1 package Maypole::Model::CDBI::FromCGI;
6 Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects
10 $obj = $class->create_from_cgi($r);
11 $obj = $class->create_from_cgi($r, { params => {data1=>...}, required => [..],
12 ignore => [...], all => [...]);
13 $obj = $class->create_from_cgi($h, $options); # CDBI::FromCGI style, see docs
15 $obj->update_from_cgi($r);
16 $obj->update_from_cgi($h, $options);
18 $obj = $obj->add_to_from_cgi($r);
19 $obj = $obj->add_to_from_cgi($r, { params => {...} } );
21 # This does not work like in CDBI::FromCGI and probably never will :
22 # $class->update_from_cgi($h, @columns);
27 Provides a way to validate form input and populate Model Objects, based
28 on Class::DBI::FromCGI.
34 # The base base model class for apps
35 # provides good search and create functions
37 use base qw(Exporter);
39 use Maypole::Constants;
40 use CGI::Untaint::Maypole;
41 our $Untainter = 'CGI::Untaint::Maypole';
43 our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns add_to_from_cgi
44 cgi_update_errors untaint_type validate_inputs validate_all _do_update_all
45 _do_create_all _create_related classify_form_inputs/;
49 use Data::Dumper; # for debugging
53 =head2 untaint_columns
55 Replicates Class::DBI::FromCGI method of same name :
57 __PACKAGE__->untaint_columns(
58 printable => [qw/Title Director/],
59 integer => [qw/DomesticGross NumExplodingSheep],
60 date => [qw/OpeningDate/],
66 die "untaint_columns() needs a hash" unless @_ % 2;
67 my ($class, %args) = @_;
68 $class->mk_classdata('__untaint_types')
69 unless $class->can('__untaint_types');
70 my %types = %{ $class->__untaint_types || {} };
71 while (my ($type, $ref) = each(%args)) {
74 $class->__untaint_types(\%types);
79 gets the untaint type for a column as set in "untaint_types"
83 # get/set untaint_type for a column
85 my ($class, $field, $new_type) = @_;
86 my %handler = __PACKAGE__->_untaint_handlers($class);
87 return $handler{$field} if $handler{$field};
89 local $SIG{__WARN__} = sub { };
90 my $type = $class->column_type($field) or die;
91 _column_type_for($type);
93 return $handler || undef;
96 =head2 cgi_update_errors
98 Returns errors that ocurred during an operation.
102 sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
106 =head2 create_from_cgi
108 Based on the same method in Class::DBI::FromCGI.
110 Creates multiple objects from a cgi form.
111 Errors are returned in cgi_update_errors
113 It can be called Maypole style passing the Maypole request object as the
114 first arg, or Class::DBI::FromCGI style passing the Untaint Handler ($h)
117 A hashref of options can be passed as the second argument. Unlike
118 in the CDBI equivalent, you can *not* pass a list as the second argument.
120 params -- hashref of cgi data to use instead of $r->params,
121 required -- list of fields that are required
122 ignore -- list of fields to ignore
123 all -- list of all fields (defaults to $class->columns)
127 sub create_from_cgi {
128 my ($self, $r, $opts) = @_;
129 $self->_croak( "create_from_cgi can only be called as a class method")
131 my ($errors, $validated);
134 if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility
135 ($validated, $errors) = $self->validate_inputs($r,$opts);
137 my $params = $opts->{params} || $r->params;
138 $opts->{params} = $self->classify_form_inputs($params);
139 ($validated, $errors) = $self->validate_all($r, $opts);
143 return bless { _cgi_update_error => $errors }, $self;
146 # Insert all the data
147 my ($obj, $err ) = $self->_do_create_all($validated);
149 return bless { _cgi_update_error => $err }, $self;
155 =head2 update_from_cgi
157 Replicates the Class::DBI::FromCGI method of same name. It updates an object and
158 returns 1 upon success. It can take the same arguments as create_form_cgi.
159 If errors, it sets the cgi_update_errors.
163 sub update_from_cgi {
164 my ($self, $r, $opts) = @_;
165 $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
166 my ($errors, $validated);
167 $self->{_cgi_update_error} = {};
168 $opts->{updating} = 1;
170 # FromCGI interface compatibility
171 if ($r->isa('CGI::Untaint')) {
172 # REHASH the $opts for updating:
173 # 1: we ignore any fields we dont have parmeter for. (safe ?)
174 # 2: we dont want to update fields unless they change
176 my @ignore = @{$opts->{ignore} || []};
177 push @ignore, $self->primary_column->name;
178 my $raw = $r->raw_data;
179 #print "*** raw data ****" . Dumper($raw);
180 foreach my $field ($self->columns) {
181 #print "*** field is $field ***\n";
182 if (not defined $raw->{$field}) {
183 push @ignore, $field->name;
184 #print "*** ignoring $field because it is not present ***\n";
187 # stupid inflation , cant get at raw db value easy, must call
188 # deflate ***FIXME****
189 my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
190 if ($raw->{$field} eq $cur_val) {
191 #print "*** ignoring $field because unchanged ***\n";
192 push @ignore, "$field";
195 $opts->{ignore} = \@ignore;
196 ($validated, $errors) = $self->validate_inputs($r,$opts);
198 my $params = $opts->{params} || $r->params;
199 $opts->{params} = $self->classify_form_inputs($params);
200 ($validated, $errors) = $self->validate_all($r, $opts);
201 #print "*** errors for validate all ****" . Dumper($errors);
205 #print "*** we have errors ****" . Dumper($errors);
206 $self->{_cgi_update_error} = $errors;
210 # Update all the data
211 my ($obj, $err ) = $self->_do_update_all($validated);
213 $self->{_cgi_update_error} = $err;
219 =head2 add_to_from_cgi
221 $obj->add_to_from_cgi($r[, $opts]);
223 Like add_to_* for has_many relationships but will add nay objects it can
224 figure out from the data. It returns a list of objects it creates or nothing
225 on error. Call cgi_update_errors with the calling object to get errors.
226 Fatal errors are in the respective "FATAL" key.
230 sub add_to_from_cgi {
231 my ($self, $r, $opts) = @_;
232 $self->_croak( "add_to_from_cgi can only be called as an object method")
234 my ($errors, $validated, @created);
237 my $params = $opts->{params} || $r->params;
238 $opts->{params} = $self->classify_form_inputs($params);
239 ($validated, $errors) = $self->validate_all($r, $opts);
243 $self->{_cgi_update_error} = $errors;
247 # Insert all the data
248 foreach my $hm (keys %$validated) {
249 my ($obj, $errs) = $self->_create_related($hm, $validated->{$hm});
253 $errors->{$hm} = $errs;
258 $self->{_cgi_update_error} = $errors;
270 Validates (untaints) a hash of possibly mixed table data.
271 Returns validated and errors ($validated, $errors).
272 If no errors then undef in that spot.
277 my ($self, $r, $opts) = @_;
278 my $class = ref $self || $self;
279 my $classified = $opts->{params};
280 my $updating = $opts->{updating};
282 # Base case - validate this classes data
283 $opts->{all} ||= eval{ $r->config->{$self->table}{all_cols} } ||
284 [$self->columns('All')];
285 $opts->{required} ||= eval{ $r->config->{$self->table}{required_cols} } ||
287 my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} }
289 push @$ignore, $self->primary_column->name if $updating;
291 # Ignore hashes of foreign inputs. This takes care of required has_a's
292 # for main object that we have foreign inputs for.
293 foreach (keys %$classified) {
294 push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
296 $opts->{ignore} = $ignore;
297 my $h = $Untainter->new($classified);
298 my ($validated, $errs) = $self->validate_inputs($h, $opts);
300 # Validate all foreign input
302 #warn "Classified data is " . Dumper($classified);
303 foreach my $field (keys %$classified) {
304 if (ref $classified->{$field} eq "HASH") {
305 my $data = $classified->{$field};
307 my @usr_entered_vals = ();
308 foreach ( values %$data ) {
309 push @usr_entered_vals, $_ if $_ ne '';
313 # IF we have some inputs for the related
314 if ( @usr_entered_vals ) {
315 # We need to ignore us if we are a required has_a in this foreign class
316 my $rel_meta = $self->related_meta($r, $field);
317 my $fclass = $rel_meta->{foreign_class};
318 my $fmeta = $fclass->meta_info('has_a');
320 if ($fmeta->{$_}{foreign_class} eq $class) {
324 my ($valid, $ferrs) = $fclass->validate_all($r,
325 {params => $data, updating => $updating, ignore => $ignore } );
327 $errs->{$field} = $ferrs if $ferrs;
328 $validated->{$field} = $valid;
331 # Check this foreign object is not requeired
332 my %req = map { $_ => 1 } $opts->{required};
334 $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
339 #warn "Validated inputs are " . Dumper($validated);
340 undef $errs unless keys %$errs;
341 return ($validated, $errs);
345 # validate_inputs undocumented. It is not yet part of the public interface.
346 #=head2 validate_inputs
348 #$self->validate_inputs($h, $opts);
350 #This is the main validation method to validate inputs for a single class.
351 #Most of the time you use validate_all.
353 # Returns validated and errors.
354 # If no errors then undef in that slot.
358 sub validate_inputs {
359 my ($self, $h, $opts) = @_;
360 my $updating = $opts->{updating};
361 my %required = map { $_ => 1 } @{$opts->{required}};
363 $seen{$_}++ foreach @{$opts->{ignore}};
366 $opts->{all} = [ $self->columns ] unless @{$opts->{all} || [] } ;
367 foreach my $field (@{$opts->{required}}, @{$opts->{all}}) {
368 next if $seen{$field}++;
369 my $type = $self->untaint_type($field) or
370 do { warn "No untaint type for $self 's field $field. Ignoring.";
373 my $value = $h->extract("-as_$type" => $field);
376 # Required field error
377 if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
378 #($value eq '' or !defined $value))
379 $errors->{$field} = "You must supply '$field'"
380 #unless ($updating and$self->field;
383 # 1: No inupt entered
384 if ($err =~ /^No input for/) {
385 # A : Updating -- set the field to undef or ''
387 $fields->{$field} = eval{$self->column_nullable($field)} ?
390 # B : Creating -- dont set a value and RDMS will put default
393 # 2: A real untaint error -- just set the error
394 elsif ($err !~ /^No parameter for/) {
395 $errors->{$field} = $err;
398 $fields->{$field} = $value
401 undef $errors unless keys %$errors;
402 return ($fields, $errors);
410 # Untaints and Creates objects from hashed params.
411 # Returns parent object and errors ($obj, $errors).
412 # If no errors, then undef in that slot.
414 my ($self, $validated) = @_;
415 my $class = ref $self || $self;
416 my ($errors, $accssr);
418 # Separate out related objects' data from main hash
420 foreach (keys %$validated) {
421 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
423 # Make has_own/a rel type objects and put id in parent's data hash
424 # foreach $accssr (keys %related) {
425 # my $rel_meta = $self->related_meta('r', $accssr);
426 # $self->_croak("No relationship found for $accssr to $class.")
428 # my $rel_type = $rel_meta->{name};
429 # if ($rel_type =~ /(^has_own$|^has_a$)/) {
430 # my $fclass= $rel_meta->{foreign_class};
431 # my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr});
432 # # put id in parent's data hash
433 # if (not keys %$errs) {
434 # $validated->{$accssr} = $rel_obj->id;
436 # $errors->{$accssr} = $errs;
438 # delete $related{$accssr}; # done with this
442 # Make main object -- base case
443 #warn "\n*** validated data is " . Dumper($validated). "***\n";
444 my $me_obj = eval { $self->create($validated) };
446 warn "Just failed making a " . $self. " FATAL Error is $@"
447 if (eval{$self->model_debug});
448 $errors->{FATAL} = $@;
449 return (undef, $errors);
452 if (eval{$self->model_debug}) {
454 warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
456 warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
460 # Make other related (must_have, might_have, has_many etc )
461 foreach $accssr ( keys %related ) {
462 my ($rel_obj, $errs) =
463 $me_obj->_create_related($accssr, $related{$accssr});
464 $errors->{$accssr} = $errs if $errs;
467 #warn "Errors are " . Dumper($errors);
469 undef $errors unless keys %$errors;
470 return ($me_obj, $errors);
478 # Updates objects from hashed untainted data
482 my ($self, $validated) = @_;
483 my ($errors, $accssr);
485 # Separate out related objects' data from main hash
487 foreach (keys %$validated) {
488 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
491 # set does not work with IsA right now so we set each col individually
492 #$self->set(%$validated);
493 my $old = $self->autoupdate(0);
494 for (keys %$validated) {
495 $self->$_($validated->{$_});
498 $self->autoupdate($old);
501 foreach $accssr (keys %related) {
502 my $fobj = $self->$accssr;
503 my $validated = $related{$accssr};
505 my $old = $fobj->autoupdate(0);
506 for (keys %$validated) {
507 $fobj->$_($validated->{$_});
510 $fobj->autoupdate($old);
513 $fobj = $self->_create_related($accssr, $related{$accssr});
524 # Creates and automatically relates newly created object to calling object
525 # Returns related object and errors ($obj, $errors).
526 # If no errors, then undef in that slot.
528 sub _create_related {
529 # self is object or class, accssr is accssr to relationship, params are
530 # data for relobject, and created is the array ref to store objs we
532 my ( $self, $accssr, $params, $created ) = @_;
533 $self->_croak ("Can't make related object without a parent $self object")
536 my $rel_meta = $self->related_meta('r',$accssr);
538 $self->_croak("No relationship for $accssr in " . ref($self));
540 my $rel_type = $rel_meta->{name};
541 my $fclass = $rel_meta->{foreign_class};
542 #warn " Dumper of meta is " . Dumper($rel_meta);
547 # Set up params for might_have, has_many, etc
548 if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
550 # Foreign Key meta data not very standardized in CDBI
551 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
552 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
553 my %data = (%$params, $fkey => $self->id);
554 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
555 #warn "Data is " . Dumper(\%data);
556 ($rel, $errs) = $fclass->_do_create_all(\%data, $created);
559 ($rel, $errs) = $fclass->_do_create_all($params, $created);
561 $self->$accssr($rel->id);
565 return ($rel, $errs);
571 =head2 classify_form_inputs
573 $self->classify_form_inputs($params[, $delimiter]);
575 Foreign inputs are inputs that have data for a related table.
576 They come named so we can tell which related class they belong to.
577 This assumes the form : $accessor . $delimeter . $column recursively
578 classifies them into hashes. It returns a hashref.
582 sub classify_form_inputs {
583 my ($self, $params, $delimiter) = @_;
586 $delimiter ||= $self->foreign_input_delimiter;
587 foreach my $input_name (keys %$params) {
588 my @accssrs = split /$delimiter/, $input_name;
589 my $col_name = pop @accssrs;
590 $bottom_level = \%hashed;
591 while ( my $a = shift @accssrs ) {
592 $bottom_level->{$a} ||= {};
593 $bottom_level = $bottom_level->{$a}; # point to bottom level
595 # now insert parameter at bottom level keyed on col name
596 $bottom_level->{$col_name} = $params->{$input_name};
601 sub _untaint_handlers {
602 my ($me, $them) = @_;
603 return () unless $them->can('__untaint_types');
604 my %type = %{ $them->__untaint_types || {} };
606 @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
610 sub _column_type_for {
614 varchar => 'printable',
617 tinyint => 'integer',
618 smallint => 'integer',
619 mediumint => 'integer',
621 integer => 'integer',
626 return $map{$type} || "";
635 Peter Speltz, Aaron Trevena
637 =head1 AUTHORS EMERITUS
644 * add_to_from_cgi, search_from_cgi
645 * complete documentation
646 * ensure full backward compatibility with Class::DBI::FromCGI
648 =head1 BUGS and QUERIES
650 Please direct all correspondence regarding this module to:
653 =head1 COPYRIGHT AND LICENSE
655 Copyright 2003-2004 by Peter Speltz
657 This library is free software; you can redistribute it and/or modify
658 it under the same terms as Perl itself.
662 L<Class::DBI>, L<Class::DBI::FromCGI>