--- /dev/null
+package Maypole::Model::CDBI::DFV;
+use strict;
+
+=head1 NAME
+
+Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole.
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use 'Maypole::Application';
+
+ Foo->config->model("Maypole::Model::CDBI::DFV");
+ Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]);
+
+ # Look ma, no untainting
+
+ sub Foo::SomeTable::SomeAction : Exported {
+
+ . . .
+
+ }
+
+=head1 DESCRIPTION
+
+This module allows you to use Maypole with previously set-up
+L<Class::DBI> classes that use Class::DBI::DFV;
+
+Simply call C<setup> with a list reference of the classes you're going to use,
+and Maypole will work out the tables and set up the inheritance relationships
+as normal.
+
+Better still, it will also set use your DFV profile to validate input instead
+of CGI::Untaint. For teh win!!
+
+=cut
+
+use Data::FormValidator;
+use Data::Dumper;
+
+use Maypole::Config;
+use Maypole::Model::CDBI::AsForm;
+
+use base qw(Maypole::Model::CDBI::Base);
+
+Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));
+
+=head1 METHODS
+
+=head2 setup
+
+ This method is inherited from Maypole::Model::Base and calls setup_database,
+ which uses Class::DBI::Loader to create and load Class::DBI classes from
+ the given database schema.
+
+=head2 setup_database
+
+ This method loads the model classes for the application
+
+=cut
+
+sub setup_database {
+ my ( $self, $config, $namespace, $classes ) = @_;
+ $config->{classes} = $classes;
+ foreach my $class (@$classes) {
+ $namespace->load_model_subclass($class);
+ }
+ $namespace->model_classes_loaded(1);
+ $config->{table_to_class} = { map { $_->table => $_ } @$classes };
+ $config->{tables} = [ keys %{ $config->{table_to_class} } ];
+}
+
+=head2 class_of
+
+ returns class for given table
+
+=cut
+
+sub class_of {
+ my ( $self, $r, $table ) = @_;
+ return $r->config->{table_to_class}->{$table};
+}
+
+=head2 adopt
+
+This class method is passed the name of a model class that represensts a table
+and allows the master model class to do any set-up required.
+
+=cut
+
+sub adopt {
+ my ( $self, $child ) = @_;
+ if ( my $col = $child->stringify_column ) {
+ $child->columns( Stringify => $col );
+ }
+}
+
+=head2 check_params
+
+ Checks parameters against the DFV profile for the class, returns the results
+ of DFV's check.
+
+ my $dfv_results = __PACKAGE__->check_params($r->params);
+
+=cut
+
+sub check_params {
+ my ($class,$params) = @_;
+ return Data::FormValidator->check($params, $class->dfv_profile);
+}
+
+
+=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 $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;
+ # 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 = {};
+
+
+ # NG changes start here.
+ # Code below fails to handle multi col PKs
+ my @pks = $class->columns('Primary');
+
+ foreach my $param ( $class->columns ) {
+ # next if ($param eq $class->columns('Primary'));
+ next if grep {/^${param}$/} @pks;
+
+ my $value = $r->params->{$param};
+ next unless (defined $value);
+ $this_class_params->{$param} = ( $value eq '' ) ? undef : $value;
+ }
+
+ # 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) {
+ $r->warn("[_do_update] No relationship for $accssr in " . ref($class));
+ next;
+ }
+
+ 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 = {};
+ foreach my $param ( $class->columns ) {
+ next if ($param eq $class->columns('Primary'));
+ my $value = $r->params->{$param};
+ next unless (defined $value);
+ $this_class_params->{$param} = ( $value eq '' ) ? undef : $value;
+ }
+
+ my $obj;
+
+ my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
+ if ($dfv_results->success) {
+ $obj = $class->create($this_class_params);
+ } else {
+ # 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->_carp("[_create_related] No relationship for $accssr in " . ref($self));
+ return;
+ }
+
+ 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::Base>
+
+=head1 AUTHOR
+
+Aaron Trevena.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
+
+
projects / maypole.git / blobdiff