1 package Maypole::Model::CDBI::FromCGI;
5 Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects
13 Provides a way to validate form input and populate Model Objects, based
14 on Class::DBI::FromCGI.
20 # The base base model class for apps
21 # provides good search and create functions
23 use base qw(Exporter);
25 use Maypole::Constants;
26 use CGI::Untaint::Maypole;
27 our $Untainter = 'CGI::Untaint::Maypole';
29 our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns
30 cgi_update_errors untaint_type _validate validate_all _do_update_all
31 _do_create_all classify_form_inputs/;
35 use Data::Dumper; # for debugging
39 =head2 untaint_columns
41 Replicates Class::DBI::FromCGI method of same name :
43 __PACKAGE__->untaint_columns(
44 printable => [qw/Title Director/],
45 integer => [qw/DomesticGross NumExplodingSheep],
46 date => [qw/OpeningDate/],
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)) {
60 $class->__untaint_types(\%types);
65 gets/sets untaint_type for a column, no equivilent in Class::DBI::FromCGI
69 # get/set untaint_type for a column
71 my ($class, $field, $new_type) = @_;
72 my %handler = __PACKAGE__->_untaint_handlers($class);
73 return $handler{$field} if $handler{$field};
75 local $SIG{__WARN__} = sub { };
76 my $type = $class->column_type($field) or die;
77 _column_type_for($type);
79 return $handler || undef;
82 =head2 cgi_update_errors
84 returns cgi update errors
88 sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
92 =head2 create_from_cgi
94 Based on the same method in Class::DBI::FromCGI.
96 Creates multiple objects from a cgi form.
97 Errors are returned in cgi_update_errors
99 simple usage: $beer->create_from_cgi($r);
101 The last arg is flag to say whether to classify inputs or not.
102 TODO : make 100% backward compatible
106 sub create_from_cgi {
107 my ($self, $r, $params, $no_classify) = @_;
108 $self->_croak( "create_from_cgi can only be called as a class method")
111 my ($errors, $validated);
112 # FromCGI interface compatibility
113 # params are ($h, $wanted)
114 if ($r->isa('CGI::Untaint')) {
115 ($errors, $validated) = $self->_validate($r,$params);
117 $params ||= $r->params;
118 my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
119 ($errors, $validated) = $self->validate_all($r, $classified);
123 return bless { _cgi_update_error => $errors }, $self;
126 # Insert all the data
127 my ($obj, $err ) = $self->_do_create_all($validated);
129 return bless { _cgi_update_error => $err }, $obj ;
135 =head2 update_from_cgi
137 returns 1 or nothing if errors
141 sub update_from_cgi {
142 my ($self, $r, $params, $no_classify) = @_;
143 $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
144 my ($errors, $validated, $wanted);
145 $self->{_cgi_update_error} = {};
147 # FromCGI interface compatibility params are ($h, $wanted)
148 if ($r->isa('CGI::Untaint')) {
149 # REHASH the $wanted for updating:
150 # 1: we ignore any fields we dont have parmeter for. (safe ?)
151 # 2: we dont want to update fields unless they change
153 my ($h, $wanted) = ($r, $params);
154 my @ignore = @{$wanted->{ignore} || []};
155 push @ignore, $self->primary_column->name;
156 my $raw = $h->raw_data;
157 #print "*** raw data ****" . Dumper($raw);
158 foreach my $field ($self->columns) {
159 #print "*** field is $field ***\n";
160 if (not defined $raw->{$field}) {
161 push @ignore, $field->name;
162 #print "*** ignoring $field because it is not present ***\n";
165 # stupid inflation , cant get at raw db value easy, must call
166 # deflate ***FIXME****
167 my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
168 if ($raw->{$field} eq $cur_val) {
169 #print "*** ignoring $field because unchanged ***\n";
170 push @ignore, $field->name;
174 $wanted->{ignore} = \@ignore;
175 #print "*** wanted ****" . Dumper($wanted);
176 ($errors, $validated) = $self->_validate($h,$wanted,1);
177 #print "*** validated data ****" . Dumper($validated);
178 #print "*** errors ****" . Dumper($errors);
180 $params ||= $r->params;
181 my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
182 ($errors, $validated) = $self->validate_all($r, $classified,1);
183 #print "*** errors for validate all ****" . Dumper($errors);
187 #print "*** we have errors ****" . Dumper($errors);
188 $self->{_cgi_update_error} = $errors;
192 # Update all the data
193 my ($obj, $err ) = $self->_do_update_all($validated);
195 $self->{_cgi_update_error} = $err;
203 Validates (untaints) a hash of possibly mixed table params. It returns hashrefs
204 of errors and validated data.
209 my ($self, $r, $classified, $updating) = @_;
211 # Base case - validate this classes data
212 my $all = eval{ $r->config->{$self->table}{all_cols} } ||
213 [$self->columns('All')];
214 my $req = eval{ $r->config->{$self->table}{required_cols} } ||
216 my $ignore = eval{ $r->config->{$self->table}{ignore_cols} } ||
218 push @$ignore, $self->primary_column->name if $updating;
219 # ignore hashes of foreign inputs
220 foreach (keys %$classified) {
221 push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
223 my $h = $Untainter->new($classified);
224 my ($errs, $validated) = $self->_validate(
225 $h, {all => $all, required => $req, ignore => $ignore},$updating
228 #warn "Validated dump is " . Dumper($validated);
229 #warn "classified dump is " . Dumper($classified);
230 # Validate all foreign input
231 foreach my $field (keys %$classified) {
232 if (ref $classified->{$field} eq "HASH") {
233 my $data = $classified->{$field};
234 # warn "Dump of fdata for $field: " . Dumper($data) if $r->debug;
235 my @usr_entered_vals = ();
236 my %required = map { $_ => 1 }
237 @{$r->config->{$self->table}{required_cols}};
238 foreach ( values %$data ) {
239 push @usr_entered_vals, $_ if $_ ne '';
243 # IF we have some inputs for the related
244 if ( @usr_entered_vals ) {
245 # warn "user entered vals . " . Dumper(\@usr_entered_vals) if $r->debug;
246 my ($ferrs, $valid) = $self->related_class($r, $field)->validate_all($r, $classified->{$field}, $updating );
247 $errs->{$field} = $ferrs if $ferrs;
248 $validated->{$field} = $valid;
250 # Check its not requeired
251 if ($required{$field}) {
252 $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
257 undef $errs unless keys %$errs;
258 return ($errs, $validated);
263 my ($self, $h, $wanted, $updating) = @_;
264 my %required = map { $_ => 1 } @{$wanted->{required}};
266 $seen{$_}++ foreach @{$wanted->{ignore}};
269 $wanted->{all} = [ $self->columns ] unless @{$wanted->{all} || [] } ;
270 foreach my $field (@{$wanted->{required}}, @{$wanted->{all}}) {
271 next if $seen{$field}++;
272 my $type = $self->untaint_type($field) or
273 do { warn "No untaint type for $self 's field $field. Ignoring.";
276 my $value = $h->extract("-as_$type" => $field);
279 # Required field error
280 if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
281 #($value eq '' or !defined $value))
282 $errors->{$field} = "You must supply '$field'"
283 #unless ($updating and$self->field;
286 # 1: No inupt entered
287 if ($err =~ /^No input for/) {
288 # A : Updating -- set the field to undef or ''
290 $fields->{$field} = eval{$self->column_nullable($field)} ?
293 # B : Creating -- dont set a value and RDMS will put default
296 # 2: A real untaint error -- just set the error
297 elsif ($err !~ /^No parameter for/) {
298 $errors->{$field} = $err;
301 $fields->{$field} = $value
304 undef $errors unless keys %$errors;
305 return ($errors, $fields);
313 # Untaints and Creates objects from hashed params.
314 # Returns parent object and errors.
316 my ($self, $validated) = @_;
317 my $class = ref $self || $self;
318 my ($errors, $accssr);
320 # Separate out related objects' data from main hash
322 foreach (keys %$validated) {
323 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
325 # Make has_own/a rel type objects and put id in parent's data hash
326 foreach $accssr (keys %related) {
327 my $rel_meta = $self->related_meta('r', $accssr);
328 $self->_croak("No relationship found for $accssr to $class.")
330 my $rel_type = $rel_meta->{name};
331 if ($rel_type =~ /(^has_own$|^has_a$)/) {
332 my $fclass= $rel_meta->{foreign_class};
333 my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr});
334 # put id in parent's data hash
335 if (not keys %$errs) {
336 $validated->{$accssr} = $rel_obj->id;
338 $errors->{$accssr} = $errs;
340 delete $related{$accssr}; # done with this
344 # Make main object -- base case
345 my $me_obj = eval { $self->insert($validated) };
347 warn "Just failed making a " . $self. " FATAL Error is $@";
348 $errors->{FATAL} = $@;
349 return (undef, $errors);
352 if (eval{$self->model_debug}) {
354 warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
356 warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
360 # Make other related (must_have, might_have, has_many , etc )
361 foreach $accssr ( keys %related ) {
362 my ($rel_obj, $errs) =
363 $me_obj->_create_related($accssr, $related{$accssr});
364 $errors->{$accssr} = $errs if $errs;
367 undef $errors unless keys %$errors;
368 return ($me_obj, $errors);
376 # Updates objects from hashed untainted data
380 my ($self, $validated) = @_;
381 my ($errors, $accssr);
383 # Separate out related objects' data from main hash
385 foreach (keys %$validated) {
386 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
389 # set does not work with IsA right now so we set each col individually
390 #$self->set(%$validated);
391 my $old = $self->autoupdate(0);
392 for (keys %$validated) {
393 $self->$_($validated->{$_});
396 $self->autoupdate($old);
399 foreach $accssr (keys %related) {
400 my $fobj = $self->$accssr;
401 my $validated = $related{$accssr};
403 my $old = $fobj->autoupdate(0);
404 for (keys %$validated) {
405 $fobj->$_($validated->{$_});
408 $fobj->autoupdate($old);
411 $fobj = $self->_create_related($accssr, $related{$accssr});
422 # Creates and automatically relates newly created object to calling object
423 # It returns related object and possibly errors
425 sub _create_related {
426 # self is object or class, accssr is accssr to relationship, params are
427 # data for relobject, and created is the array ref to store objs we
429 my ( $self, $accssr, $params, $created ) = @_;
430 $self->_croak ("Can't make related object without a parent $self object")
433 my $rel_meta = $self->related_meta('r',$accssr);
435 $self->_croak("No relationship for $accssr in " . ref($self));
437 my $rel_type = $rel_meta->{name};
438 my $fclass = $rel_meta->{foreign_class};
441 if ($rel_type ne 'has_own' or $rel_type ne 'has_a') {
442 # set up params for might_have, has_many, etc
443 $params->{ $rel_meta->{args}{foreign_column} } = $self->id;
444 %$params = ( %$params, %{$rel_meta->{args}->{constraint} || {}} );
445 ($rel, $errs) = $fclass->_do_create_all($params, $created);
448 ($rel, $errs) = $fclass->_do_create_all($params, $created);
450 $self->$accssr($rel->id);
454 return ($rel, $errs);
461 ########################
462 # classify_form_inputs #
463 ########################
464 ################################################################################
465 # Foreign inputs are inputs that have data for a related table.
466 # We must name them so we can tell which related class they belong to.
467 # This assumes the form : $accessor . $delimeter . $column.
469 # Example Customer must_have person which is a
470 # CstmrPrsn which has_a Person;
472 # Customer->must_have('cstmrprsn' => 'CstmrPrsn');
473 # CstmrPrsn->has_own('prsn_id' => 'Person');
475 # If you say: Customer->to_field('cstmrprsn');
476 # AsForm makes inputs for CstmrPrsn which leads to inputs for Person (first
477 # _name, last_name, etc);
478 # We need to keep track that the Person inputs are not related to Customer
479 # directly but to the CstmrPrsn object which is related to Customer.
481 # Input Names end up like so:
482 # cstmr_type # Customer column
483 # cstmrprsn__AF__role # CstmrPrsn column
484 # cstmrprsn__AF__person__AF__first_name # Person column
485 # cstmrprsn__AF__person__AF__last_name # Person column
488 # So our job is to rehash the inputs into a multi level hash keyed on
489 # column or virtual column (accessor) names.
492 ###############################################################################
494 =head2 classify_form_inputs
498 sub classify_form_inputs {
499 my ($self, $params, $delimiter) = @_;
502 $delimiter ||= $self->foreign_input_delimiter;
503 # Put forminputs in own hashes by accessor (class they belong too)
504 # AsForm makes "$accessor__AF__columnname" form for foeign inputs
505 foreach my $input_name (keys %$params) {
506 my @accssrs = split /$delimiter/, $input_name;
507 my $col_name = pop @accssrs;
508 $bottom_level = \%hashed;
509 while ( my $a = shift @accssrs ) {
510 $bottom_level->{$a} ||= {};
511 $bottom_level = $bottom_level->{$a}; # point to bottom level
513 # now insert parameter at bottom level keyed on col name
514 $bottom_level->{$col_name} = $params->{$input_name};
519 sub _untaint_handlers {
520 my ($me, $them) = @_;
521 return () unless $them->can('__untaint_types');
522 my %type = %{ $them->__untaint_types || {} };
524 @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
528 sub _column_type_for {
532 varchar => 'printable',
535 tinyint => 'integer',
536 smallint => 'integer',
537 mediumint => 'integer',
543 return $map{$type} || "";
552 Peter Speltz, Aaron Trevena
554 =head1 AUTHORS EMERITUS
560 * complete documentation
561 * ensure full backward compatibility with Class::DBI::FromCGI
563 =head1 BUGS and QUERIES
565 Please direct all correspondence regarding this module to:
568 =head1 COPYRIGHT AND LICENSE
570 Copyright 2003-2004 by Tony Bowden
572 This library is free software; you can redistribute it and/or modify
573 it under the same terms as Perl itself.
577 L<Class::DBI>, L<Class::DBI::FromCGI>