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_inputs validate_all _do_update_all
31 _do_create_all _create_related 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);
100 advanced usage: $beer->create_from_cgi($r[,$options ]);
101 old style: $beer->create_from_cgi($h[,$opts ]);
103 A hashref of options can be passed. It can contain:
105 params -- hashref of to use instead of $r->params,
106 required_cols -- list of fields that are required
107 ignore_cols -- list of fields to ignore
112 sub create_from_cgi {
113 my ($self, $r, $opts) = @_;
114 $self->_croak( "create_from_cgi can only be called as a class method")
116 my ($errors, $validated);
119 if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility
120 ($errors, $validated) = $self->validate_inputs($r,$opts);
122 my $params = $opts->{params} || $r->params;
123 $opts->{params} = $self->classify_form_inputs($params);
124 ($errors, $validated) = $self->validate_all($r, $opts);
128 return bless { _cgi_update_error => $errors }, $self;
131 # Insert all the data
132 my ($obj, $err ) = $self->_do_create_all($validated);
134 return bless { _cgi_update_error => $err }, $self;
140 =head2 update_from_cgi
142 returns 1 or nothing if errors
143 TODO -- support $film->update_from_cgi($h => @columns_to_update);
149 sub update_from_cgi {
150 my ($self, $r, $opts) = @_;
151 $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
152 my ($errors, $validated);
153 $self->{_cgi_update_error} = {};
154 $opts->{updating} = 1;
156 # FromCGI interface compatibility
157 if ($r->isa('CGI::Untaint')) {
158 # REHASH the $opts for updating:
159 # 1: we ignore any fields we dont have parmeter for. (safe ?)
160 # 2: we dont want to update fields unless they change
162 my @ignore = @{$opts->{ignore} || []};
163 push @ignore, $self->primary_column->name;
164 my $raw = $r->raw_data;
165 #print "*** raw data ****" . Dumper($raw);
166 foreach my $field ($self->columns) {
167 #print "*** field is $field ***\n";
168 if (not defined $raw->{$field}) {
169 push @ignore, $field->name;
170 #print "*** ignoring $field because it is not present ***\n";
173 # stupid inflation , cant get at raw db value easy, must call
174 # deflate ***FIXME****
175 my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
176 if ($raw->{$field} eq $cur_val) {
177 #print "*** ignoring $field because unchanged ***\n";
178 push @ignore, "$field";
181 $opts->{ignore} = \@ignore;
182 ($errors, $validated) = $self->validate_inputs($r,$opts);
184 my $params = $opts->{params} || $r->params;
185 $opts->{params} = $self->classify_form_inputs($params);
186 ($errors, $validated) = $self->validate_all($r, $opts);
187 #print "*** errors for validate all ****" . Dumper($errors);
191 #print "*** we have errors ****" . Dumper($errors);
192 $self->{_cgi_update_error} = $errors;
196 # Update all the data
197 my ($obj, $err ) = $self->_do_update_all($validated);
199 $self->{_cgi_update_error} = $err;
207 Validates (untaints) a hash of possibly mixed table params. It returns hashrefs
208 of errors and validated data.
213 my ($self, $r, $opts) = @_;
214 my $class = ref $self || $self;
215 my $classified = $opts->{params};
216 my $updating = $opts->{updating};
218 # Base case - validate this classes data
219 $opts->{all} ||= eval{ $r->config->{$self->table}{all_cols} } ||
220 [$self->columns('All')];
221 $opts->{required} ||= eval{ $r->config->{$self->table}{required_cols} } ||
223 my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} }
225 push @$ignore, $self->primary_column->name if $updating;
227 # Ignore hashes of foreign inputs. This takes care of required has_a's
228 # for main object that we have foreign inputs for.
229 foreach (keys %$classified) {
230 push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
232 $opts->{ignore} = $ignore;
233 my $h = $Untainter->new($classified);
234 my ($errs, $validated) = $self->validate_inputs($h, $opts);
236 # Validate all foreign input
238 foreach my $field (keys %$classified) {
239 if (ref $classified->{$field} eq "HASH") {
240 my $data = $classified->{$field};
242 my @usr_entered_vals = ();
243 foreach ( values %$data ) {
244 push @usr_entered_vals, $_ if $_ ne '';
248 # IF we have some inputs for the related
249 if ( @usr_entered_vals ) {
250 # We need to ignore us if we are a required has_a in this foreign class
251 my $rel_meta = $self->related_meta($r, $field);
252 my $fclass = $rel_meta->{foreign_class};
253 my $fmeta = $fclass->meta_info('has_a');
255 if ($fmeta->{$_}{foreign_class} eq $class) {
259 my ($ferrs, $valid) = $fclass->validate_all($r,
260 {params => $data, updating => $updating, ignore => $ignore } );
262 $errs->{$field} = $ferrs if $ferrs;
263 $validated->{$field} = $valid;
266 # Check this foreign object is not requeired
267 my %req = map { $_ => 1 } $opts->{required};
269 $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
274 #warn "Validated inputs are " . Dumper($validated);
275 undef $errs unless keys %$errs;
276 return ($errs, $validated);
280 =head2 validate_inputs
282 $self->validate_inputs($h, $opts);
286 sub validate_inputs {
287 my ($self, $h, $opts) = @_;
288 my $updating = $opts->{updating};
289 my %required = map { $_ => 1 } @{$opts->{required}};
291 $seen{$_}++ foreach @{$opts->{ignore}};
294 $opts->{all} = [ $self->columns ] unless @{$opts->{all} || [] } ;
295 foreach my $field (@{$opts->{required}}, @{$opts->{all}}) {
296 next if $seen{$field}++;
297 my $type = $self->untaint_type($field) or
298 do { warn "No untaint type for $self 's field $field. Ignoring.";
301 my $value = $h->extract("-as_$type" => $field);
304 # Required field error
305 if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
306 #($value eq '' or !defined $value))
307 $errors->{$field} = "You must supply '$field'"
308 #unless ($updating and$self->field;
311 # 1: No inupt entered
312 if ($err =~ /^No input for/) {
313 # A : Updating -- set the field to undef or ''
315 $fields->{$field} = eval{$self->column_nullable($field)} ?
318 # B : Creating -- dont set a value and RDMS will put default
321 # 2: A real untaint error -- just set the error
322 elsif ($err !~ /^No parameter for/) {
323 $errors->{$field} = $err;
326 $fields->{$field} = $value
329 undef $errors unless keys %$errors;
330 return ($errors, $fields);
338 # Untaints and Creates objects from hashed params.
339 # Returns parent object and errors.
341 my ($self, $validated) = @_;
342 my $class = ref $self || $self;
343 my ($errors, $accssr);
345 # Separate out related objects' data from main hash
347 foreach (keys %$validated) {
348 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
350 # Make has_own/a rel type objects and put id in parent's data hash
351 # foreach $accssr (keys %related) {
352 # my $rel_meta = $self->related_meta('r', $accssr);
353 # $self->_croak("No relationship found for $accssr to $class.")
355 # my $rel_type = $rel_meta->{name};
356 # if ($rel_type =~ /(^has_own$|^has_a$)/) {
357 # my $fclass= $rel_meta->{foreign_class};
358 # my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr});
359 # # put id in parent's data hash
360 # if (not keys %$errs) {
361 # $validated->{$accssr} = $rel_obj->id;
363 # $errors->{$accssr} = $errs;
365 # delete $related{$accssr}; # done with this
369 # Make main object -- base case
370 #warn "\n*** validated data is " . Dumper($validated). "***\n";
371 my $me_obj = eval { $self->create($validated) };
373 warn "Just failed making a " . $self. " FATAL Error is $@"
374 if (eval{$self->model_debug});
375 $errors->{FATAL} = $@;
376 return (undef, $errors);
379 if (eval{$self->model_debug}) {
381 warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
383 warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
387 # Make other related (must_have, might_have, has_many etc )
388 foreach $accssr ( keys %related ) {
389 my ($rel_obj, $errs) =
390 $me_obj->_create_related($accssr, $related{$accssr});
391 $errors->{$accssr} = $errs if $errs;
394 warn "Errors are " . Dumper($errors);
396 undef $errors unless keys %$errors;
397 return ($me_obj, $errors);
405 # Updates objects from hashed untainted data
409 my ($self, $validated) = @_;
410 my ($errors, $accssr);
412 # Separate out related objects' data from main hash
414 foreach (keys %$validated) {
415 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
418 # set does not work with IsA right now so we set each col individually
419 #$self->set(%$validated);
420 my $old = $self->autoupdate(0);
421 for (keys %$validated) {
422 $self->$_($validated->{$_});
425 $self->autoupdate($old);
428 foreach $accssr (keys %related) {
429 my $fobj = $self->$accssr;
430 my $validated = $related{$accssr};
432 my $old = $fobj->autoupdate(0);
433 for (keys %$validated) {
434 $fobj->$_($validated->{$_});
437 $fobj->autoupdate($old);
440 $fobj = $self->_create_related($accssr, $related{$accssr});
451 # Creates and automatically relates newly created object to calling object
452 # It returns related object and possibly errors
454 sub _create_related {
455 # self is object or class, accssr is accssr to relationship, params are
456 # data for relobject, and created is the array ref to store objs we
458 my ( $self, $accssr, $params, $created ) = @_;
459 $self->_croak ("Can't make related object without a parent $self object")
462 my $rel_meta = $self->related_meta('r',$accssr);
464 $self->_croak("No relationship for $accssr in " . ref($self));
466 my $rel_type = $rel_meta->{name};
467 my $fclass = $rel_meta->{foreign_class};
468 warn " Dumper of meta is " . Dumper($rel_meta);
473 # Set up params for might_have, has_many, etc
474 if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
476 # Foreign Key meta data not very standardized in CDBI
477 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
478 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
479 my %data = (%$params, $fkey => $self->id);
480 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
481 warn "Data is " . Dumper(\%data);
482 ($rel, $errs) = $fclass->_do_create_all(\%data, $created);
485 ($rel, $errs) = $fclass->_do_create_all($params, $created);
487 $self->$accssr($rel->id);
491 return ($rel, $errs);
497 =head2 classify_form_inputs
499 $self->classify_form_inputs($params[, $delimiter]);
501 Foreign inputs are inputs that have data for a related table.
502 They come named so we can tell which related class they belong to.
503 This assumes the form : $accessor . $delimeter . $column recursively
504 classifies them into hashes. It returns a hashref.
508 sub classify_form_inputs {
509 my ($self, $params, $delimiter) = @_;
512 $delimiter ||= $self->foreign_input_delimiter;
513 foreach my $input_name (keys %$params) {
514 my @accssrs = split /$delimiter/, $input_name;
515 my $col_name = pop @accssrs;
516 $bottom_level = \%hashed;
517 while ( my $a = shift @accssrs ) {
518 $bottom_level->{$a} ||= {};
519 $bottom_level = $bottom_level->{$a}; # point to bottom level
521 # now insert parameter at bottom level keyed on col name
522 $bottom_level->{$col_name} = $params->{$input_name};
527 sub _untaint_handlers {
528 my ($me, $them) = @_;
529 return () unless $them->can('__untaint_types');
530 my %type = %{ $them->__untaint_types || {} };
532 @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
536 sub _column_type_for {
540 varchar => 'printable',
543 tinyint => 'integer',
544 smallint => 'integer',
545 mediumint => 'integer',
547 integer => 'integer',
552 return $map{$type} || "";
563 =head1 AUTHORS EMERITUS
570 * add_to_from_cgi, search_from_cgi
571 * complete documentation
572 * ensure full backward compatibility with Class::DBI::FromCGI
574 =head1 BUGS and QUERIES
576 Please direct all correspondence regarding this module to:
579 =head1 COPYRIGHT AND LICENSE
581 Copyright 2003-2004 by Tony Bowden
583 This library is free software; you can redistribute it and/or modify
584 it under the same terms as Perl itself.
588 L<Class::DBI>, L<Class::DBI::FromCGI>