lib/Maypole/Model/CDBI/FromCGI.pm

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