-package Maypole::Model::CDBI::FromCGI;
+package Maypole::Model::CDBI::FromCGI;
use strict;
+=head1 NAME
+
+Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects
+
+=head1 SYNOPSIS
+
+...
+
+=head1 DESCRIPTION
+
+Provides a way to validate form input and populate Model Objects, based
+on Class::DBI::FromCGI.
+
+=cut
+
use warnings;
-# The base base model class for apps --
+# The base base model class for apps
# provides good search and create functions
use base qw(Exporter);
our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns
cgi_update_errors untaint_type _validate validate_all _do_update_all
- _do_create_all classify_form_inputs/;
+ _do_create_all classify_form_inputs/;
use Data::Dumper; # for debugging
+=head1 METHODS
+
+=head2 untaint_columns
+
+Replicates Class::DBI::FromCGI method of same name :
+
+ __PACKAGE__->untaint_columns(
+ printable => [qw/Title Director/],
+ integer => [qw/DomesticGross NumExplodingSheep],
+ date => [qw/OpeningDate/],
+ );
+
+=cut
sub untaint_columns {
die "untaint_columns() needs a hash" unless @_ % 2;
$class->__untaint_types(\%types);
}
+=head2 untaint_type
+
+ gets/sets untaint_type for a column, no equivilent in Class::DBI::FromCGI
+
+=cut
+
# get/set untaint_type for a column
sub untaint_type {
my ($class, $field, $new_type) = @_;
return $handler || undef;
}
+=head2 cgi_update_errors
+
+returns cgi update errors
+
+=cut
+
sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
-###################
-# create_from_cgi #
-###################
+=head2 create_from_cgi
-# Creates multiple objects from a cgi form.
-# Errors are returned in cgi_update_errors
-#
-# simple usage: $beer->create_from_cgi($r);
-#
-# The last arg is flag to say whether to classify inputs or not.
-# TODO : make 100% backward compatible
-#
+Based on the same method in Class::DBI::FromCGI.
-sub create_from_cgi {
- my ($self, $r, $params, $no_classify) = @_;
- $self->_croak( "create_from_cgi can only be called as a class method")
- if ref $self;
-
- my ($errors, $validated);
- #print "*** create_from_cgi ***\n\n";
- # FromCGI interface compatibility
- # params are ($h, $wanted)
- if ($r->isa('CGI::Untaint')) {
- #print "*** raw data ***" . Dumper($r->raw_data);
- #print "*** wanted data ***" . Dumper($params);
-
- ($errors, $validated) = $self->_validate($r,$params);
- #print "*** validated data ***" . Dumper($validated);
- #print "*** errors data ***" . Dumper($errors);
- }
- else {
- $params ||= $r->params;
- my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
- ($errors, $validated) = $self->validate_all($r, $classified);
- }
+Creates multiple objects from a cgi form.
+Errors are returned in cgi_update_errors
- if (keys %$errors) {
- return bless { _cgi_update_error => $errors }, $self;
- }
-
- # Insert all the data
- my ($obj, $err ) = $self->_do_create_all($validated);
- if ($err) {
- return bless { _cgi_update_error => $err }, $obj ;
- }
- return $obj;
+simple usage: $beer->create_from_cgi($r);
+
+The last arg is flag to say whether to classify inputs or not.
+TODO : make 100% backward compatible
+
+=cut
+
+sub create_from_cgi {
+ my ($self, $r, $params, $no_classify) = @_;
+ $self->_croak( "create_from_cgi can only be called as a class method")
+ if ref $self;
+
+ my ($errors, $validated);
+ # FromCGI interface compatibility
+ # params are ($h, $wanted)
+ if ($r->isa('CGI::Untaint')) {
+ ($errors, $validated) = $self->_validate($r,$params);
+ } else {
+ $params ||= $r->params;
+ my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
+ ($errors, $validated) = $self->validate_all($r, $classified);
+ }
+
+ if (keys %$errors) {
+ return bless { _cgi_update_error => $errors }, $self;
+ }
+
+ # Insert all the data
+ my ($obj, $err ) = $self->_do_create_all($validated);
+ if ($err) {
+ return bless { _cgi_update_error => $err }, $obj ;
+ }
+ return $obj;
}
-###################
-# update_from_cgi #
-###################
+=head2 update_from_cgi
+
+returns 1 or nothing if errors
-# returns 1 or nothing if errors
-
+=cut
sub update_from_cgi {
- my ($self, $r, $params, $no_classify) = @_;
- $self->_croak( "update_from_cgi can only be called as an object method")
- unless ref $self;
- my ($errors, $validated, $wanted);
- $self->{_cgi_update_error} = {};
-
- #print "*** update_from_cgi talking ***\n\n";
- # FromCGI interface compatibility params are ($h, $wanted)
- if ($r->isa('CGI::Untaint')) {
- # REHASH the $wanted for updating:
- # 1: we ignore any fields we dont have parmeter for. (safe ?)
- # 2: we dont want to update fields unless they change
-
- my ($h, $wanted) = ($r, $params);
- my @ignore = @{$wanted->{ignore} || []};
- push @ignore, $self->primary_column->name;
- my $raw = $h->raw_data;
- #print "*** raw data ****" . Dumper($raw);
- foreach my $field ($self->columns) {
- #print "*** field is $field ***\n";
- if (not defined $raw->{$field}) {
- push @ignore, $field->name;
- #print "*** ignoring $field because it is not present ***\n";
- next;
-
- }
- # stupid inflation , cant get at raw db value easy, must call
- # deflate ***FIXME****
- my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
- if ($raw->{$field} eq $cur_val) {
+ my ($self, $r, $params, $no_classify) = @_;
+ $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
+ my ($errors, $validated, $wanted);
+ $self->{_cgi_update_error} = {};
+
+ # FromCGI interface compatibility params are ($h, $wanted)
+ if ($r->isa('CGI::Untaint')) {
+ # REHASH the $wanted for updating:
+ # 1: we ignore any fields we dont have parmeter for. (safe ?)
+ # 2: we dont want to update fields unless they change
+
+ my ($h, $wanted) = ($r, $params);
+ my @ignore = @{$wanted->{ignore} || []};
+ push @ignore, $self->primary_column->name;
+ my $raw = $h->raw_data;
+ #print "*** raw data ****" . Dumper($raw);
+ foreach my $field ($self->columns) {
+ #print "*** field is $field ***\n";
+ if (not defined $raw->{$field}) {
+ push @ignore, $field->name;
+ #print "*** ignoring $field because it is not present ***\n";
+ next;
+ }
+ # stupid inflation , cant get at raw db value easy, must call
+ # deflate ***FIXME****
+ my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
+ if ($raw->{$field} eq $cur_val) {
#print "*** ignoring $field because unchanged ***\n";
- push @ignore, $field->name;
- }
- }
-
- $wanted->{ignore} = \@ignore;
- #print "*** wanted ****" . Dumper($wanted);
- ($errors, $validated) = $self->_validate($h,$wanted,1);
- #print "*** validated data ****" . Dumper($validated);
- #print "*** errors ****" . Dumper($errors);
- }
- else {
- $params ||= $r->params;
- my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
- ($errors, $validated) = $self->validate_all($r, $classified,1);
- #print "*** errors for validate all ****" . Dumper($errors);
- }
+ push @ignore, $field->name;
+ }
+ }
- if (keys %$errors) {
- #print "*** we have errors ****" . Dumper($errors);
- $self->{_cgi_update_error} = $errors;
- return;
- }
-
- # Update all the data
- my ($obj, $err ) = $self->_do_update_all($validated);
- if ($err) {
- $self->{_cgi_update_error} = $err;
- return;
- }
- return 1;
+ $wanted->{ignore} = \@ignore;
+ #print "*** wanted ****" . Dumper($wanted);
+ ($errors, $validated) = $self->_validate($h,$wanted,1);
+ #print "*** validated data ****" . Dumper($validated);
+ #print "*** errors ****" . Dumper($errors);
+ } else {
+ $params ||= $r->params;
+ my $classified = $no_classify ? {%$params}:$self->classify_form_inputs($params);
+ ($errors, $validated) = $self->validate_all($r, $classified,1);
+ #print "*** errors for validate all ****" . Dumper($errors);
+ }
+
+ if (keys %$errors) {
+ #print "*** we have errors ****" . Dumper($errors);
+ $self->{_cgi_update_error} = $errors;
+ return;
+ }
+
+ # Update all the data
+ my ($obj, $err ) = $self->_do_update_all($validated);
+ if ($err) {
+ $self->{_cgi_update_error} = $err;
+ return;
+ }
+ return 1;
}
-
-
-=head2 validate_all
+
+=head2 validate_all
Validates (untaints) a hash of possibly mixed table params. It returns hashrefs
of errors and validated data.
=cut
sub validate_all {
- my ($self, $r, $classified, $updating) = @_;
-
- # Base case - validate this classes data
- my $all = eval{ $r->config->{$self->table}{all_cols} } ||
- [$self->columns('All')];
- my $req = eval{ $r->config->{$self->table}{required_cols} } ||
- [];
- my $ignore = eval{ $r->config->{$self->table}{ignore_cols} } ||
- [];
- push @$ignore, $self->primary_column->name if $updating;
- # ignore hashes of foreign inputs
- foreach (keys %$classified) {
- push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
- }
- my $h = $Untainter->new($classified);
- my ($errs, $validated) = $self->_validate(
- $h, {all => $all, required => $req, ignore => $ignore},$updating
- );
-
- #warn "Validated dump is " . Dumper($validated);
- #warn "classified dump is " . Dumper($classified);
- # Validate all foreign input
- foreach my $field (keys %$classified) {
- if (ref $classified->{$field} eq "HASH") {
- my $data = $classified->{$field};
-# warn "Dump of fdata for $field: " . Dumper($data) if $r->debug;
- my @usr_entered_vals = ();
- my %required = map { $_ => 1 }
- @{$r->config->{$self->table}{required_cols}};
- foreach ( values %$data ) {
- push @usr_entered_vals, $_ if $_ ne '';
- }
-
- # filled in values
- # IF we have some inputs for the related
- if ( @usr_entered_vals ) {
-# warn "user entered vals . " . Dumper(\@usr_entered_vals) if $r->debug;
- my ($ferrs, $valid) = $self->related_class($r, $field)->validate_all($r, $classified->{$field}, $updating );
- $errs->{$field} = $ferrs if $ferrs;
- $validated->{$field} = $valid;
- }
- else {
+ my ($self, $r, $classified, $updating) = @_;
+
+ # Base case - validate this classes data
+ my $all = eval{ $r->config->{$self->table}{all_cols} } ||
+ [$self->columns('All')];
+ my $req = eval{ $r->config->{$self->table}{required_cols} } ||
+ [];
+ my $ignore = eval{ $r->config->{$self->table}{ignore_cols} } ||
+ [];
+ push @$ignore, $self->primary_column->name if $updating;
+ # ignore hashes of foreign inputs
+ foreach (keys %$classified) {
+ push @$ignore, $_ if ref $classified->{$_} eq 'HASH';
+ }
+ my $h = $Untainter->new($classified);
+ my ($errs, $validated) = $self->_validate(
+ $h, {all => $all, required => $req, ignore => $ignore},$updating
+ );
+
+ #warn "Validated dump is " . Dumper($validated);
+ #warn "classified dump is " . Dumper($classified);
+ # Validate all foreign input
+ foreach my $field (keys %$classified) {
+ if (ref $classified->{$field} eq "HASH") {
+ my $data = $classified->{$field};
+ # warn "Dump of fdata for $field: " . Dumper($data) if $r->debug;
+ my @usr_entered_vals = ();
+ my %required = map { $_ => 1 }
+ @{$r->config->{$self->table}{required_cols}};
+ foreach ( values %$data ) {
+ push @usr_entered_vals, $_ if $_ ne '';
+ }
+
+ # filled in values
+ # IF we have some inputs for the related
+ if ( @usr_entered_vals ) {
+ # warn "user entered vals . " . Dumper(\@usr_entered_vals) if $r->debug;
+ my ($ferrs, $valid) = $self->related_class($r, $field)->validate_all($r, $classified->{$field}, $updating );
+ $errs->{$field} = $ferrs if $ferrs;
+ $validated->{$field} = $valid;
+ } else {
# Check its not requeired
- if ($required{$field}) {
- $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
- }
-
- }
-
- }
+ if ($required{$field}) {
+ $errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
}
- undef $errs unless keys %$errs;
- return ($errs, $validated);
+ }
+ }
+ }
+ undef $errs unless keys %$errs;
+ return ($errs, $validated);
}
sub _validate {
- my ($self, $h, $wanted, $updating) = @_;
- my %required = map { $_ => 1 } @{$wanted->{required}};
- my %seen;
- $seen{$_}++ foreach @{$wanted->{ignore}};
- my $errors = {};
- my $fields = {};
- $wanted->{all} = [ $self->columns ] unless @{$wanted->{all} || [] } ;
- foreach my $field (@{$wanted->{required}}, @{$wanted->{all}}) {
- next if $seen{$field}++;
- my $type = $self->untaint_type($field) or
- do { warn "No untaint type for $self 's field $field. Ignoring.";
- next;
- };
- my $value = $h->extract("-as_$type" => $field);
- my $err = $h->error;
-
- # Required field error
- if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
+ my ($self, $h, $wanted, $updating) = @_;
+ my %required = map { $_ => 1 } @{$wanted->{required}};
+ my %seen;
+ $seen{$_}++ foreach @{$wanted->{ignore}};
+ my $errors = {};
+ my $fields = {};
+ $wanted->{all} = [ $self->columns ] unless @{$wanted->{all} || [] } ;
+ foreach my $field (@{$wanted->{required}}, @{$wanted->{all}}) {
+ next if $seen{$field}++;
+ my $type = $self->untaint_type($field) or
+ do { warn "No untaint type for $self 's field $field. Ignoring.";
+ next;
+ };
+ my $value = $h->extract("-as_$type" => $field);
+ my $err = $h->error;
+
+ # 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) {
+ $errors->{$field} = "You must supply '$field'"
+ #unless ($updating and$self->field;
+ } elsif ($err) {
- # 1: No inupt entered
- if ($err =~ /^No input for/)
- {
+ # 1: No inupt entered
+ if ($err =~ /^No input for/) {
# A : Updating -- set the field to undef or ''
- if ($updating) {
- $fields->{$field} = eval{$self->column_nullable($field)} ?
- undef : '';
- }
- # B : Creating -- dont set a value and RDMS will put default
- }
-
- # 2: A real untaint error -- just set the error
- elsif ($err !~ /^No parameter for/)
- {
- $errors->{$field} = $err;
- }
- } else {
- $fields->{$field} = $value
- }
+ if ($updating) {
+ $fields->{$field} = eval{$self->column_nullable($field)} ?
+ undef : '';
}
- undef $errors unless keys %$errors;
- return ($errors, $fields);
+ # B : Creating -- dont set a value and RDMS will put default
+ }
+
+ # 2: A real untaint error -- just set the error
+ elsif ($err !~ /^No parameter for/) {
+ $errors->{$field} = $err;
+ }
+ } else {
+ $fields->{$field} = $value
+ }
+ }
+ undef $errors unless keys %$errors;
+ return ($errors, $fields);
}
-
-
##################
# _do_create_all #
##################
# Untaints and Creates objects from hashed params.
# Returns parent object and errors.
sub _do_create_all {
- my ($self, $validated) = @_;
- my $class = ref $self || $self;
- my ($errors, $accssr);
-
- # Separate out related objects' data from main hash
- my %related;
- 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
- my $me_obj = eval { $self->insert($validated) };
- if ($@) {
- warn "Just failed making a " . $self. " FATAL Error is $@";
- $errors->{FATAL} = $@;
- return (undef, $errors);
- }
+ my ($self, $validated) = @_;
+ my $class = ref $self || $self;
+ my ($errors, $accssr);
+
+ # Separate out related objects' data from main hash
+ my %related;
+ 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
+ my $me_obj = eval { $self->insert($validated) };
+ if ($@) {
+ warn "Just failed making a " . $self. " FATAL Error is $@";
+ $errors->{FATAL} = $@;
+ return (undef, $errors);
+ }
- if (eval{$self->model_debug}) {
- if ($me_obj) {
- warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
- }
- else {
- warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
- }
- }
+ if (eval{$self->model_debug}) {
+ if ($me_obj) {
+ warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
+ } else {
+ warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
+ }
+ }
- # Make other related (must_have, might_have, has_many , etc )
- foreach $accssr ( keys %related )
- {
- my ($rel_obj, $errs) =
- $me_obj->_create_related($accssr, $related{$accssr});
- $errors->{$accssr} = $errs if $errs;
- }
+ # Make other related (must_have, might_have, has_many , etc )
+ foreach $accssr ( keys %related ) {
+ my ($rel_obj, $errs) =
+ $me_obj->_create_related($accssr, $related{$accssr});
+ $errors->{$accssr} = $errs if $errs;
+ }
- undef $errors unless keys %$errors;
- return ($me_obj, $errors);
+ undef $errors unless keys %$errors;
+ return ($me_obj, $errors);
}
#
#
###############################################################################
+
+=head2 classify_form_inputs
+
+=cut
+
sub classify_form_inputs {
my ($self, $params, $delimiter) = @_;
my %hashed = ();
);
return $map{$type} || "";
}
-
+=head1 MAINTAINER
+
+Maypole Developers
+
+=head1 AUTHORS
+Peter Speltz, Aaron Trevena
+
+=head1 AUTHORS EMERITUS
+
+Tony Bowden
+
+=head1 TODO
+
+* complete documentation
+* ensure full backward compatibility with Class::DBI::FromCGI
+
+=head1 BUGS and QUERIES
+
+Please direct all correspondence regarding this module to:
+ Maypole list.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2003-2004 by Tony Bowden
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Class::DBI>, L<Class::DBI::FromCGI>
+
+=cut
1;
projects / maypole.git / commitdiff