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
=cut
-use warnings;
# The base base model class for apps
# provides good search and create functions
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/;
=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
=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.
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
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) {
=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
}
}
$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);
}
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
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
}
$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};
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;
}
#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 {
# 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
}
}
undef $errors unless keys %$errors;
- return ($errors, $fields);
+ return ($fields, $errors);
}
##################
# 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;
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 . ")";
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);
###################
# 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);
}
=head1 AUTHORS
-Peter Speltz
+Peter Speltz, Aaron Trevena
=head1 AUTHORS EMERITUS
=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.
projects / maypole.git / blobdiff