lib/Maypole/Model/CDBI/FromCGI.pm

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