X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI%2FFromCGI.pm;h=217570acfc2d51b18bd53cc682070cd3ebddd839;hb=1ec67be9e8b738cbd2a523523af3bd7e61f98480;hp=e342a28f45ab9d418507a4ece50f52206d59c96b;hpb=b9aff7e76eab19b36abd670e6fc75a8a3d821324;p=maypole.git diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm index e342a28..217570a 100644 --- a/lib/Maypole/Model/CDBI/FromCGI.pm +++ b/lib/Maypole/Model/CDBI/FromCGI.pm @@ -1,12 +1,27 @@ package Maypole::Model::CDBI::FromCGI; use strict; +use warnings; + =head1 NAME Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects =head1 SYNOPSIS -... + $obj = $class->create_from_cgi($r); + $obj = $class->create_from_cgi($r, { params => {data1=>...}, required => [..], + ignore => [...], all => [...]); + $obj = $class->create_from_cgi($h, $options); # CDBI::FromCGI style, see docs + + $obj->update_from_cgi($r); + $obj->update_from_cgi($h, $options); + + $obj = $obj->add_to_from_cgi($r); + $obj = $obj->add_to_from_cgi($r, { params => {...} } ); + + # This does not work like in CDBI::FromCGI and probably never will : + # $class->update_from_cgi($h, @columns); + =head1 DESCRIPTION @@ -15,7 +30,6 @@ on Class::DBI::FromCGI. =cut -use warnings; # The base base model class for apps # provides good search and create functions @@ -26,9 +40,9 @@ use Maypole::Constants; use CGI::Untaint::Maypole; our $Untainter = 'CGI::Untaint::Maypole'; -our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns - cgi_update_errors untaint_type _validate validate_all _do_update_all - _do_create_all classify_form_inputs/; +our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns add_to_from_cgi + cgi_update_errors untaint_type validate_inputs validate_all _do_update_all + _do_create_all _create_related classify_form_inputs/; @@ -62,7 +76,7 @@ sub untaint_columns { =head2 untaint_type - gets/sets untaint_type for a column, no equivilent in Class::DBI::FromCGI + gets the untaint type for a column as set in "untaint_types" =cut @@ -81,14 +95,12 @@ sub untaint_type { =head2 cgi_update_errors -returns cgi update errors +Returns errors that ocurred during an operation. =cut sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } } - - =head2 create_from_cgi Based on the same method in Class::DBI::FromCGI. @@ -96,27 +108,33 @@ Based on the same method in Class::DBI::FromCGI. Creates multiple objects from a cgi form. Errors are returned in cgi_update_errors -simple usage: $beer->create_from_cgi($r); +It can be called Maypole style passing the Maypole request object as the +first arg, or Class::DBI::FromCGI style passing the Untaint Handler ($h) +as the first arg. -The last arg is flag to say whether to classify inputs or not. -TODO : make 100% backward compatible +A hashref of options can be passed as the second argument. Unlike +in the CDBI equivalent, you can *not* pass a list as the second argument. +Options can be : + params -- hashref of cgi data to use instead of $r->params, + required -- list of fields that are required + ignore -- list of fields to ignore + all -- list of all fields (defaults to $class->columns) =cut sub create_from_cgi { - my ($self, $r, $params, $no_classify) = @_; + my ($self, $r, $opts) = @_; $self->_croak( "create_from_cgi can only be called as a class method") if ref $self; - my ($errors, $validated); - # FromCGI interface compatibility - # params are ($h, $wanted) - if ($r->isa('CGI::Untaint')) { - ($errors, $validated) = $self->_validate($r,$params); + + + if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility + ($validated, $errors) = $self->validate_inputs($r,$opts); } else { - $params ||= $r->params; - my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params); - ($errors, $validated) = $self->validate_all($r, $classified); + my $params = $opts->{params} || $r->params; + $opts->{params} = $self->classify_form_inputs($params); + ($validated, $errors) = $self->validate_all($r, $opts); } if (keys %$errors) { @@ -126,7 +144,7 @@ sub create_from_cgi { # Insert all the data my ($obj, $err ) = $self->_do_create_all($validated); if ($err) { - return bless { _cgi_update_error => $err }, $obj ; + return bless { _cgi_update_error => $err }, $self; } return $obj; } @@ -134,52 +152,50 @@ sub create_from_cgi { =head2 update_from_cgi -returns 1 or nothing if errors +Replicates the Class::DBI::FromCGI method of same name. It updates an object and +returns 1 upon success. It can take the same arguments as create_form_cgi. +If errors, it sets the cgi_update_errors. =cut sub update_from_cgi { - my ($self, $r, $params, $no_classify) = @_; + my ($self, $r, $opts) = @_; $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self; - my ($errors, $validated, $wanted); + my ($errors, $validated); $self->{_cgi_update_error} = {}; + $opts->{updating} = 1; - # FromCGI interface compatibility params are ($h, $wanted) + # FromCGI interface compatibility if ($r->isa('CGI::Untaint')) { - # REHASH the $wanted for updating: + # REHASH the $opts for updating: # 1: we ignore any fields we dont have parmeter for. (safe ?) # 2: we dont want to update fields unless they change - my ($h, $wanted) = ($r, $params); - my @ignore = @{$wanted->{ignore} || []}; + my @ignore = @{$opts->{ignore} || []}; push @ignore, $self->primary_column->name; - my $raw = $h->raw_data; + my $raw = $r->raw_data; #print "*** raw data ****" . Dumper($raw); foreach my $field ($self->columns) { #print "*** field is $field ***\n"; - if (not defined $raw->{$field}) { - push @ignore, $field->name; - #print "*** ignoring $field because it is not present ***\n"; - next; - } - # stupid inflation , cant get at raw db value easy, must call - # deflate ***FIXME**** - my $cur_val = ref $self->$field ? $self->$field->id : $self->$field; - if ($raw->{$field} eq $cur_val) { - #print "*** ignoring $field because unchanged ***\n"; - push @ignore, $field->name; - } + if (not defined $raw->{$field}) { + push @ignore, $field->name; + #print "*** ignoring $field because it is not present ***\n"; + next; + } + # stupid inflation , cant get at raw db value easy, must call + # deflate ***FIXME**** + my $cur_val = ref $self->$field ? $self->$field->id : $self->$field; + if ($raw->{$field} eq $cur_val) { + #print "*** ignoring $field because unchanged ***\n"; + push @ignore, "$field"; + } } - - $wanted->{ignore} = \@ignore; - #print "*** wanted ****" . Dumper($wanted); - ($errors, $validated) = $self->_validate($h,$wanted,1); - #print "*** validated data ****" . Dumper($validated); - #print "*** errors ****" . Dumper($errors); + $opts->{ignore} = \@ignore; + ($validated, $errors) = $self->validate_inputs($r,$opts); } else { - $params ||= $r->params; - my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params); - ($errors, $validated) = $self->validate_all($r, $classified,1); + my $params = $opts->{params} || $r->params; + $opts->{params} = $self->classify_form_inputs($params); + ($validated, $errors) = $self->validate_all($r, $opts); #print "*** errors for validate all ****" . Dumper($errors); } @@ -198,76 +214,155 @@ sub update_from_cgi { return 1; } +=head2 add_to_from_cgi + +$obj->add_to_from_cgi($r[, $opts]); + +Like add_to_* for has_many relationships but will add nay objects it can +figure out from the data. It returns a list of objects it creates or nothing +on error. Call cgi_update_errors with the calling object to get errors. +Fatal errors are in the respective "FATAL" key. + +=cut + +sub add_to_from_cgi { + my ($self, $r, $opts) = @_; + $self->_croak( "add_to_from_cgi can only be called as an object method") + unless ref $self; + my ($errors, $validated, @created); + + my $params = $opts->{params} || $r->params; + $opts->{params} = $self->classify_form_inputs($params); + ($validated, $errors) = $self->validate_all($r, $opts); + + + if (keys %$errors) { + $self->{_cgi_update_error} = $errors; + return; + } + + # Insert all the data + foreach my $hm (keys %$validated) { + my ($obj, $errs) = $self->_create_related($hm, $validated->{$hm}); + if (not $errs) { + push @created, $obj; + }else { + $errors->{$hm} = $errs; + } + } + + if (keys %$errors) { + $self->{_cgi_update_error} = $errors; + return; + } + + return @created; +} + + + + =head2 validate_all -Validates (untaints) a hash of possibly mixed table params. It returns hashrefs -of errors and validated data. +Validates (untaints) a hash of possibly mixed table data. +Returns validated and errors ($validated, $errors). +If no errors then undef in that spot. =cut sub validate_all { - my ($self, $r, $classified, $updating) = @_; + my ($self, $r, $opts) = @_; + my $class = ref $self || $self; + my $classified = $opts->{params}; + my $updating = $opts->{updating}; # Base case - validate this classes data - my $all = eval{ $r->config->{$self->table}{all_cols} } || - [$self->columns('All')]; - my $req = eval{ $r->config->{$self->table}{required_cols} } || - []; - my $ignore = eval{ $r->config->{$self->table}{ignore_cols} } || - []; + $opts->{all} ||= eval{ $r->config->{$self->table}{all_cols} } || [$self->columns('All')]; + $opts->{required} ||= eval { $r->config->{$self->table}{required_cols} || $self->required_columns } || []; + my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} } || []; push @$ignore, $self->primary_column->name if $updating; - # ignore hashes of foreign inputs + + # Ignore hashes of foreign inputs. This takes care of required has_a's + # for main object that we have foreign inputs for. foreach (keys %$classified) { push @$ignore, $_ if ref $classified->{$_} eq 'HASH'; } + $opts->{ignore} = $ignore; my $h = $Untainter->new($classified); - my ($errs, $validated) = $self->_validate( - $h, {all => $all, required => $req, ignore => $ignore},$updating - ); + my ($validated, $errs) = $self->validate_inputs($h, $opts); - #warn "Validated dump is " . Dumper($validated); - #warn "classified dump is " . Dumper($classified); # Validate all foreign input + + #warn "Classified data is " . Dumper($classified); foreach my $field (keys %$classified) { if (ref $classified->{$field} eq "HASH") { my $data = $classified->{$field}; - # warn "Dump of fdata for $field: " . Dumper($data) if $r->debug; + my $ignore = []; my @usr_entered_vals = (); - my %required = map { $_ => 1 } - @{$r->config->{$self->table}{required_cols}}; foreach ( values %$data ) { - push @usr_entered_vals, $_ if $_ ne ''; + push @usr_entered_vals, $_ if $_ ne ''; } # filled in values # IF we have some inputs for the related if ( @usr_entered_vals ) { - # warn "user entered vals . " . Dumper(\@usr_entered_vals) if $r->debug; - my ($ferrs, $valid) = $self->related_class($r, $field)->validate_all($r, $classified->{$field}, $updating ); - $errs->{$field} = $ferrs if $ferrs; - $validated->{$field} = $valid; + # We need to ignore us if we are a required has_a in this foreign class + my $rel_meta = $self->related_meta($r, $field); + my $fclass = $rel_meta->{foreign_class}; + my $fmeta = $fclass->meta_info('has_a'); + for (keys %$fmeta) { + if ($fmeta->{$_}{foreign_class} eq $class) { + push @$ignore, $_; + } + } + my ($valid, $ferrs) = $fclass->validate_all($r, + {params => $data, updating => $updating, ignore => $ignore } ); + + $errs->{$field} = $ferrs if $ferrs; + $validated->{$field} = $valid; + } else { - # Check its not requeired - if ($required{$field}) { - $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section." - } - } - } + # Check this foreign object is not requeired + my %req = map { $_ => 1 } $opts->{required}; + if ($req{$field}) { + $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section." + } + } + } } + #warn "Validated inputs are " . Dumper($validated); undef $errs unless keys %$errs; - return ($errs, $validated); + return ($validated, $errs); } -sub _validate { - my ($self, $h, $wanted, $updating) = @_; - my %required = map { $_ => 1 } @{$wanted->{required}}; + +=head2 validate_inputs + +$self->validate_inputs($h, $opts); + +This is the main validation method to validate inputs for a single class. +Most of the time you use validate_all. + +Returns validated and errors. + +If no errors then undef in that slot. + +Note: This method is currently experimental (in 2.11) and may be subject to change +without notice. + +=cut + +sub validate_inputs { + my ($self, $h, $opts) = @_; + my $updating = $opts->{updating}; + my %required = map { $_ => 1 } @{$opts->{required}}; my %seen; - $seen{$_}++ foreach @{$wanted->{ignore}}; + $seen{$_}++ foreach @{$opts->{ignore}}; my $errors = {}; my $fields = {}; - $wanted->{all} = [ $self->columns ] unless @{$wanted->{all} || [] } ; - foreach my $field (@{$wanted->{required}}, @{$wanted->{all}}) { + $opts->{all} = [ $self->columns ] unless @{$opts->{all} || [] } ; + foreach my $field (@{$opts->{required}}, @{$opts->{all}}) { next if $seen{$field}++; my $type = $self->untaint_type($field) or do { warn "No untaint type for $self 's field $field. Ignoring."; @@ -278,9 +373,7 @@ sub _validate { # Required field error if ($required{$field} and !ref($value) and $err =~ /^No input for/) { - #($value eq '' or !defined $value)) $errors->{$field} = "You must supply '$field'" - #unless ($updating and$self->field; } elsif ($err) { # 1: No inupt entered @@ -302,7 +395,7 @@ sub _validate { } } undef $errors unless keys %$errors; - return ($errors, $fields); + return ($fields, $errors); } @@ -311,7 +404,8 @@ sub _validate { ################## # Untaints and Creates objects from hashed params. -# Returns parent object and errors. +# Returns parent object and errors ($obj, $errors). +# If no errors, then undef in that slot. sub _do_create_all { my ($self, $validated) = @_; my $class = ref $self || $self; @@ -322,33 +416,17 @@ sub _do_create_all { foreach (keys %$validated) { $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH'; } - # Make has_own/a rel type objects and put id in parent's data hash - foreach $accssr (keys %related) { - my $rel_meta = $self->related_meta('r', $accssr); - $self->_croak("No relationship found for $accssr to $class.") - unless $rel_meta; - my $rel_type = $rel_meta->{name}; - if ($rel_type =~ /(^has_own$|^has_a$)/) { - my $fclass= $rel_meta->{foreign_class}; - my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr}); - # put id in parent's data hash - if (not keys %$errs) { - $validated->{$accssr} = $rel_obj->id; - } else { - $errors->{$accssr} = $errs; - } - delete $related{$accssr}; # done with this - } - } # Make main object -- base case - my $me_obj = eval { $self->insert($validated) }; + #warn "\n*** validated data is " . Dumper($validated). "***\n"; + my $me_obj = eval { $self->create($validated) }; if ($@) { - warn "Just failed making a " . $self. " FATAL Error is $@"; + warn "Just failed making a " . $self. " FATAL Error is $@" + if (eval{$self->model_debug}); $errors->{FATAL} = $@; return (undef, $errors); } - + if (eval{$self->model_debug}) { if ($me_obj) { warn "Just made a $self : $me_obj ( " . $me_obj->id . ")"; @@ -357,12 +435,14 @@ sub _do_create_all { } } - # Make other related (must_have, might_have, has_many , etc ) + # Make other related (must_have, might_have, has_many etc ) foreach $accssr ( keys %related ) { my ($rel_obj, $errs) = $me_obj->_create_related($accssr, $related{$accssr}); $errors->{$accssr} = $errs if $errs; + } + #warn "Errors are " . Dumper($errors); undef $errors unless keys %$errors; return ($me_obj, $errors); @@ -420,78 +500,61 @@ sub _do_update_all { ################### # Creates and automatically relates newly created object to calling object -# It returns related object and possibly errors +# Returns related object and errors ($obj, $errors). +# If no errors, then undef in that slot. sub _create_related { - # self is object or class, accssr is accssr to relationship, params are - # data for relobject, and created is the array ref to store objs we - # create (optional). - my ( $self, $accssr, $params, $created ) = @_; - $self->_croak ("Can't make related object without a parent $self object") - unless ref $self; - $created ||= []; - my $rel_meta = $self->related_meta('r',$accssr); + # self is object or class, accssr is accssr to relationship, params are + # data for relobject, and created is the array ref to store objs we + # create (optional). + my ( $self, $accssr, $params, $created ) = @_; + $self->_croak ("Can't make related object without a parent $self object") + unless ref $self; + $created ||= []; + my $rel_meta = $self->related_meta('r',$accssr); if (!$rel_meta) { - $self->_croak("No relationship for $accssr in " . ref($self)); - } - my $rel_type = $rel_meta->{name}; - my $fclass = $rel_meta->{foreign_class}; - - my ($rel, $errs); - if ($rel_type ne 'has_own' or $rel_type ne 'has_a') { - # set up params for might_have, has_many, etc - $params->{ $rel_meta->{args}{foreign_column} } = $self->id; - %$params = ( %$params, %{$rel_meta->{args}->{constraint} || {}} ); - ($rel, $errs) = $fclass->_do_create_all($params, $created); - } - else { - ($rel, $errs) = $fclass->_do_create_all($params, $created); - unless ($errs) { - $self->$accssr($rel->id); - $self->update; - } + $self->_carp("[_create_related] No relationship for $accssr in " . ref($self)); + return; + } + my $rel_type = $rel_meta->{name}; + my $fclass = $rel_meta->{foreign_class}; + #warn " Dumper of meta is " . Dumper($rel_meta); + + + my ($rel, $errs); + + # Set up params for might_have, has_many, etc + if ($rel_type ne 'has_own' and $rel_type ne 'has_a') { + + # Foreign Key meta data not very standardized in CDBI + my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column}; + unless ($fkey) { die " Could not determine foreign key for $fclass"; } + my %data = (%$params, $fkey => $self->id); + %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} ); + #warn "Data is " . Dumper(\%data); + ($rel, $errs) = $fclass->_do_create_all(\%data, $created); + } + else { + ($rel, $errs) = $fclass->_do_create_all($params, $created); + unless ($errs) { + $self->$accssr($rel->id); + $self->update; } - return ($rel, $errs); + } + return ($rel, $errs); } +=head2 classify_form_inputs + +$self->classify_form_inputs($params[, $delimiter]); -######################## -# classify_form_inputs # -######################## -################################################################################ -# Foreign inputs are inputs that have data for a related table. -# We must name them so we can tell which related class they belong to. -# This assumes the form : $accessor . $delimeter . $column. -# -# Example Customer must_have person which is a -# CstmrPrsn which has_a Person; -# -# Customer->must_have('cstmrprsn' => 'CstmrPrsn'); -# CstmrPrsn->has_own('prsn_id' => 'Person'); -# -# If you say: Customer->to_field('cstmrprsn'); -# AsForm makes inputs for CstmrPrsn which leads to inputs for Person (first -# _name, last_name, etc); -# We need to keep track that the Person inputs are not related to Customer -# directly but to the CstmrPrsn object which is related to Customer. -# -# Input Names end up like so: -# cstmr_type # Customer column -# cstmrprsn__AF__role # CstmrPrsn column -# cstmrprsn__AF__person__AF__first_name # Person column -# cstmrprsn__AF__person__AF__last_name # Person column -# -# -# So our job is to rehash the inputs into a multi level hash keyed on -# column or virtual column (accessor) names. -# -# -############################################################################### - -=head2 classify_form_inputs +Foreign inputs are inputs that have data for a related table. +They come named so we can tell which related class they belong to. +This assumes the form : $accessor . $delimeter . $column recursively +classifies them into hashes. It returns a hashref. =cut @@ -500,8 +563,6 @@ sub classify_form_inputs { my %hashed = (); my $bottom_level; $delimiter ||= $self->foreign_input_delimiter; - # Put forminputs in own hashes by accessor (class they belong too) - # AsForm makes "$accessor__AF__columnname" form for foeign inputs foreach my $input_name (keys %$params) { my @accssrs = split /$delimiter/, $input_name; my $col_name = pop @accssrs; @@ -536,6 +597,7 @@ sub _column_type_for { smallint => 'integer', mediumint => 'integer', int => 'integer', + integer => 'integer', bigint => 'integer', year => 'integer', date => 'date', @@ -557,6 +619,8 @@ Tony Bowden =head1 TODO +* Tests +* add_to_from_cgi, search_from_cgi * complete documentation * ensure full backward compatibility with Class::DBI::FromCGI @@ -567,7 +631,7 @@ Please direct all correspondence regarding this module to: =head1 COPYRIGHT AND LICENSE -Copyright 2003-2004 by Tony Bowden +Copyright 2003-2004 by Peter Speltz This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.