lib/Maypole/Model/CDBI/FromCGI.pm

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