X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI%2FFromCGI.pm;h=217570acfc2d51b18bd53cc682070cd3ebddd839;hb=1ec67be9e8b738cbd2a523523af3bd7e61f98480;hp=0d1f86a5f0d4a87b97358c8975b1e59a9a70de02;hpb=c3973978e1373a262d13da63c9e9ecfde4b72cc7;p=maypole.git diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm index 0d1f86a..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,7 +40,7 @@ use Maypole::Constants; use CGI::Untaint::Maypole; our $Untainter = 'CGI::Untaint::Maypole'; -our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns +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,16 +108,17 @@ 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); -advanced usage: $beer->create_from_cgi($r[,$options ]); -old style: $beer->create_from_cgi($h[,$opts ]); - -A hashref of options can be passed. It can contain: - - params -- hashref of to use instead of $r->params, - required_cols -- list of fields that are required - ignore_cols -- list of fields to ignore +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. +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 @@ -117,11 +130,11 @@ sub create_from_cgi { if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility - ($errors, $validated) = $self->validate_inputs($r,$opts); + ($validated, $errors) = $self->validate_inputs($r,$opts); } else { my $params = $opts->{params} || $r->params; $opts->{params} = $self->classify_form_inputs($params); - ($errors, $validated) = $self->validate_all($r, $opts); + ($validated, $errors) = $self->validate_all($r, $opts); } if (keys %$errors) { @@ -139,10 +152,9 @@ sub create_from_cgi { =head2 update_from_cgi -returns 1 or nothing if errors -TODO -- support $film->update_from_cgi($h => @columns_to_update); -usage?? - +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 @@ -179,11 +191,11 @@ sub update_from_cgi { } } $opts->{ignore} = \@ignore; - ($errors, $validated) = $self->validate_inputs($r,$opts); + ($validated, $errors) = $self->validate_inputs($r,$opts); } else { my $params = $opts->{params} || $r->params; $opts->{params} = $self->classify_form_inputs($params); - ($errors, $validated) = $self->validate_all($r, $opts); + ($validated, $errors) = $self->validate_all($r, $opts); #print "*** errors for validate all ****" . Dumper($errors); } @@ -202,10 +214,59 @@ 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 @@ -216,12 +277,9 @@ sub validate_all { my $updating = $opts->{updating}; # Base case - validate this classes data - $opts->{all} ||= eval{ $r->config->{$self->table}{all_cols} } || - [$self->columns('All')]; - $opts->{required} ||= eval{ $r->config->{$self->table}{required_cols} } || - []; - my $ignore = $opts->{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. This takes care of required has_a's @@ -231,10 +289,11 @@ sub validate_all { } $opts->{ignore} = $ignore; my $h = $Untainter->new($classified); - my ($errs, $validated) = $self->validate_inputs($h, $opts); + my ($validated, $errs) = $self->validate_inputs($h, $opts); # 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}; @@ -256,7 +315,7 @@ sub validate_all { push @$ignore, $_; } } - my ($ferrs, $valid) = $fclass->validate_all($r, + my ($valid, $ferrs) = $fclass->validate_all($r, {params => $data, updating => $updating, ignore => $ignore } ); $errs->{$field} = $ferrs if $ferrs; @@ -273,14 +332,25 @@ sub validate_all { } #warn "Validated inputs are " . Dumper($validated); undef $errs unless keys %$errs; - return ($errs, $validated); + return ($validated, $errs); } -=head2 validate_inputs + +=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 { @@ -303,9 +373,7 @@ sub validate_inputs { # 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 @@ -327,7 +395,7 @@ sub validate_inputs { } } undef $errors unless keys %$errors; - return ($errors, $fields); + return ($fields, $errors); } @@ -336,7 +404,8 @@ sub validate_inputs { ################## # 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; @@ -347,35 +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 #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 $@" - if (eval{$self->model_debug}); + 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 . ")"; @@ -389,9 +440,9 @@ sub _do_create_all { my ($rel_obj, $errs) = $me_obj->_create_related($accssr, $related{$accssr}); $errors->{$accssr} = $errs if $errs; - + } - warn "Errors are " . Dumper($errors); + #warn "Errors are " . Dumper($errors); undef $errors unless keys %$errors; return ($me_obj, $errors); @@ -449,46 +500,48 @@ 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}; - warn " Dumper of meta is " . Dumper($rel_meta); - + $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') { + my ($rel, $errs); - # 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; - } + # 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); } @@ -558,7 +611,7 @@ Maypole Developers =head1 AUTHORS -Peter Speltz +Peter Speltz, Aaron Trevena =head1 AUTHORS EMERITUS @@ -578,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.