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