--- /dev/null
+package Maypole::Model::CDBI::FromCGI;
+use strict;
+use warnings;
+
+# The base base model class for apps --
+# provides good search and create functions
+
+use base qw(Exporter);
+use CGI::Untaint;
+use Maypole::Constants;
+use CGI::Untaint::Maypole;
+our $Untainter = 'CGI::Untaint::Maypole';
+
+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/;
+
+
+
+use Data::Dumper; # for debugging
+
+
+sub untaint_columns {
+ die "untaint_columns() needs a hash" unless @_ % 2;
+ my ($class, %args) = @_;
+ $class->mk_classdata('__untaint_types')
+ unless $class->can('__untaint_types');
+ my %types = %{ $class->__untaint_types || {} };
+ while (my ($type, $ref) = each(%args)) {
+ $types{$type} = $ref;
+ }
+ $class->__untaint_types(\%types);
+}
+
+# get/set untaint_type for a column
+sub untaint_type {
+ my ($class, $field, $new_type) = @_;
+ my %handler = __PACKAGE__->_untaint_handlers($class);
+ return $handler{$field} if $handler{$field};
+ my $handler = eval {
+ local $SIG{__WARN__} = sub { };
+ my $type = $class->column_type($field) or die;
+ _column_type_for($type);
+ };
+ return $handler || undef;
+}
+
+sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
+
+
+
+###################
+# 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
+#
+
+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);
+ }
+
+ 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 #
+###################
+
+# returns 1 or nothing if errors
+
+
+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) {
+ #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);
+ }
+
+ 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
+
+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 {
+ # Check its not requeired
+ 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);
+}
+
+
+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/) {
+ #($value eq '' or !defined $value))
+ $errors->{$field} = "You must supply '$field'"
+ #unless ($updating and$self->field;
+ } elsif ($err) {
+
+ # 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
+ }
+ }
+ 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);
+ }
+
+ 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;
+ }
+
+ undef $errors unless keys %$errors;
+ return ($me_obj, $errors);
+}
+
+
+##################
+# _do_update_all #
+##################
+
+# Updates objects from hashed untainted data
+# Returns 1
+
+sub _do_update_all {
+ my ($self, $validated) = @_;
+ my ($errors, $accssr);
+
+ # Separate out related objects' data from main hash
+ my %related;
+ foreach (keys %$validated) {
+ $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
+ }
+ # Update main obj
+ # set does not work with IsA right now so we set each col individually
+ #$self->set(%$validated);
+ my $old = $self->autoupdate(0);
+ for (keys %$validated) {
+ $self->$_($validated->{$_});
+ }
+ $self->update;
+ $self->autoupdate($old);
+
+ # Update related
+ foreach $accssr (keys %related) {
+ my $fobj = $self->$accssr;
+ my $validated = $related{$accssr};
+ if ($fobj) {
+ my $old = $fobj->autoupdate(0);
+ for (keys %$validated) {
+ $fobj->$_($validated->{$_});
+ }
+ $fobj->update;
+ $fobj->autoupdate($old);
+ }
+ else {
+ $fobj = $self->_create_related($accssr, $related{$accssr});
+ }
+ }
+ return 1;
+}
+
+
+###################
+# _create_related #
+###################
+
+# Creates and automatically relates newly created object to calling object
+# It returns related object and possibly errors
+
+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);
+ if (!$rel_meta) {
+ $self->_croak("No relationship for $accssr in " . ref($self));
+ }
+ my $rel_type = $rel_meta->{name};
+ my $fclass = $rel_meta->{foreign_class};
+
+ my ($rel, $errs);
+ if ($rel_type ne 'has_own' or $rel_type ne 'has_a') {
+ # set up params for might_have, has_many, etc
+ $params->{ $rel_meta->{args}{foreign_column} } = $self->id;
+ %$params = ( %$params, %{$rel_meta->{args}->{constraint} || {}} );
+ ($rel, $errs) = $fclass->_do_create_all($params, $created);
+ }
+ else {
+ ($rel, $errs) = $fclass->_do_create_all($params, $created);
+ unless ($errs) {
+ $self->$accssr($rel->id);
+ $self->update;
+ }
+ }
+ return ($rel, $errs);
+}
+
+
+
+
+
+########################
+# classify_form_inputs #
+########################
+################################################################################
+# Foreign inputs are inputs that have data for a related table.
+# We must name them so we can tell which related class they belong to.
+# This assumes the form : $accessor . $delimeter . $column.
+#
+# Example Customer must_have person which is a
+# CstmrPrsn which has_a Person;
+#
+# Customer->must_have('cstmrprsn' => 'CstmrPrsn');
+# CstmrPrsn->has_own('prsn_id' => 'Person');
+#
+# If you say: Customer->to_field('cstmrprsn');
+# AsForm makes inputs for CstmrPrsn which leads to inputs for Person (first
+# _name, last_name, etc);
+# We need to keep track that the Person inputs are not related to Customer
+# directly but to the CstmrPrsn object which is related to Customer.
+#
+# Input Names end up like so:
+# cstmr_type # Customer column
+# cstmrprsn__AF__role # CstmrPrsn column
+# cstmrprsn__AF__person__AF__first_name # Person column
+# cstmrprsn__AF__person__AF__last_name # Person column
+#
+#
+# So our job is to rehash the inputs into a multi level hash keyed on
+# column or virtual column (accessor) names.
+#
+#
+###############################################################################
+sub classify_form_inputs {
+ my ($self, $params, $delimiter) = @_;
+ my %hashed = ();
+ my $bottom_level;
+ $delimiter ||= $self->foreign_input_delimiter;
+ # Put forminputs in own hashes by accessor (class they belong too)
+ # AsForm makes "$accessor__AF__columnname" form for foeign inputs
+ foreach my $input_name (keys %$params) {
+ my @accssrs = split /$delimiter/, $input_name;
+ my $col_name = pop @accssrs;
+ $bottom_level = \%hashed;
+ while ( my $a = shift @accssrs ) {
+ $bottom_level->{$a} ||= {};
+ $bottom_level = $bottom_level->{$a}; # point to bottom level
+ }
+ # now insert parameter at bottom level keyed on col name
+ $bottom_level->{$col_name} = $params->{$input_name};
+ }
+ return \%hashed;
+}
+
+sub _untaint_handlers {
+ my ($me, $them) = @_;
+ return () unless $them->can('__untaint_types');
+ my %type = %{ $them->__untaint_types || {} };
+ my %h;
+ @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
+ return %h;
+}
+
+sub _column_type_for {
+ my $type = lc shift;
+ $type =~ s/\(.*//;
+ my %map = (
+ varchar => 'printable',
+ char => 'printable',
+ text => 'printable',
+ tinyint => 'integer',
+ smallint => 'integer',
+ mediumint => 'integer',
+ int => 'integer',
+ bigint => 'integer',
+ year => 'integer',
+ date => 'date',
+ );
+ return $map{$type} || "";
+}
+
+
+
+
+1;
+
+
--- /dev/null
+#!/usr/bin/perl -w
+use Test::More;
+use lib 'ex'; # Where BeerDB should live
+BEGIN {
+ $ENV{BEERDB_DEBUG} = 2;
+
+ eval { require BeerDB };
+ Test::More->import( skip_all =>
+ "SQLite not working or BeerDB module could not be loaded: $@"
+ ) if $@;
+
+ plan tests =>21;
+
+}
+use Maypole::CLI qw(BeerDB);
+use Maypole::Constants;
+$ENV{MAYPOLE_TEMPLATES} = "t/templates";
+
+isa_ok( (bless {},"BeerDB") , "Maypole");
+
+
+
+# Test create missing required
+like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit?name=&url=www.sammysmiths.com¬es=Healthy Brew"), qr/name' => 'This field is required/, "Required fields necessary to create ");
+
+# Test create with all required
+like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit?name=Samuel Smiths&url=www.sammysmiths.com¬es=Healthy Brew"), qr/^# view/, "Created a brewery");
+
+($brewery,@other) = BeerDB::Brewery->search(name=>'Samuel Smiths');
+
+
+SKIP: {
+ skip "Could not create and retrieve Brewery", 8 unless $brewery;
+ like(eval {$brewery->name}, qr/Samuel Smiths/, "Retrieved Brewery, $brewery, we just created");
+
+ #-------- Test updating printable fields ------------------
+
+ # TEST clearing out required printable column
+ like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit/".$brewery->id."?name="), qr/name' => 'This field is required/, "Required printable field can not be cleared on update");
+
+ # Test cgi update errors hanging around from last request
+ unlike(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit/".$brewery->id), qr/name' => 'This field is required/, "cgi_update_errors did not persist");
+
+ # Test update no columns
+ like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit/".$brewery->id), qr/^# view/, "Updated no columns");
+
+ # Test only updating one non required column
+ like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit/".$brewery->id."?notes="), qr/^# view/, "Updated a single non required column");
+
+ # TEST empty input for non required printable
+ like(BeerDB->call_url("http://localhost/beerdb/brewery/do_edit/".$brewery->id."?notes=&name=Sammy Smiths"), qr/^# view/, "Updated brewery" );
+
+ # TEST update actually cleared out a printable field
+ $val = $brewery->notes ;
+ if ($val eq '') { $val = undef };
+ is($val, undef, "Verified non required printable field was cleared");
+
+ # TEST update did not change a field not in parameter list
+ is($brewery->url, 'www.sammysmiths.com', "A field not in parameter list is not updated.");
+};
+
+#----------------- Test other types of fields --------------
+
+$style = BeerDB::Style->insert({name => 'Stout', notes => 'Rich, dark, creamy, mmmmmm.'});
+
+# TEST create with integer, date, printable fields
+like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit?name=Oatmeal Stout&brewery=".$brewery->id."&style=".$style->id."&score=5¬es=Healthy Brew&price=5.00&tasted=2000-12-01"), qr/^# view/, "Created a beer with date, integer and printable fields");
+
+($beer, @other) = BeerDB::Beer->search(name=>'Oatmeal Stout');
+
+SKIP: {
+ skip "Could not create and retrieve Beer", 7 unless $beer;
+
+ # TEST wiping out an integer field
+ like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit/".$beer->id."?name=Oatmeal Stout&brewery=".$brewery->id."&style=".$style->id."&score=¬es=Healthy Brew&price=5.00"), qr/^# view/, "Updated a beer");
+
+ # TEST update actually cleared out a the integer field
+ $val = $beer->score ;
+ if ($val eq '') { $val = undef };
+ is($val, undef, "Verified non required integer field was cleared");
+
+
+ # TEST invalid integer field
+ like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit/".$beer->id."?name=Oatmeal Stout&brewery=".$brewery->id."&style=Stout&price=5.00"), qr/style' => 'Please provide a valid value/, "Integer field invalid");
+
+ # TEST update with empty date field
+ like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit/".$beer->id."?name=Oatmeal Stout&brewery=".$brewery->id."&style=".$style->id."&tasted=¬es=Healthy Brew&price=5.00"), qr/^# view/, "Updated a beer");
+
+ # TEST update actually cleared out a date field
+ $tasted = $beer->tasted ;
+ if ($tasted eq '') { $tasted = undef };
+ is($tasted, undef, "Verified non required date field was cleared.");
+
+ # TEST invalid date
+ like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit/".$beer->id."?name=Oatmeal Stout&brewery=".$brewery->id."&style=".$style->id."&tasted=baddate¬es=Healthy Brew&price=5.00"), qr/tasted' => 'Please provide a valid value/, "Date field invalid");
+
+ # TEST negative value allowed for required field
+ like(BeerDB->call_url("http://localhost/beerdb/beer/do_edit/".$beer->id."?name=Oatmeal Stout&brewery=".$brewery->id."&price=-5.00"), qr/^# view/, "Negative values allowed for required field");
+
+ # TEST negative value actually got stored
+ is($beer->price, '-5.00', "Negative value for required field stored in database")
+};
+
+$beer_id = $beer->id;
+$beer->delete;
+
+# TEST delete
+$beer = BeerDB::Beer->retrieve($beer_id);
+is($beer, undef, "Deleted Beer");
+
+$brewery->delete;
+$style->delete;
projects / maypole.git / commitdiff