lib/Maypole/Model/CDBI/DFV.pm

   1 package Maypole::Model::CDBI::DFV;
   2 use strict;
   3
   4 =head1 NAME
   5
   6 Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole.
   7
   8 =head1 SYNOPSIS
   9
  10     package Foo;
  11     use 'Maypole::Application';
  12
  13     Foo->config->model("Maypole::Model::CDBI::DFV");
  14     Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]);
  15
  16     # Look ma, no untainting
  17
  18     sub Foo::SomeTable::SomeAction : Exported {
  19
  20         . . .
  21
  22     }
  23
  24 =head1 DESCRIPTION
  25
  26 This module allows you to use Maypole with previously set-up
  27 L<Class::DBI> classes that use Class::DBI::DFV;
  28
  29 Simply call C<setup> with a list reference of the classes you're going to use,
  30 and Maypole will work out the tables and set up the inheritance relationships
  31 as normal.
  32
  33 Better still, it will also set use your DFV profile to validate input instead
  34 of CGI::Untaint. For teh win!!
  35
  36 =cut
  37
  38 use Class::C3;
  39 use Data::FormValidator;
  40 use Data::Dumper;
  41
  42 use Maypole::Config;
  43 use Maypole::Model::CDBI::AsForm;
  44
  45 use base qw(Maypole::Model::CDBI::Base);
  46
  47 Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));
  48
  49 =head1 METHODS
  50
  51 =head2 setup
  52
  53   This method is inherited from Maypole::Model::Base and calls setup_database,
  54   which uses Class::DBI::Loader to create and load Class::DBI classes from
  55   the given database schema.
  56
  57 =head2 setup_database
  58
  59   This method loads the model classes for the application
  60
  61 =cut
  62
  63 sub setup_database {
  64     my ( $self, $config, $namespace, $classes ) = @_;
  65     $config->{classes}        = $classes;
  66     foreach my $class (@$classes) {
  67       $namespace->load_model_subclass($class);
  68     }
  69     $namespace->model_classes_loaded(1);
  70     $config->{table_to_class} = { map { $_->table => $_ } @$classes };
  71     $config->{tables}         = [ keys %{ $config->{table_to_class} } ];
  72 }
  73
  74 =head2 class_of
  75
  76   returns class for given table
  77
  78 =cut
  79
  80 sub class_of {
  81     my ( $self, $r, $table ) = @_;
  82     return $r->config->{table_to_class}->{$table};
  83 }
  84
  85 =head2 adopt
  86
  87 This class method is passed the name of a model class that represensts a table
  88 and allows the master model class to do any set-up required.
  89
  90 =cut
  91
  92 sub adopt {
  93     my ( $self, $child ) = @_;
  94     if ( my $col = $child->stringify_column ) {
  95         $child->columns( Stringify => $col );
  96     }
  97 }
  98
  99 =head2 check_params
 100
 101   Checks parameters against the DFV profile for the class, returns the results
 102   of DFV's check.
 103
 104   my $dfv_results = __PACKAGE__->check_params($r->params);
 105
 106 =cut
 107
 108 sub check_params {
 109   my ($class,$params) = @_;
 110   return Data::FormValidator->check($params, $class->dfv_profile);
 111 }
 112
 113
 114 =head1 Action Methods
 115
 116 Action methods are methods that are accessed through web (or other public) interface.
 117
 118 Inherited from L<Maypole::Model::CDBI::Base> except do_edit (below)
 119
 120 =head2 do_edit
 121
 122 If there is an object in C<$r-E<gt>objects>, then it should be edited
 123 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
 124 be created with those parameters, and put back into C<$r-E<gt>objects>.
 125 The template should be changed to C<view>, or C<edit> if there were any
 126 errors. A hash of errors will be passed to the template.
 127
 128 =cut
 129
 130 sub do_edit : Exported {
 131   my ($class, $r, $obj) = @_;
 132
 133   my $config   = $r->config;
 134   my $table    = $r->table;
 135
 136   # handle cancel button hit
 137   if ( $r->params->{cancel} ) {
 138     $r->template("list");
 139     $r->objects( [$class->retrieve_all] );
 140     return;
 141   }
 142
 143
 144   my $errors;
 145   if ($obj) {
 146     ($obj,$errors) = $class->_do_update($r,$obj);
 147   } else {
 148     ($obj,$errors) = $class->_do_create($r);
 149   }
 150
 151   # handle errors, if none, proceed to view the newly created/updated object
 152   if (ref $errors) {
 153     # pass errors to template
 154     $r->template_args->{errors} = $errors;
 155     # Set it up as it was:
 156     $r->template_args->{cgi_params} = $r->params;
 157     $r->template("edit");
 158   } else {
 159     $r->template("view");
 160   }
 161
 162   $r->objects( $obj ? [$obj] : []);
 163 }
 164
 165 sub _do_update {
 166   my ($class,$r,$obj) = @_;
 167   my $errors;
 168   my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
 169
 170   # handle dfv errors
 171   if ( $dfv_results->has_missing ) {   # missing fields
 172     foreach my $field ( $dfv_results->missing ) {
 173       $errors->{$field} = "$field is required";
 174     }
 175   }
 176   if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
 177     foreach my $field ( $dfv_results->invalid ) {
 178       $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
 179     }
 180   }
 181
 182
 183   my $this_class_params = {};
 184
 185
 186   # NG changes start here.
 187   # Code below fails to handle multi col PKs
 188   my @pks = $class->columns('Primary');
 189
 190   foreach my $param ( $class->columns ) {
 191     # next if ($param eq $class->columns('Primary'));
 192     next if grep {/^${param}$/} @pks;
 193
 194     my $value = $r->params->{$param};
 195     next unless (defined $value);
 196     $this_class_params->{$param} = ( $value eq '' ) ?  undef : $value;
 197   }
 198
 199   # update or make other related (must_have, might_have, has_many  etc )
 200   unless ($errors) {
 201     foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
 202       # get related object if it exists
 203       my $rel_meta = $class->related_meta('r',$accssr);
 204       if (!$rel_meta) {
 205         $r->warn("[_do_update] No relationship for $accssr in " . ref($class));
 206         next;
 207       }
 208
 209       my $rel_type  = $rel_meta->{name};
 210       my $fclass    = $rel_meta->{foreign_class};
 211       my ($rel_obj,$errs);
 212       $rel_obj = $fclass->retrieve($r->params->{$accssr});
 213       # update or create related object
 214       ($rel_obj, $errs) = ($rel_obj)
 215         ? $fclass->_do_update($r, $rel_obj)
 216           : $obj->_create_related($accssr, $r->params);
 217       $errors->{$accssr} = $errs if ($errs);
 218     }
 219   }
 220
 221   unless ($errors) {
 222     $obj->set( %$this_class_params );
 223     $obj->update;
 224   }
 225
 226   return ($obj,$errors);
 227 }
 228
 229 sub _do_create {
 230   my ($class,$r) = @_;
 231   my $errors;
 232
 233   my $this_class_params = {};
 234   foreach my $param ( $class->columns ) {
 235     next if ($param eq $class->columns('Primary'));
 236     my $value = $r->params->{$param};
 237     next unless (defined $value);
 238     $this_class_params->{$param} = ( $value eq '' ) ?  undef : $value;
 239   }
 240
 241   my $obj;
 242
 243   my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
 244   if ($dfv_results->success) {
 245     $obj = $class->create($this_class_params);
 246   } else {
 247     # handle dfv errors
 248     if ( $dfv_results->has_missing ) {   # missing fields
 249       foreach my $field ( $dfv_results->missing ) {
 250         $errors->{$field} = "$field is required";
 251       }
 252     }
 253     if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
 254       foreach my $field ( $dfv_results->invalid ) {
 255         $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
 256       }
 257     }
 258   }
 259
 260   # Make other related (must_have, might_have, has_many  etc )
 261   unless ($errors) {
 262     foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
 263       my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
 264       $errors->{$accssr} = $errs if ($errs);
 265     }
 266   }
 267   return ($obj,$errors);
 268 }
 269
 270
 271 sub _create_related {
 272   # self is object or class, accssr is accssr to relationship, params are
 273   # data for relobject, and created is the array ref to store objs
 274   my ( $self, $accssr, $params )  = @_;
 275   $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
 276   my $created = [];
 277   my $rel_meta = $self->related_meta('r',$accssr);
 278   if (!$rel_meta) {
 279     $self->_carp("[_create_related] No relationship for $accssr in " . ref($self));
 280     return;
 281   }
 282
 283   my $rel_type  = $rel_meta->{name};
 284   my $fclass    = $rel_meta->{foreign_class};
 285
 286   my ($rel, $errs);
 287
 288   # Set up params for might_have, has_many, etc
 289   if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
 290     # Foreign Key meta data not very standardized in CDBI
 291     my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
 292     unless ($fkey) { die " Could not determine foreign key for $fclass"; }
 293     my %data = (%$params, $fkey => $self->id);
 294     %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
 295     ($rel, $errs) =  $fclass->_do_create(\%data);
 296   }
 297   else {
 298     ($rel, $errs) =  $fclass->_do_create($params);
 299     unless ($errs) {
 300       $self->$accssr($rel->id);
 301       $self->update;
 302     }
 303   }
 304   return ($rel, $errs);
 305 }
 306
 307
 308 =head2 do_delete
 309
 310 Inherited from Maypole::Model::CDBI::Base.
 311
 312 This action deletes records
 313
 314 =head2 do_search
 315
 316 Inherited from Maypole::Model::CDBI::Base.
 317
 318 This action method searches for database records.
 319
 320 =head2 list
 321
 322 Inherited from Maypole::Model::CDBI::Base.
 323
 324 The C<list> method fills C<$r-E<gt>objects> with all of the
 325 objects in the class. The results are paged using a pager.
 326
 327 =cut
 328
 329 sub _column_info {
 330   my $class = shift;
 331
 332   # get COLUMN INFO from DB
 333   $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
 334
 335   # update with required columns from DFV Profile
 336   my $profile = $class->dfv_profile;
 337   $class->required_columns($profile->{required});
 338
 339   return $class->COLUMN_INFO;
 340 }
 341
 342
 343
 344 =head1 SEE ALSO
 345
 346 L<Maypole::Model::Base>
 347
 348 L<Maypole::Model::CDBI::Base>
 349
 350 =head1 AUTHOR
 351
 352 Aaron Trevena.
 353
 354 =head1 LICENSE
 355
 356 You may distribute this code under the same terms as Perl itself.
 357
 358 =cut
 359
 360 1;
 361
 362