lib/Maypole/Model/CDBI/FromCGI.pm

   1 package Maypole::Model::CDBI::FromCGI;
   2 use strict;
   3
   4 =head1 NAME
   5
   6 Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects
   7
   8 =head1 SYNOPSIS
   9
  10   $obj = $class->create_from_cgi($r);
  11   $obj = $class->create_from_cgi($r, { params => {data1=>...}, required => [..],
  12                  ignore => [...], all => [...]);
  13   $obj = $class->create_from_cgi($h, $options); # CDBI::FromCGI style, see docs
  14
  15   $obj->update_from_cgi($r);
  16   $obj->update_from_cgi($h, $options);
  17
  18   $obj = $obj->add_to_from_cgi($r);
  19   $obj = $obj->add_to_from_cgi($r, { params => {...} } );
  20
  21   # This does not work like in CDBI::FromCGI and probably never will :
  22   # $class->update_from_cgi($h, @columns);
  23
  24
  25 =head1 DESCRIPTION
  26
  27 Provides a way to validate form input and populate Model Objects, based
  28 on Class::DBI::FromCGI.
  29
  30 =cut
  31
  32 use warnings;
  33
  34 # The base base model class for apps
  35 # provides good search and create functions
  36
  37 use base qw(Exporter);
  38 use CGI::Untaint;
  39 use Maypole::Constants;
  40 use CGI::Untaint::Maypole;
  41 our $Untainter = 'CGI::Untaint::Maypole';
  42
  43 our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns add_to_from_cgi
  44     cgi_update_errors untaint_type validate_inputs validate_all _do_update_all
  45     _do_create_all _create_related classify_form_inputs/;
  46
  47
  48
  49 use Data::Dumper; # for debugging
  50
  51 =head1 METHODS
  52
  53 =head2 untaint_columns
  54
  55 Replicates Class::DBI::FromCGI method of same name :
  56
  57   __PACKAGE__->untaint_columns(
  58     printable => [qw/Title Director/],
  59     integer   => [qw/DomesticGross NumExplodingSheep],
  60     date      => [qw/OpeningDate/],
  61   );
  62
  63 =cut
  64
  65 sub untaint_columns {
  66     die "untaint_columns() needs a hash" unless @_ % 2;
  67     my ($class, %args) = @_;
  68     $class->mk_classdata('__untaint_types')
  69         unless $class->can('__untaint_types');
  70     my %types = %{ $class->__untaint_types || {} };
  71     while (my ($type, $ref) = each(%args)) {
  72         $types{$type} = $ref;
  73     }
  74     $class->__untaint_types(\%types);
  75 }
  76
  77 =head2 untaint_type
  78
  79   gets the  untaint type for a column as set in "untaint_types"
  80
  81 =cut
  82
  83 # get/set untaint_type for a column
  84 sub untaint_type {
  85     my ($class, $field, $new_type) = @_;
  86     my %handler = __PACKAGE__->_untaint_handlers($class);
  87     return $handler{$field} if $handler{$field};
  88     my $handler = eval {
  89         local $SIG{__WARN__} = sub { };
  90         my $type = $class->column_type($field) or die;
  91         _column_type_for($type);
  92     };
  93     return $handler || undef;
  94 }
  95
  96 =head2 cgi_update_errors
  97
  98 Returns errors that ocurred during an operation.
  99
 100 =cut
 101
 102 sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
 103
 104
 105
 106 =head2 create_from_cgi
 107
 108 Based on the same method in Class::DBI::FromCGI.
 109
 110 Creates  multiple objects  from a  cgi form.
 111 Errors are returned in cgi_update_errors
 112
 113 It can be called Maypole style passing the Maypole request object as the
 114 first arg, or Class::DBI::FromCGI style passing the Untaint Handler ($h)
 115 as the first arg.
 116
 117 A hashref of options can be passed as the second argument. Unlike
 118 in the CDBI equivalent, you can *not* pass a list as the second argument.
 119 Options can be :
 120  params -- hashref of cgi data to use instead of $r->params,
 121  required -- list of fields that are required
 122  ignore   -- list of fields to ignore
 123  all      -- list of all fields (defaults to $class->columns)
 124
 125 =cut
 126
 127 sub create_from_cgi {
 128   my ($self, $r, $opts) = @_;
 129   $self->_croak( "create_from_cgi can only be called as a class method")
 130     if ref $self;
 131   my ($errors, $validated);
 132
 133
 134   if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility
 135     ($validated, $errors) = $self->validate_inputs($r,$opts);
 136   } else {
 137     my $params = $opts->{params} || $r->params;
 138     $opts->{params} = $self->classify_form_inputs($params);
 139     ($validated, $errors) = $self->validate_all($r, $opts);
 140   }
 141
 142   if (keys %$errors) {
 143     return bless { _cgi_update_error => $errors }, $self;
 144   }
 145
 146   # Insert all the data
 147   my ($obj, $err ) = $self->_do_create_all($validated);
 148   if ($err) {
 149     return bless { _cgi_update_error => $err }, $self;
 150   }
 151   return $obj;
 152 }
 153
 154
 155 =head2 update_from_cgi
 156
 157 Replicates the Class::DBI::FromCGI method of same name. It updates an object and
 158 returns 1 upon success. It can take the same arguments as create_form_cgi.
 159 If errors, it sets the cgi_update_errors.
 160
 161 =cut
 162
 163 sub update_from_cgi {
 164   my ($self, $r, $opts) = @_;
 165   $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
 166   my ($errors, $validated);
 167   $self->{_cgi_update_error} = {};
 168   $opts->{updating} = 1;
 169
 170   # FromCGI interface compatibility
 171   if ($r->isa('CGI::Untaint')) {
 172     # REHASH the $opts for updating:
 173     # 1: we ignore any fields we dont have parmeter for. (safe ?)
 174     # 2: we dont want to update fields unless they change
 175
 176     my @ignore = @{$opts->{ignore} || []};
 177     push @ignore, $self->primary_column->name;
 178     my $raw = $r->raw_data;
 179     #print "*** raw data ****" . Dumper($raw);
 180     foreach my $field ($self->columns) {
 181       #print "*** field is $field ***\n";
 182         if (not defined $raw->{$field}) {
 183                         push @ignore, $field->name;
 184                         #print "*** ignoring $field because it is not present ***\n";
 185                         next;
 186         }
 187         # stupid inflation , cant get at raw db value easy, must call
 188         # deflate ***FIXME****
 189         my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
 190         if ($raw->{$field} eq $cur_val) {
 191                         #print "*** ignoring $field because unchanged ***\n";
 192                         push @ignore, "$field";
 193         }
 194     }
 195     $opts->{ignore} = \@ignore;
 196     ($validated, $errors) = $self->validate_inputs($r,$opts);
 197   } else {
 198     my $params = $opts->{params} || $r->params;
 199     $opts->{params} = $self->classify_form_inputs($params);
 200     ($validated, $errors) = $self->validate_all($r, $opts);
 201     #print "*** errors for validate all   ****" . Dumper($errors);
 202   }
 203
 204   if (keys %$errors) {
 205     #print "*** we have errors   ****" . Dumper($errors);
 206     $self->{_cgi_update_error} = $errors;
 207     return;
 208   }
 209
 210   # Update all the data
 211   my ($obj, $err ) = $self->_do_update_all($validated);
 212   if ($err) {
 213     $self->{_cgi_update_error} = $err;
 214     return;
 215   }
 216   return 1;
 217 }
 218
 219 =head2 add_to_from_cgi
 220
 221 $obj->add_to_from_cgi($r[, $opts]);
 222
 223 Like add_to_* for has_many relationships but will add nay objects it can
 224 figure out from the data.  It returns a list of objects it creates or nothing
 225 on error. Call cgi_update_errors with the calling object to get errors.
 226 Fatal errors are in the respective "FATAL" key.
 227
 228 =cut
 229
 230 sub add_to_from_cgi {
 231   my ($self, $r, $opts) = @_;
 232   $self->_croak( "add_to_from_cgi can only be called as an object method")
 233     unless ref $self;
 234   my ($errors, $validated, @created);
 235
 236
 237   my $params = $opts->{params} || $r->params;
 238   $opts->{params} = $self->classify_form_inputs($params);
 239   ($validated, $errors) = $self->validate_all($r, $opts);
 240
 241
 242   if (keys %$errors) {
 243     $self->{_cgi_update_error} = $errors;
 244         return;
 245   }
 246
 247   # Insert all the data
 248   foreach my $hm (keys %$validated) {
 249         my ($obj, $errs) = $self->_create_related($hm, $validated->{$hm});
 250         if (not $errs) {
 251                 push @created, $obj;
 252         }else {
 253                 $errors->{$hm} = $errs;
 254         }
 255   }
 256
 257   if (keys %$errors) {
 258     $self->{_cgi_update_error} = $errors;
 259         return;
 260   }
 261
 262   return @created;
 263 }
 264
 265
 266
 267
 268 =head2 validate_all
 269
 270 Validates (untaints) a hash of possibly mixed table data.
 271 Returns validated and errors ($validated, $errors).
 272 If no errors then undef in that spot.
 273
 274 =cut
 275
 276 sub validate_all {
 277   my ($self, $r, $opts) = @_;
 278   my $class = ref $self || $self;
 279   my $classified = $opts->{params};
 280   my $updating   = $opts->{updating};
 281
 282   # Base case - validate this classes data
 283   $opts->{all}   ||= eval{ $r->config->{$self->table}{all_cols} }               ||
 284     [$self->columns('All')];
 285   $opts->{required} ||= eval{ $r->config->{$self->table}{required_cols} } ||
 286         [];
 287   my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} }
 288     || [];
 289   push @$ignore, $self->primary_column->name if $updating;
 290
 291   # Ignore hashes of foreign inputs. This takes care of required has_a's
 292   # for main object that we have foreign inputs for.
 293   foreach (keys %$classified) {
 294     push @$ignore, $_ if  ref $classified->{$_} eq 'HASH';
 295   }
 296   $opts->{ignore} = $ignore;
 297   my $h = $Untainter->new($classified);
 298   my ($validated, $errs) = $self->validate_inputs($h, $opts);
 299
 300   # Validate all foreign input
 301
 302   #warn "Classified data is " . Dumper($classified);
 303   foreach my $field (keys %$classified) {
 304     if (ref $classified->{$field} eq "HASH") {
 305       my $data = $classified->{$field};
 306           my $ignore = [];
 307       my @usr_entered_vals = ();
 308       foreach ( values %$data ) {
 309                 push @usr_entered_vals, $_  if $_  ne '';
 310       }
 311
 312       # filled in values
 313       # IF we have some inputs for the related
 314       if ( @usr_entered_vals ) {
 315                 # We need to ignore us if we are a required has_a in this foreign class
 316                 my $rel_meta = $self->related_meta($r, $field);
 317             my $fclass   = $rel_meta->{foreign_class};
 318                 my $fmeta    = $fclass->meta_info('has_a');
 319                 for (keys %$fmeta) {
 320                         if ($fmeta->{$_}{foreign_class} eq $class) {
 321                                 push @$ignore, $_;
 322                         }
 323                 }
 324                 my ($valid, $ferrs) = $fclass->validate_all($r,
 325                 {params => $data, updating => $updating, ignore => $ignore } );
 326
 327                 $errs->{$field} = $ferrs if $ferrs;
 328                 $validated->{$field} = $valid;
 329
 330       } else {
 331                 # Check this foreign object is not requeired
 332                 my %req = map { $_ => 1 } $opts->{required};
 333                 if ($req{$field}) {
 334                         $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
 335                         }
 336                 }
 337         }
 338   }
 339   #warn "Validated inputs are " . Dumper($validated);
 340   undef $errs unless keys %$errs;
 341   return ($validated, $errs);
 342 }
 343
 344
 345 # validate_inputs undocumented. It is not yet part of the public interface.
 346 #=head2 validate_inputs
 347 #
 348 #$self->validate_inputs($h, $opts);
 349 #
 350 #This is the main validation method to validate inputs for a single class.
 351 #Most of the time you use validate_all.
 352 #
 353 # Returns validated and errors.
 354 # If no errors then undef in that slot.
 355 #
 356 #=cut
 357
 358 sub validate_inputs {
 359   my ($self, $h, $opts) = @_;
 360   my $updating = $opts->{updating};
 361   my %required = map { $_ => 1 } @{$opts->{required}};
 362   my %seen;
 363   $seen{$_}++ foreach @{$opts->{ignore}};
 364   my $errors    = {};
 365   my $fields    = {};
 366   $opts->{all} = [ $self->columns ] unless @{$opts->{all} || [] } ;
 367   foreach my $field (@{$opts->{required}}, @{$opts->{all}}) {
 368     next if $seen{$field}++;
 369     my $type = $self->untaint_type($field) or
 370       do { warn "No untaint type for $self 's field $field. Ignoring.";
 371            next;
 372          };
 373     my $value = $h->extract("-as_$type" => $field);
 374     my $err = $h->error;
 375
 376     # Required field error
 377     if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
 378                                 #($value eq '' or !defined $value))
 379       $errors->{$field} = "You must supply '$field'"
 380         #unless ($updating and$self->field;
 381     } elsif ($err) {
 382
 383       # 1: No inupt entered
 384       if ($err =~ /^No input for/) {
 385                                 # A : Updating -- set the field to undef or ''
 386         if ($updating) {
 387           $fields->{$field} = eval{$self->column_nullable($field)} ?
 388             undef : '';
 389         }
 390                                 # B : Creating -- dont set a value and RDMS will put default
 391       }
 392
 393       # 2: A real untaint error -- just set the error
 394       elsif ($err !~ /^No parameter for/) {
 395         $errors->{$field} =  $err;
 396       }
 397     } else {
 398       $fields->{$field} = $value
 399     }
 400   }
 401   undef $errors unless keys %$errors;
 402   return ($fields, $errors);
 403 }
 404
 405
 406 ##################
 407 # _do_create_all #
 408 ##################
 409
 410 # Untaints and Creates objects from hashed params.
 411 # Returns parent object and errors ($obj, $errors).
 412 # If no errors, then undef in that slot.
 413 sub _do_create_all {
 414   my ($self, $validated) = @_;
 415   my $class = ref $self  || $self;
 416   my ($errors, $accssr);
 417
 418   # Separate out related objects' data from main hash
 419   my %related;
 420   foreach (keys %$validated) {
 421     $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
 422   }
 423   # Make has_own/a rel type objects and put id in parent's data hash
 424 #  foreach $accssr (keys %related) {
 425 #    my $rel_meta = $self->related_meta('r', $accssr);
 426 #    $self->_croak("No relationship found for $accssr to $class.")
 427 #      unless $rel_meta;
 428 #    my $rel_type   = $rel_meta->{name};
 429 #    if ($rel_type =~ /(^has_own$|^has_a$)/) {
 430 #      my $fclass= $rel_meta->{foreign_class};
 431 #      my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr});
 432 #      # put id in parent's data hash
 433 #      if (not keys %$errs) {
 434 #       $validated->{$accssr} = $rel_obj->id;
 435 #      } else {
 436 #       $errors->{$accssr} = $errs;
 437 #      }
 438 #      delete $related{$accssr}; # done with this
 439 #    }
 440 #  }
 441
 442   # Make main object -- base case
 443   #warn "\n*** validated data is " . Dumper($validated). "***\n";
 444   my $me_obj  = eval { $self->create($validated) };
 445   if ($@) {
 446         warn "Just failed making a " . $self. " FATAL Error is $@"
 447                 if (eval{$self->model_debug});
 448     $errors->{FATAL} = $@;
 449     return (undef, $errors);
 450   }
 451
 452   if (eval{$self->model_debug}) {
 453     if ($me_obj) {
 454       warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
 455     } else {
 456       warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
 457     }
 458   }
 459
 460   # Make other related (must_have, might_have, has_many  etc )
 461   foreach $accssr ( keys %related ) {
 462     my ($rel_obj, $errs) =
 463       $me_obj->_create_related($accssr, $related{$accssr});
 464     $errors->{$accssr} = $errs if $errs;
 465
 466   }
 467   #warn "Errors are " . Dumper($errors);
 468
 469   undef $errors unless keys %$errors;
 470   return ($me_obj, $errors);
 471 }
 472
 473
 474 ##################
 475 # _do_update_all #
 476 ##################
 477
 478 #  Updates objects from hashed untainted data
 479 # Returns 1
 480
 481 sub _do_update_all {
 482         my ($self, $validated) = @_;
 483         my ($errors, $accssr);
 484
 485         #  Separate out related objects' data from main hash
 486         my %related;
 487         foreach (keys %$validated) {
 488                 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
 489         }
 490         # Update main obj
 491         # set does not work with IsA right now so we set each col individually
 492         #$self->set(%$validated);
 493         my $old = $self->autoupdate(0);
 494         for (keys %$validated) {
 495                 $self->$_($validated->{$_});
 496         }
 497         $self->update;
 498         $self->autoupdate($old);
 499
 500         # Update related
 501         foreach $accssr (keys %related) {
 502                 my $fobj = $self->$accssr;
 503                 my $validated = $related{$accssr};
 504                 if ($fobj) {
 505                         my $old = $fobj->autoupdate(0);
 506                         for (keys %$validated) {
 507                                 $fobj->$_($validated->{$_});
 508                         }
 509                         $fobj->update;
 510                         $fobj->autoupdate($old);
 511                 }
 512                 else {
 513                         $fobj = $self->_create_related($accssr, $related{$accssr});
 514                 }
 515         }
 516         return 1;
 517 }
 518
 519
 520 ###################
 521 # _create_related #
 522 ###################
 523
 524 # Creates and automatically relates newly created object to calling object
 525 # Returns related object and errors ($obj, $errors).
 526 # If no errors, then undef in that slot.
 527
 528 sub _create_related {
 529         # self is object or class, accssr is accssr to relationship, params are
 530         # data for relobject, and created is the array ref to store objs we
 531         # create (optional).
 532         my ( $self, $accssr, $params, $created )  = @_;
 533         $self->_croak ("Can't make related object without a parent $self object")
 534                 unless ref $self;
 535         $created      ||= [];
 536         my  $rel_meta = $self->related_meta('r',$accssr);
 537     if (!$rel_meta) {
 538                 $self->_croak("No relationship for $accssr in " . ref($self));
 539         }
 540         my $rel_type  = $rel_meta->{name};
 541         my $fclass    = $rel_meta->{foreign_class};
 542         #warn " Dumper of meta is " . Dumper($rel_meta);
 543
 544
 545         my ($rel, $errs);
 546
 547         # Set up params for might_have, has_many, etc
 548         if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
 549
 550                 # Foreign Key meta data not very standardized in CDBI
 551                 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
 552                 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
 553                 my %data = (%$params, $fkey => $self->id);
 554                 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
 555                 #warn "Data is " . Dumper(\%data);
 556             ($rel, $errs) =  $fclass->_do_create_all(\%data, $created);
 557         }
 558         else {
 559             ($rel, $errs) =  $fclass->_do_create_all($params, $created);
 560                 unless ($errs) {
 561                         $self->$accssr($rel->id);
 562                         $self->update;
 563                 }
 564         }
 565         return ($rel, $errs);
 566 }
 567
 568
 569
 570
 571 =head2  classify_form_inputs
 572
 573 $self->classify_form_inputs($params[, $delimiter]);
 574
 575 Foreign inputs are inputs that have data for a related table.
 576 They come named so we can tell which related class they belong to.
 577 This assumes the form : $accessor . $delimeter . $column recursively
 578 classifies them into hashes. It returns a hashref.
 579
 580 =cut
 581
 582 sub classify_form_inputs {
 583         my ($self, $params, $delimiter) = @_;
 584         my %hashed = ();
 585         my $bottom_level;
 586         $delimiter ||= $self->foreign_input_delimiter;
 587         foreach my $input_name (keys %$params) {
 588                 my @accssrs  = split /$delimiter/, $input_name;
 589                 my $col_name = pop @accssrs;
 590                 $bottom_level = \%hashed;
 591                 while ( my $a  = shift @accssrs ) {
 592                         $bottom_level->{$a} ||= {};
 593                         $bottom_level = $bottom_level->{$a};  # point to bottom level
 594                 }
 595                 # now insert parameter at bottom level keyed on col name
 596                 $bottom_level->{$col_name} = $params->{$input_name};
 597         }
 598         return  \%hashed;
 599 }
 600
 601 sub _untaint_handlers {
 602     my ($me, $them) = @_;
 603     return () unless $them->can('__untaint_types');
 604     my %type = %{ $them->__untaint_types || {} };
 605     my %h;
 606     @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
 607     return %h;
 608 }
 609
 610 sub _column_type_for {
 611     my $type = lc shift;
 612     $type =~ s/\(.*//;
 613     my %map = (
 614         varchar   => 'printable',
 615         char      => 'printable',
 616         text      => 'printable',
 617         tinyint   => 'integer',
 618         smallint  => 'integer',
 619         mediumint => 'integer',
 620         int       => 'integer',
 621         integer   => 'integer',
 622         bigint    => 'integer',
 623         year      => 'integer',
 624         date      => 'date',
 625     );
 626     return $map{$type} || "";
 627 }
 628
 629 =head1 MAINTAINER
 630
 631 Maypole Developers
 632
 633 =head1 AUTHORS
 634
 635 Peter Speltz, Aaron Trevena
 636
 637 =head1 AUTHORS EMERITUS
 638
 639 Tony Bowden
 640
 641 =head1 TODO
 642
 643 * Tests
 644 * add_to_from_cgi, search_from_cgi
 645 * complete documentation
 646 * ensure full backward compatibility with Class::DBI::FromCGI
 647
 648 =head1 BUGS and QUERIES
 649
 650 Please direct all correspondence regarding this module to:
 651  Maypole list.
 652
 653 =head1 COPYRIGHT AND LICENSE
 654
 655 Copyright 2003-2004 by Peter Speltz
 656
 657 This library is free software; you can redistribute it and/or modify
 658 it under the same terms as Perl itself.
 659
 660 =head1 SEE ALSO
 661
 662 L<Class::DBI>, L<Class::DBI::FromCGI>
 663
 664 =cut
 665
 666 1;
 667
 668