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 $obj = eval { My::DBI->create( $this_class_params ) };
 204
 205   my $dfv_results = ($obj) ? undef :  $class->dfv_results->msgs ;
 206
 207   # handle dfv errors
 208   if ( $dfv_results->has_missing ) {   # missing fields
 209     foreach my $field ( $dfv_results->missing ) {
 210       $errors->{$field} = "$field is required";
 211     }
 212   }
 213   if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
 214     foreach my $field ( $dfv_results->invalid ) {
 215       $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
 216     }
 217   }
 218
 219   # Make other related (must_have, might_have, has_many  etc )
 220   unless ($errors) {
 221     foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
 222       my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
 223       $errors->{$accssr} = $errs if ($errs);
 224     }
 225   }
 226   return ($obj,$errors);
 227 }
 228
 229
 230 sub _create_related {
 231   # self is object or class, accssr is accssr to relationship, params are
 232   # data for relobject, and created is the array ref to store objs
 233   my ( $self, $accssr, $params )  = @_;
 234   $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
 235   my $created = [];
 236   my $rel_meta = $self->related_meta('r',$accssr);
 237   if (!$rel_meta) {
 238     $self->_croak("No relationship for $accssr in " . ref($self));
 239   }
 240
 241   my $rel_type  = $rel_meta->{name};
 242   my $fclass    = $rel_meta->{foreign_class};
 243
 244   my ($rel, $errs);
 245
 246   # Set up params for might_have, has_many, etc
 247   if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
 248     # Foreign Key meta data not very standardized in CDBI
 249     my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
 250     unless ($fkey) { die " Could not determine foreign key for $fclass"; }
 251     my %data = (%$params, $fkey => $self->id);
 252     %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
 253     ($rel, $errs) =  $fclass->_do_create(\%data);
 254   }
 255   else {
 256     ($rel, $errs) =  $fclass->_do_create($params);
 257     unless ($errs) {
 258       $self->$accssr($rel->id);
 259       $self->update;
 260     }
 261   }
 262   return ($rel, $errs);
 263 }
 264
 265
 266 =head2 do_delete
 267
 268 Inherited from Maypole::Model::CDBI::Base.
 269
 270 This action deletes records
 271
 272 =head2 do_search
 273
 274 Inherited from Maypole::Model::CDBI::Base.
 275
 276 This action method searches for database records.
 277
 278 =head2 list
 279
 280 Inherited from Maypole::Model::CDBI::Base.
 281
 282 The C<list> method fills C<$r-E<gt>objects> with all of the
 283 objects in the class. The results are paged using a pager.
 284
 285 =cut
 286
 287 sub _column_info {
 288   my $class = shift;
 289
 290   # get COLUMN INFO from DB
 291   $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
 292
 293   # update with required columns from DFV Profile
 294   my $profile = $class->dfv_profile;
 295   $class->required_columns(@{$profile->{required}});
 296
 297   return $class->COLUMN_INFO;
 298 }
 299
 300
 301
 302 =head1 SEE ALSO
 303
 304 L<Maypole::Model::Base>
 305
 306 L<Maypole::Model::CDBI::Base>
 307
 308 =head1 AUTHOR
 309
 310 Aaron Trevena.
 311
 312 =head1 LICENSE
 313
 314 You may distribute this code under the same terms as Perl itself.
 315
 316 =cut
 317
 318 1;
 319
 320