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