package Maypole::Model::CDBI::DFV;
-use Class::C3;
-use Maypole::Config;
-use base qw(Maypole::Model::Base);
use strict;
-Maypole::Config->mk_accessors(qw(table_to_class));
-
=head1 NAME
-Maypole::Model::CDBI::Plain - Class::DBI model without ::Loader
+Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole.
=head1 SYNOPSIS
Better still, it will also set use your DFV profile to validate input instead
of CGI::Untaint. For teh win!!
+=cut
+
+use Class::C3;
+use Maypole::Config;
+use Data::FormValidator;
+use Maypole::Model::CDBI::AsForm;
+
+use base qw(Maypole::Model::Base);
+
+Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));
+
=head1 METHODS
=head2 setup
return $r->config->{table_to_class}->{$table};
}
-=head2 add_model_superclass
-
-Adds model as superclass to model classes
-
-=cut
-
-sub add_model_superclass {
- my ($class,$config) = @_;
- foreach my $subclass ( @{ $config->classes } ) {
- next if $subclass->isa("Maypole::Model::Base");
- no strict 'refs';
- push @{ $subclass . "::ISA" }, $config->model;
- }
- return;
-}
-
=head2 adopt
This class method is passed the name of a model class that represensts a table
}
}
+=head1 Action Methods
+
+Action methods are methods that are accessed through web (or other public) interface.
+
+Inherited from L<Maypole::Model::CDBI::Base> except do_edit (below)
+
+=head2 do_edit
+
+If there is an object in C<$r-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> if there were any
+errors. A hash of errors will be passed to the template.
+
+=cut
+
+sub do_edit : Exported {
+ my ($class, $r, $obj) = @_;
+
+ my $config = $r->config;
+ my $table = $r->table;
+
+ # handle cancel button hit
+ if ( $r->params->{cancel} ) {
+ $r->template("list");
+ $r->objects( [$class->retrieve_all] );
+ return;
+ }
+
+ my $required_cols = $class->required_columns;
+ my $errors;
+ if ($obj) {
+ ($obj,$errors) = $class->_do_update($r,$obj);
+ } else {
+ ($obj,$errors) = $class->_do_create($r);
+ }
+
+ # handle errors, if none, proceed to view the newly created/updated object
+ if (ref $errors) {
+ # pass errors to template
+ $r->template_args->{errors} = $errors;
+ foreach my $error (keys %$errors) {
+ $r->template_args->{errors}{ucfirst($error)} = $errors->{$error}
+ }
+
+ # Set it up as it was:
+ $r->template_args->{cgi_params} = $r->params;
+ $r->template("edit");
+ } else {
+ $r->template("view");
+ }
+
+ $r->objects( $obj ? [$obj] : []);
+}
+
+sub _do_update {
+ my ($class,$r,$obj) = @_;
+ my $errors;
+ my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
+
+ # handle dfv errors
+ if ( $dfv_results->has_missing ) { # missing fields
+ foreach my $field ( $dfv_results->missing ) {
+ $errors->{$field} = "$field is required";
+ }
+ }
+ if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
+ foreach my $field ( $dfv_results->invalid ) {
+ $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
+ }
+ }
+
+ my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
+
+ # update or make other related (must_have, might_have, has_many etc )
+ unless ($errors) {
+ foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
+ # get related object if it exists
+ my $rel_meta = $class->related_meta('r',$accssr);
+ if (!$rel_meta) {
+ $class->_croak("No relationship for $accssr in " . ref($class));
+ }
+
+ my $rel_type = $rel_meta->{name};
+ my $fclass = $rel_meta->{foreign_class};
+ my ($rel_obj,$errs);
+ $rel_obj = $fclass->retrieve($r->params->{$accssr});
+ # update or create related object
+ ($rel_obj, $errs) = ($rel_obj)
+ ? $fclass->_do_update($r, $rel_obj)
+ : $obj->_create_related($accssr, $r->params);
+ $errors->{$accssr} = $errs if ($errs);
+ }
+ }
+
+ unless ($errors) {
+ $obj->set( %$this_class_params );
+ $obj->update;
+ }
+
+ return ($obj,$errors);
+
+}
+
+sub _do_create {
+ my ($class,$r) = @_;
+ my $errors;
+ my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
+ my $obj = eval { My::DBI->create( $this_class_params ) };
+
+ my $dfv_results = ($obj) ? undef : $class->dfv_results->msgs ;
+
+ # handle dfv errors
+ if ( $dfv_results->has_missing ) { # missing fields
+ foreach my $field ( $dfv_results->missing ) {
+ $errors->{$field} = "$field is required";
+ }
+ }
+ if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
+ foreach my $field ( $dfv_results->invalid ) {
+ $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
+ }
+ }
+
+ # Make other related (must_have, might_have, has_many etc )
+ unless ($errors) {
+ foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
+ my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
+ $errors->{$accssr} = $errs if ($errs);
+ }
+ }
+ return ($obj,$errors);
+}
+
+
+sub _create_related {
+ # self is object or class, accssr is accssr to relationship, params are
+ # data for relobject, and created is the array ref to store objs
+ my ( $self, $accssr, $params ) = @_;
+ $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
+ my $created = [];
+ my $rel_meta = $self->related_meta('r',$accssr);
+ if (!$rel_meta) {
+ $self->_croak("No relationship for $accssr in " . ref($self));
+ }
+
+ my $rel_type = $rel_meta->{name};
+ my $fclass = $rel_meta->{foreign_class};
+
+ my ($rel, $errs);
+
+ # Set up params for might_have, has_many, etc
+ if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
+ # Foreign Key meta data not very standardized in CDBI
+ my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
+ unless ($fkey) { die " Could not determine foreign key for $fclass"; }
+ my %data = (%$params, $fkey => $self->id);
+ %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
+ ($rel, $errs) = $fclass->_do_create(\%data);
+ }
+ else {
+ ($rel, $errs) = $fclass->_do_create($params);
+ unless ($errs) {
+ $self->$accssr($rel->id);
+ $self->update;
+ }
+ }
+ return ($rel, $errs);
+}
+
+
+=head2 do_delete
+
+Inherited from Maypole::Model::CDBI::Base.
+
+This action deletes records
+
+=head2 do_search
+
+Inherited from Maypole::Model::CDBI::Base.
+
+This action method searches for database records.
+
+=head2 list
+
+Inherited from Maypole::Model::CDBI::Base.
+
+The C<list> method fills C<$r-E<gt>objects> with all of the
+objects in the class. The results are paged using a pager.
+
+=cut
+
+sub _column_info {
+ my $class = shift;
+
+ # get COLUMN INFO from DB
+ $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
+
+ # update with required columns from DFV Profile
+ my $profile = $class->dfv_profile;
+ $class->required_columns(@{$profile->{required}});
+
+ return $class->COLUMN_INFO;
+}
+
+
+
=head1 SEE ALSO
L<Maypole::Model::Base>
-L<Maypole::Model::CDBI>
+L<Maypole::Model::CDBI::Base>
-=cut
+=head1 AUTHOR
+
+Aaron Trevena.
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
1;
projects / maypole.git / blobdiff