From a4c30c9757a710511bcfabe5cad9a7390eabfbcd Mon Sep 17 00:00:00 2001 From: biopete Date: Tue, 13 Jun 2006 18:49:06 +0000 Subject: [PATCH] CRUD tests, FromCGI that works, test to prove it ;) git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@495 48953598-375a-da11-a14b-00016c27c3ee --- Makefile.PL | 14 +- ex/BeerDB.pm | 12 +- ex/beerdb.sql | 3 +- lib/CGI/Untaint/Maypole.pm | 124 +++++++ lib/Maypole/Model/CDBI.pm | 44 ++- lib/Maypole/Model/CDBI/AsForm.pm | 1 - lib/Maypole/Model/CDBI/FromCGI.pm | 524 ++++++++++++++++++++++++++++++ t/crud.t | 112 +++++++ t/templates/custom/edit | 11 + t/templates/custom/view | 1 + 10 files changed, 819 insertions(+), 27 deletions(-) create mode 100644 lib/CGI/Untaint/Maypole.pm create mode 100644 lib/Maypole/Model/CDBI/FromCGI.pm create mode 100755 t/crud.t create mode 100644 t/templates/custom/edit diff --git a/Makefile.PL b/Makefile.PL index efe9501..302189e 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -16,22 +16,22 @@ WriteMakefile( Class::DBI => 0.96, Class::DBI::SQLite => 0, CGI::Untaint => 1.26, - CGI::Untaint::date => 0, - CGI::Untaint::email => 0, + CGI::Untaint::date => 0, + CGI::Untaint::email => 0, UNIVERSAL::moniker => 0, UNIVERSAL::require => 0, URI => 0, URI::QueryParam => 0, CGI::Simple => 0, - HTTP::Body => 0.5, - HTML::Element => 0, + HTTP::Body => 0.5, + HTML::Element => 0, HTTP::Headers => 1.59, Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, Digest::MD5 => 0, - File::MMagic::XS => 0.08, - Class::DBI::Plugin::Type => 0, + File::MMagic::XS => 0.08, + Class::DBI::Plugin::Type => 0, }, # e.g., Module::Name => 1.1 ( $] >= 5.005 @@ -87,7 +87,7 @@ create table beer ( style integer, name varchar(30), url varchar(120), -# tasted date, + tasted date, score integer(2), price varchar(12), abv varchar(10), diff --git a/ex/BeerDB.pm b/ex/BeerDB.pm index db4ec1c..e0b2894 100644 --- a/ex/BeerDB.pm +++ b/ex/BeerDB.pm @@ -30,8 +30,10 @@ BeerDB->config->application_name('The Beer Database'); BeerDB->config->uri_base( $ENV{BEERDB_BASE} || "http://localhost/beerdb/" ); # Change this to the htdoc root for your maypole application. -BeerDB->config->template_root( $ENV{BEERDB_TEMPLATE_ROOT} ) if $ENV{BEERDB_TEMPLATE_ROOT}; +my @root= ('t/templates'); +push @root,$ENV{BEERDB_TEMPLATE_ROOT} if ($ENV{BEERDB_TEMPLATE_ROOT}); +BeerDB->config->template_root( [@root] ); # Specify the rows per page in search results, lists, etc : 10 is a nice round number BeerDB->config->rows_per_page(10); @@ -42,10 +44,16 @@ BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); BeerDB::Beer->untaint_columns( printable => [qw/abv name price notes url/], integer => [qw/style brewery score/], - date =>[ qw/date/], + date =>[ qw/tasted/], ); BeerDB::Pub->untaint_columns(printable => [qw/name notes url/]); +# Required Fields +BeerDB->config->{brewery}{required_cols} = [qw/name/]; +BeerDB->config->{style}{required_cols} = [qw/name/]; +BeerDB->config->{beer}{required_cols} = [qw/brewery name price/]; +BeerDB->config->{pub}{required_cols} = [qw/name/]; + BeerDB->config->{loader}->relationship($_) for ( "a brewery produces beers", "a style defines beers", diff --git a/ex/beerdb.sql b/ex/beerdb.sql index b5d7d7c..0c6a0df 100644 --- a/ex/beerdb.sql +++ b/ex/beerdb.sql @@ -26,7 +26,8 @@ CREATE TABLE beer ( score integer(2), price varchar(12), abv varchar(10), - notes text + notes text, + tasted date ); CREATE TABLE brewery ( diff --git a/lib/CGI/Untaint/Maypole.pm b/lib/CGI/Untaint/Maypole.pm new file mode 100644 index 0000000..d096c27 --- /dev/null +++ b/lib/CGI/Untaint/Maypole.pm @@ -0,0 +1,124 @@ +package CGI::Untaint::Maypole; + +use strict; +use warnings; +our $VERSION = '0.01'; +use base 'CGI::Untaint'; +use Carp; + +=head1 NAME + +CGI::Untaint::Maypole - Use instead of CGI::Untaint. Based on CGI::Untaint + +=head1 SYNOPSIS + + use CGI::Untaint::Maypole; + my $h = CGI::Untaint::Maypole->new($params); + $value = $h->extract(-as_printable => 'name); + + if ($h->error =~ /No input for/) { + # caught empty input now handle it + .... + } + if ($h->raw_data->{$field} eq $object->$field) { + # Raw data same as database data. Perhaps we should not update field + ... + } + +=head1 DESCRIPTION + +This patches some issues I have with CGI::Untaint. You still need it installed +and you install handlers the same. + +1) Instead of passing the empty string to the untaint handlers and relying on +them to handle it to everyone's liking, it seems better +to have CGI::Untaint just say "No input for field" if the field is blank. + +2) It adds the method C to the get back the parameters the handler +was created with. + +=cut + + +sub raw_data { + return shift->{__data}; +} + +# offending method ripped from base and patched +sub _do_extract { + my $self = shift; + + my %param = @_; + + #---------------------------------------------------------------------- + # Make sure we have a valid data handler + #---------------------------------------------------------------------- + my @as = grep /^-as_/, keys %param; + croak "No data handler type specified" unless @as; + croak "Multiple data handler types specified" unless @as == 1; + + my $field = delete $param{ $as[0] }; + my $skip_valid = $as[0] =~ s/^(-as_)like_/$1/; + my $module = $self->_load_module($as[0]); + + #---------------------------------------------------------------------- + # Do we have a sensible value? Check the default untaint for this + # type of variable, unless one is passed. + #---------------------------------------------------------------------- + + ################# PETER'S PATCH ##################### + my $raw = $self->{__data}->{$field} ; + die "No parameter for '$field'\n" if !defined($raw); + die "No input for '$field'\n" if $raw eq ''; + ##################################################### + + + my $handler = $module->_new($self, $raw); + + my $clean = eval { $handler->_untaint }; + if ($@) { # Give sensible death message + die "$field ($raw) is in invalid format.\n" + if $@ =~ /^Died at/; + die $@; + } + + #---------------------------------------------------------------------- + # Are we doing a validation check? + #---------------------------------------------------------------------- + unless ($skip_valid) { + if (my $ref = $handler->can('is_valid')) { + die "$field ($raw) is in invalid format.\n" + unless $handler->is_valid; + } + } + + return $handler->untainted; +} + +=head1 BUGS + +None known yet. + +=head1 SEE ALSO + +L. L. + +=head1 AUTHOR + +Peter Speltz. + +=head1 BUGS and QUERIES + +Please direct all correspondence regarding this module to: + bug-Maypole@rt.cpan.org + +=head1 COPYRIGHT and LICENSE + +Copyright (C) 2006 Peter Speltz. All rights reserved. + +This module is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index ae11c4d..d8d5ace 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -25,9 +25,18 @@ will instead use Class::DBI classes provided. use base qw(Maypole::Model::Base Class::DBI); use Maypole::Model::CDBI::AsForm; -use CGI::Untaint; + +use Maypole::Model::CDBI::FromCGI; +use CGI::Untaint::Maypole; +our $Untainter = 'CGI::Untaint::Maypole'; + +# or if you like bugs + +#use Class::DBI::FromCGI; +#use CGI::Untaint; +#our $Untainter = 'CGI::Untaint'; + use Class::DBI::Plugin::Type; -use Class::DBI::FromCGI; use Class::DBI::Loader; use Class::DBI::AbstractSearch; use Class::DBI::Plugin::RetrieveAll; @@ -61,7 +70,7 @@ sub do_edit : Exported { my $config = $r->config; my $table = $r->table; - # handle cancel button hits + # handle cancel button hit if ( $r->{params}->{cancel} ) { $r->template("list"); $r->objects( [$self->retrieve_all] ); @@ -119,10 +128,19 @@ sub _do_update_or_create { my $fatal; my $creating = 0; - my $h = CGI::Untaint->new( %{$r->params} ); + my $h = $Untainter->new( %{$r->params} ); # update or create if ($obj) { + # 1: Required fields for update are different than create. Its only required + # if it is in the parameters + +# my @real_required = (); +# my %required = map { $_ => 1 } @$required_cols; +# foreach (keys %{$r->params}) { +# push @real_required, $_ if $required{$_}; +# } + # We have something to edit eval { $obj->update_from_cgi( $h => { required => $required_cols, @@ -132,20 +150,14 @@ sub _do_update_or_create { }; $fatal = $@; } else { - eval { - $obj = $self->create_from_cgi( $h => { + eval { + $obj = $self->create_from_cgi( $h => { required => $required_cols, ignore => $ignored_cols, - } ) - }; - - if ($fatal = $@) { - warn "FATAL ERROR: $fatal" if $r->debug; -# $self->dbi_rollback; - } else { -# $self->dbi_commit; - } - $creating++; + } ); + }; + $fatal = $@; + $creating++; } return $obj, $fatal, $creating; diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 6ca422a..47b0cbd 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -1092,7 +1092,6 @@ sub _select_guts { #$args->{stringify} ||= 'stringify_selectbox'; $args->{selected} = _hash_selected($args) if defined $args->{selected}; - warn "*** Dumpe of selected " . Dumper( $args->{selected} ); my $name = $args->{name} || $col; my $a = HTML::Element->new('select', name => $name); $a->attr( %{$args->{attr}} ) if $args->{attr}; diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm new file mode 100644 index 0000000..8718f9b --- /dev/null +++ b/lib/Maypole/Model/CDBI/FromCGI.pm @@ -0,0 +1,524 @@ +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; + + diff --git a/t/crud.t b/t/crud.t new file mode 100755 index 0000000..2406ad7 --- /dev/null +++ b/t/crud.t @@ -0,0 +1,112 @@ +#!/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; diff --git a/t/templates/custom/edit b/t/templates/custom/edit new file mode 100644 index 0000000..ceee5d2 --- /dev/null +++ b/t/templates/custom/edit @@ -0,0 +1,11 @@ +# edit +[% + + USE dumper; +"# errors dump"; + dumper.dump(errors); +"# parameters dump"; + dumper.dump(request.params); +%] + +# End errors dump diff --git a/t/templates/custom/view b/t/templates/custom/view index c5f9229..ab110c6 100644 --- a/t/templates/custom/view +++ b/t/templates/custom/view @@ -1,3 +1,4 @@ +# view # Begin object list [% FOR obj = objects %] - [% obj.name %] -- 2.39.5