1 package Maypole::Model::CDBI::FromCGI;
5 # The base base model class for apps --
6 # provides good search and create functions
10 use Maypole::Constants;
11 use CGI::Untaint::Maypole;
12 our $Untainter = 'CGI::Untaint::Maypole';
14 our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns
15 cgi_update_errors untaint_type _validate validate_all _do_update_all
16 _do_create_all classify_form_inputs/;
20 use Data::Dumper; # for debugging
24 die "untaint_columns() needs a hash" unless @_ % 2;
25 my ($class, %args) = @_;
26 $class->mk_classdata('__untaint_types')
27 unless $class->can('__untaint_types');
28 my %types = %{ $class->__untaint_types || {} };
29 while (my ($type, $ref) = each(%args)) {
32 $class->__untaint_types(\%types);
35 # get/set untaint_type for a column
37 my ($class, $field, $new_type) = @_;
38 my %handler = __PACKAGE__->_untaint_handlers($class);
39 return $handler{$field} if $handler{$field};
41 local $SIG{__WARN__} = sub { };
42 my $type = $class->column_type($field) or die;
43 _column_type_for($type);
45 return $handler || undef;
48 sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
56 # Creates multiple objects from a cgi form.
57 # Errors are returned in cgi_update_errors
59 # simple usage: $beer->create_from_cgi($r);
61 # The last arg is flag to say whether to classify inputs or not.
62 # TODO : make 100% backward compatible
66 my ($self, $r, $params, $no_classify) = @_;
67 $self->_croak( "create_from_cgi can only be called as a class method")
70 my ($errors, $validated);
71 #print "*** create_from_cgi ***\n\n";
72 # FromCGI interface compatibility
73 # params are ($h, $wanted)
74 if ($r->isa('CGI::Untaint')) {
75 #print "*** raw data ***" . Dumper($r->raw_data);
76 #print "*** wanted data ***" . Dumper($params);
78 ($errors, $validated) = $self->_validate($r,$params);
79 #print "*** validated data ***" . Dumper($validated);
80 #print "*** errors data ***" . Dumper($errors);
83 $params ||= $r->params;
84 my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
85 ($errors, $validated) = $self->validate_all($r, $classified);
89 return bless { _cgi_update_error => $errors }, $self;
93 my ($obj, $err ) = $self->_do_create_all($validated);
95 return bless { _cgi_update_error => $err }, $obj ;
105 # returns 1 or nothing if errors
108 sub update_from_cgi {
109 my ($self, $r, $params, $no_classify) = @_;
110 $self->_croak( "update_from_cgi can only be called as an object method")
112 my ($errors, $validated, $wanted);
113 $self->{_cgi_update_error} = {};
115 #print "*** update_from_cgi talking ***\n\n";
116 # FromCGI interface compatibility params are ($h, $wanted)
117 if ($r->isa('CGI::Untaint')) {
118 # REHASH the $wanted for updating:
119 # 1: we ignore any fields we dont have parmeter for. (safe ?)
120 # 2: we dont want to update fields unless they change
122 my ($h, $wanted) = ($r, $params);
123 my @ignore = @{$wanted->{ignore} || []};
124 push @ignore, $self->primary_column->name;
125 my $raw = $h->raw_data;
126 #print "*** raw data ****" . Dumper($raw);
127 foreach my $field ($self->columns) {
128 #print "*** field is $field ***\n";
129 if (not defined $raw->{$field}) {
130 push @ignore, $field->name;
131 #print "*** ignoring $field because it is not present ***\n";
135 # stupid inflation , cant get at raw db value easy, must call
136 # deflate ***FIXME****
137 my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
138 if ($raw->{$field} eq $cur_val) {
139 #print "*** ignoring $field because unchanged ***\n";
140 push @ignore, $field->name;
144 $wanted->{ignore} = \@ignore;
145 #print "*** wanted ****" . Dumper($wanted);
146 ($errors, $validated) = $self->_validate($h,$wanted,1);
147 #print "*** validated data ****" . Dumper($validated);
148 #print "*** errors ****" . Dumper($errors);
151 $params ||= $r->params;
152 my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
153 ($errors, $validated) = $self->validate_all($r, $classified,1);
154 #print "*** errors for validate all ****" . Dumper($errors);
158 #print "*** we have errors ****" . Dumper($errors);
159 $self->{_cgi_update_error} = $errors;
163 # Update all the data
164 my ($obj, $err ) = $self->_do_update_all($validated);
166 $self->{_cgi_update_error} = $err;
175 Validates (untaints) a hash of possibly mixed table params. It returns hashrefs
176 of errors and validated data.
181 my ($self, $r, $classified, $updating) = @_;
183 # Base case - validate this classes data
184 my $all = eval{ $r->config->{$self->table}{all_cols} } ||
185 [$self->columns('All')];
186 my $req = eval{ $r->config->{$self->table}{required_cols} } ||
188 my $ignore = eval{ $r->config->{$self->table}{ignore_cols} } ||
190 push @$ignore, $self->primary_column->name if $updating;
191 # ignore hashes of foreign inputs
192 foreach (keys %$classified) {
193 push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
195 my $h = $Untainter->new($classified);
196 my ($errs, $validated) = $self->_validate(
197 $h, {all => $all, required => $req, ignore => $ignore},$updating
200 #warn "Validated dump is " . Dumper($validated);
201 #warn "classified dump is " . Dumper($classified);
202 # Validate all foreign input
203 foreach my $field (keys %$classified) {
204 if (ref $classified->{$field} eq "HASH") {
205 my $data = $classified->{$field};
206 # warn "Dump of fdata for $field: " . Dumper($data) if $r->debug;
207 my @usr_entered_vals = ();
208 my %required = map { $_ => 1 }
209 @{$r->config->{$self->table}{required_cols}};
210 foreach ( values %$data ) {
211 push @usr_entered_vals, $_ if $_ ne '';
215 # IF we have some inputs for the related
216 if ( @usr_entered_vals ) {
217 # warn "user entered vals . " . Dumper(\@usr_entered_vals) if $r->debug;
218 my ($ferrs, $valid) = $self->related_class($r, $field)->validate_all($r, $classified->{$field}, $updating );
219 $errs->{$field} = $ferrs if $ferrs;
220 $validated->{$field} = $valid;
223 # Check its not requeired
224 if ($required{$field}) {
225 $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
232 undef $errs unless keys %$errs;
233 return ($errs, $validated);
238 my ($self, $h, $wanted, $updating) = @_;
239 my %required = map { $_ => 1 } @{$wanted->{required}};
241 $seen{$_}++ foreach @{$wanted->{ignore}};
244 $wanted->{all} = [ $self->columns ] unless @{$wanted->{all} || [] } ;
245 foreach my $field (@{$wanted->{required}}, @{$wanted->{all}}) {
246 next if $seen{$field}++;
247 my $type = $self->untaint_type($field) or
248 do { warn "No untaint type for $self 's field $field. Ignoring.";
251 my $value = $h->extract("-as_$type" => $field);
254 # Required field error
255 if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
256 #($value eq '' or !defined $value))
257 $errors->{$field} = "You must supply '$field'"
258 #unless ($updating and$self->field;
261 # 1: No inupt entered
262 if ($err =~ /^No input for/)
264 # A : Updating -- set the field to undef or ''
266 $fields->{$field} = eval{$self->column_nullable($field)} ?
269 # B : Creating -- dont set a value and RDMS will put default
272 # 2: A real untaint error -- just set the error
273 elsif ($err !~ /^No parameter for/)
275 $errors->{$field} = $err;
278 $fields->{$field} = $value
281 undef $errors unless keys %$errors;
282 return ($errors, $fields);
292 # Untaints and Creates objects from hashed params.
293 # Returns parent object and errors.
295 my ($self, $validated) = @_;
296 my $class = ref $self || $self;
297 my ($errors, $accssr);
299 # Separate out related objects' data from main hash
301 foreach (keys %$validated) {
302 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
304 # Make has_own/a rel type objects and put id in parent's data hash
305 foreach $accssr (keys %related) {
306 my $rel_meta = $self->related_meta('r', $accssr);
307 $self->_croak("No relationship found for $accssr to $class.")
309 my $rel_type = $rel_meta->{name};
310 if ($rel_type =~ /(^has_own$|^has_a$)/) {
311 my $fclass= $rel_meta->{foreign_class};
312 my ($rel_obj, $errs) = $fclass->_do_create_all($related{$accssr});
313 # put id in parent's data hash
314 if (not keys %$errs) { $validated->{$accssr} = $rel_obj->id; }
315 else { $errors->{$accssr} = $errs; }
316 delete $related{$accssr}; # done with this
320 # Make main object -- base case
321 my $me_obj = eval { $self->insert($validated) };
323 warn "Just failed making a " . $self. " FATAL Error is $@";
324 $errors->{FATAL} = $@;
325 return (undef, $errors);
328 if (eval{$self->model_debug}) {
330 warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
333 warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
337 # Make other related (must_have, might_have, has_many , etc )
338 foreach $accssr ( keys %related )
340 my ($rel_obj, $errs) =
341 $me_obj->_create_related($accssr, $related{$accssr});
342 $errors->{$accssr} = $errs if $errs;
345 undef $errors unless keys %$errors;
346 return ($me_obj, $errors);
354 # Updates objects from hashed untainted data
358 my ($self, $validated) = @_;
359 my ($errors, $accssr);
361 # Separate out related objects' data from main hash
363 foreach (keys %$validated) {
364 $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
367 # set does not work with IsA right now so we set each col individually
368 #$self->set(%$validated);
369 my $old = $self->autoupdate(0);
370 for (keys %$validated) {
371 $self->$_($validated->{$_});
374 $self->autoupdate($old);
377 foreach $accssr (keys %related) {
378 my $fobj = $self->$accssr;
379 my $validated = $related{$accssr};
381 my $old = $fobj->autoupdate(0);
382 for (keys %$validated) {
383 $fobj->$_($validated->{$_});
386 $fobj->autoupdate($old);
389 $fobj = $self->_create_related($accssr, $related{$accssr});
400 # Creates and automatically relates newly created object to calling object
401 # It returns related object and possibly errors
403 sub _create_related {
404 # self is object or class, accssr is accssr to relationship, params are
405 # data for relobject, and created is the array ref to store objs we
407 my ( $self, $accssr, $params, $created ) = @_;
408 $self->_croak ("Can't make related object without a parent $self object")
411 my $rel_meta = $self->related_meta('r',$accssr);
413 $self->_croak("No relationship for $accssr in " . ref($self));
415 my $rel_type = $rel_meta->{name};
416 my $fclass = $rel_meta->{foreign_class};
419 if ($rel_type ne 'has_own' or $rel_type ne 'has_a') {
420 # set up params for might_have, has_many, etc
421 $params->{ $rel_meta->{args}{foreign_column} } = $self->id;
422 %$params = ( %$params, %{$rel_meta->{args}->{constraint} || {}} );
423 ($rel, $errs) = $fclass->_do_create_all($params, $created);
426 ($rel, $errs) = $fclass->_do_create_all($params, $created);
428 $self->$accssr($rel->id);
432 return ($rel, $errs);
439 ########################
440 # classify_form_inputs #
441 ########################
442 ################################################################################
443 # Foreign inputs are inputs that have data for a related table.
444 # We must name them so we can tell which related class they belong to.
445 # This assumes the form : $accessor . $delimeter . $column.
447 # Example Customer must_have person which is a
448 # CstmrPrsn which has_a Person;
450 # Customer->must_have('cstmrprsn' => 'CstmrPrsn');
451 # CstmrPrsn->has_own('prsn_id' => 'Person');
453 # If you say: Customer->to_field('cstmrprsn');
454 # AsForm makes inputs for CstmrPrsn which leads to inputs for Person (first
455 # _name, last_name, etc);
456 # We need to keep track that the Person inputs are not related to Customer
457 # directly but to the CstmrPrsn object which is related to Customer.
459 # Input Names end up like so:
460 # cstmr_type # Customer column
461 # cstmrprsn__AF__role # CstmrPrsn column
462 # cstmrprsn__AF__person__AF__first_name # Person column
463 # cstmrprsn__AF__person__AF__last_name # Person column
466 # So our job is to rehash the inputs into a multi level hash keyed on
467 # column or virtual column (accessor) names.
470 ###############################################################################
471 sub classify_form_inputs {
472 my ($self, $params, $delimiter) = @_;
475 $delimiter ||= $self->foreign_input_delimiter;
476 # Put forminputs in own hashes by accessor (class they belong too)
477 # AsForm makes "$accessor__AF__columnname" form for foeign inputs
478 foreach my $input_name (keys %$params) {
479 my @accssrs = split /$delimiter/, $input_name;
480 my $col_name = pop @accssrs;
481 $bottom_level = \%hashed;
482 while ( my $a = shift @accssrs ) {
483 $bottom_level->{$a} ||= {};
484 $bottom_level = $bottom_level->{$a}; # point to bottom level
486 # now insert parameter at bottom level keyed on col name
487 $bottom_level->{$col_name} = $params->{$input_name};
492 sub _untaint_handlers {
493 my ($me, $them) = @_;
494 return () unless $them->can('__untaint_types');
495 my %type = %{ $them->__untaint_types || {} };
497 @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
501 sub _column_type_for {
505 varchar => 'printable',
508 tinyint => 'integer',
509 smallint => 'integer',
510 mediumint => 'integer',
516 return $map{$type} || "";