lib/Maypole/Model/CDBI/FromCGI.pm

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