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 =head1 Action Methods
 100
 101 Action methods are methods that are accessed through web (or other public) interface.
 102
 103 Inherited from L<Maypole::Model::CDBI::Base> except do_edit (below)
 104
 105 =head2 do_edit
 106
 107 If there is an object in C<$r-E<gt>objects>, then it should be edited
 108 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
 109 be created with those parameters, and put back into C<$r-E<gt>objects>.
 110 The template should be changed to C<view>, or C<edit> if there were any
 111 errors. A hash of errors will be passed to the template.
 112
 113 =cut
 114
 115 sub do_edit : Exported {
 116   my ($class, $r, $obj) = @_;
 117
 118   my $config   = $r->config;
 119   my $table    = $r->table;
 120
 121   # handle cancel button hit
 122   if ( $r->params->{cancel} ) {
 123     $r->template("list");
 124     $r->objects( [$class->retrieve_all] );
 125     return;
 126   }
 127
 128   my $required_cols = $class->required_columns;
 129   my $errors;
 130   if ($obj) {
 131     ($obj,$errors) = $class->_do_update($r,$obj);
 132   } else {
 133     ($obj,$errors) = $class->_do_create($r);
 134   }
 135
 136   # handle errors, if none, proceed to view the newly created/updated object
 137   if (ref $errors) {
 138     # pass errors to template
 139     $r->template_args->{errors} = $errors;
 140     foreach my $error (keys %$errors) {
 141       $r->template_args->{errors}{ucfirst($error)} = $errors->{$error}
 142     }
 143
 144     # Set it up as it was:
 145     $r->template_args->{cgi_params} = $r->params;
 146     $r->template("edit");
 147   } else {
 148     $r->template("view");
 149   }
 150
 151   $r->objects( $obj ? [$obj] : []);
 152 }
 153
 154 sub _do_update {
 155   my ($class,$r,$obj) = @_;
 156   my $errors;
 157   my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
 158
 159   # handle dfv errors
 160   if ( $dfv_results->has_missing ) {   # missing fields
 161     foreach my $field ( $dfv_results->missing ) {
 162       $errors->{$field} = "$field is required";
 163     }
 164   }
 165   if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
 166     foreach my $field ( $dfv_results->invalid ) {
 167       $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
 168     }
 169   }
 170
 171   my $this_class_params = { map { $_ => $r->{params}{$_} }  $class->columns  };
 172
 173   # update or make other related (must_have, might_have, has_many  etc )
 174   unless ($errors) {
 175     foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
 176       # get related object if it exists
 177       my $rel_meta = $class->related_meta('r',$accssr);
 178       if (!$rel_meta) {
 179         $class->_croak("No relationship for $accssr in " . ref($class));
 180       }
 181
 182       my $rel_type  = $rel_meta->{name};
 183       my $fclass    = $rel_meta->{foreign_class};
 184       my ($rel_obj,$errs);
 185       $rel_obj = $fclass->retrieve($r->params->{$accssr});
 186       # update or create related object
 187       ($rel_obj, $errs) = ($rel_obj)
 188         ? $fclass->_do_update($r, $rel_obj)
 189           : $obj->_create_related($accssr, $r->params);
 190       $errors->{$accssr} = $errs if ($errs);
 191     }
 192   }
 193
 194   unless ($errors) {
 195     $obj->set( %$this_class_params );
 196     $obj->update;
 197   }
 198
 199   return ($obj,$errors);
 200
 201 }
 202
 203 sub _do_create {
 204   my ($class,$r) = @_;
 205   my $errors;
 206   my $this_class_params = { map { $_ => $r->{params}{$_} }  $class->columns  };
 207   my $dfv_results;
 208   my $obj;
 209
 210   if ($class->isa('Class::DBI::DFV')) {
 211     $obj = eval { My::DBI->create( $this_class_params ) };
 212     $dfv_results = ($obj) ? undef :  $class->dfv_results ;
 213   } else {
 214     $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
 215     if ($dfv_results->success) {
 216       $obj = $class->create($this_class_params);
 217     }
 218   }
 219
 220   # handle dfv errors
 221   if ( $dfv_results->has_missing ) {   # missing fields
 222     foreach my $field ( $dfv_results->missing ) {
 223       $errors->{$field} = "$field is required";
 224     }
 225   }
 226   if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
 227     foreach my $field ( $dfv_results->invalid ) {
 228       $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
 229     }
 230   }
 231
 232   # Make other related (must_have, might_have, has_many  etc )
 233   unless ($errors) {
 234     foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
 235       my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
 236       $errors->{$accssr} = $errs if ($errs);
 237     }
 238   }
 239   return ($obj,$errors);
 240 }
 241
 242
 243 sub _create_related {
 244   # self is object or class, accssr is accssr to relationship, params are
 245   # data for relobject, and created is the array ref to store objs
 246   my ( $self, $accssr, $params )  = @_;
 247   $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
 248   my $created = [];
 249   my $rel_meta = $self->related_meta('r',$accssr);
 250   if (!$rel_meta) {
 251     $self->_croak("No relationship for $accssr in " . ref($self));
 252   }
 253
 254   my $rel_type  = $rel_meta->{name};
 255   my $fclass    = $rel_meta->{foreign_class};
 256
 257   my ($rel, $errs);
 258
 259   # Set up params for might_have, has_many, etc
 260   if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
 261     # Foreign Key meta data not very standardized in CDBI
 262     my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
 263     unless ($fkey) { die " Could not determine foreign key for $fclass"; }
 264     my %data = (%$params, $fkey => $self->id);
 265     %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
 266     ($rel, $errs) =  $fclass->_do_create(\%data);
 267   }
 268   else {
 269     ($rel, $errs) =  $fclass->_do_create($params);
 270     unless ($errs) {
 271       $self->$accssr($rel->id);
 272       $self->update;
 273     }
 274   }
 275   return ($rel, $errs);
 276 }
 277
 278
 279 =head2 do_delete
 280
 281 Inherited from Maypole::Model::CDBI::Base.
 282
 283 This action deletes records
 284
 285 =head2 do_search
 286
 287 Inherited from Maypole::Model::CDBI::Base.
 288
 289 This action method searches for database records.
 290
 291 =head2 list
 292
 293 Inherited from Maypole::Model::CDBI::Base.
 294
 295 The C<list> method fills C<$r-E<gt>objects> with all of the
 296 objects in the class. The results are paged using a pager.
 297
 298 =cut
 299
 300 sub _column_info {
 301   my $class = shift;
 302
 303   # get COLUMN INFO from DB
 304   $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
 305
 306   # update with required columns from DFV Profile
 307   my $profile = $class->dfv_profile;
 308   $class->required_columns(@{$profile->{required}});
 309
 310   return $class->COLUMN_INFO;
 311 }
 312
 313
 314
 315 =head1 SEE ALSO
 316
 317 L<Maypole::Model::Base>
 318
 319 L<Maypole::Model::CDBI::Base>
 320
 321 =head1 AUTHOR
 322
 323 Aaron Trevena.
 324
 325 =head1 LICENSE
 326
 327 You may distribute this code under the same terms as Perl itself.
 328
 329 =cut
 330
 331 1;
 332
 333