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