From 43c32b954aa111a98b2d886f0f9c4cf18fe8dd3c Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Thu, 23 Feb 2006 18:48:49 +0000 Subject: [PATCH] removed CGI::Untaint::Maypole, 29 tests now passing git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@462 48953598-375a-da11-a14b-00016c27c3ee --- MANIFEST | 1 - lib/CGI/Untaint/Maypole.pm | 111 ------------------------------- lib/Maypole.pm | 42 ++++-------- lib/Maypole/Model/CDBI.pm | 5 +- lib/Maypole/Model/CDBI/AsForm.pm | 67 ++++++++++--------- t/maypole.t | 77 ++++++++++++++------- 6 files changed, 106 insertions(+), 197 deletions(-) delete mode 100644 lib/CGI/Untaint/Maypole.pm diff --git a/MANIFEST b/MANIFEST index a578fbb..e613d81 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3,7 +3,6 @@ ex/BeerDB.pm ex/beerdb.sql lib/Apache/MVC.pm lib/CGI/Maypole.pm -lib/CGI/Untaint/Maypole.pm lib/Maypole.pm lib/Maypole/Application.pm lib/Maypole/CLI.pm diff --git a/lib/CGI/Untaint/Maypole.pm b/lib/CGI/Untaint/Maypole.pm deleted file mode 100644 index 2320a99..0000000 --- a/lib/CGI/Untaint/Maypole.pm +++ /dev/null @@ -1,111 +0,0 @@ -package CGI::Untaint::Maypole; - -use strict; -use warnings; -our $VERSION = '0.01'; -use base 'CGI::Untaint'; -use Carp; - -=head1 NAME - -CGI::Untaint::Maypole - CGI::Untaint but it returns a "No input for '$field'\n" error for fields left blank on a web form. - -=head1 SYNOPSIS - - if ($h->error =~ /No input for/) { - # caught empty input now handle it - } - - See CGI::Untaint. - -=head1 DESCRIPTION - -Instead of passing the empty string to the untaint handlers, which -do not like it or updating them all, it seemed better -to have CGI::Untaint catch the field left blank exception. So it does. -This should be ok I see no point untainting an empty string. But i am open to suggestions and other patches. - -=cut - - -# 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 ''; - ##################################################### - - - # 'False' values get returned as themselves with no warnings. - # return $self->{__lastval} unless $self->{__lastval}; - - my $handler = $module->_new($self, $raw); - - my $clean = eval { $handler->_untaint }; - if ($@) { # Give sensible death message - die "$field ($raw) does not untaint with default pattern\n" - if $@ =~ /^Died at/; - die $@; - } - - #---------------------------------------------------------------------- - # Are we doing a validation check? - #---------------------------------------------------------------------- - unless ($skip_valid) { - if (my $ref = $handler->can('is_valid')) { - die "$field ($raw) does not pass the is_valid() check\n" - unless $handler->$ref(); - } - } - - return $handler->untainted; -} - -=head1 BUGS - -None known yet. - -=head1 SEE ALSO - -L. L. L. - -=head1 AUTHOR - -Peter Speltz but most code was ripped from CGI::Untaint. - -=head1 BUGS and QUERIES - -Please direct all correspondence regarding this module to: - peterspeltz@cafes.net or bug-CGI-UntaintPatched@rt.cpan.org - -=head1 COPYRIGHT and LICENSE - -Copyright (C) 2005 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.pm b/lib/Maypole.pm index 858c1eb..7b17858 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -562,18 +562,13 @@ sub handler_guts my $applicable = $self->is_model_applicable == OK; - warn "applicable : $applicable"; - - $self->__setup_plain_template unless $applicable; - my $status; + # handle authentication eval { $status = $self->call_authenticate }; - if ( my $error = $@ ) { $status = $self->call_exception($error, "authentication"); - if ( $status != OK ) { warn "caught authenticate error: $error"; @@ -581,7 +576,6 @@ sub handler_guts $self->view_object->error($self, $error) : ERROR; } } - if ( $self->debug and $status != OK and $status != DECLINED ) { $self->view_object->error( $self, @@ -592,40 +586,32 @@ sub handler_guts # We run additional_data for every request $self->additional_data; - - if ($applicable) - { - eval { $self->model_class->process($self) }; - - if ( my $error = $@ ) + + if ($applicable) { + eval { $self->model_class->process($self) }; + if ( my $error = $@ ) { - $status = $self->call_exception($error, "model"); - - if ( $status != OK ) + $status = $self->call_exception($error, "model"); + if ( $status != OK ) { - warn "caught model error: $error"; - return $self->debug ? - $self->view_object->error($self, $error) : ERROR; + warn "caught model error: $error"; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } + } else { + $self->__setup_plain_template; } - + # less frequent path - perhaps output has been set to an error message return OK if $self->output; - -# warn "output before processing view : ", $self->output; # normal path - no output has been generated yet my $processed_view_ok = $self->__call_process_view; - warn "output after processing view : ", $self->output; - - warn "error after processing view : ", $self->{error}; - $self->{content_type} ||= $self->__get_mime_type(); $self->{document_encoding} ||= "utf-8"; - warn "made it to end, processed_view_ok : $processed_view_ok"; return $processed_view_ok; } @@ -663,7 +649,7 @@ sub __load_request_model sub __setup_plain_template { my ($self) = @_; - + # It's just a plain template $self->model_class(undef); diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index a200fc5..5d3bebe 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -36,6 +36,8 @@ use Class::DBI::Pager; use Lingua::EN::Inflect::Number qw(to_PL); use attributes (); +use Data::Dumper; + ############################################################################### # Helper methods @@ -112,7 +114,8 @@ sub _do_update_or_create { my $fatal; my $creating = 0; - my $h = CGI::Untaint::Maypole->new( %{$r->params} ); + + my $h = CGI::Untaint->new( %{$r->params} ); # update or create if ($obj) { diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 267cbea..d11ba70 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -193,6 +193,12 @@ sub unselect_element { } +=head2 a_select_box + + Returns a HTML::Element representing a select box, based on the arguments + +=cut + # make a select box from args sub a_select_box { my ($self, $name, $vals, $selected_val, $contents) = @_; @@ -262,7 +268,6 @@ sub to_field { my $args = shift @args; # argument hash ref use Data::Dumper; - warn "args to_field are $field, " . Dumper(\@args); return $self->_field_from_how($field, $how, $args) || $self->_field_from_relationship($field, $args) || @@ -280,10 +285,10 @@ Override at will. sub _field_from_how { my ($self, $field, $how, $args) = @_; $args ||= ''; - warn "field is $field. how is $how. args are $args"; +# warn "field is $field. how is $how. args are $args"; no strict 'refs'; my $meth = $how ? "_to_$how" : '' ; - warn "Meth is $meth. field is $field"; +# warn "Meth is $meth. field is $field"; return $self->$meth($field, $args) if $meth and $self->can($meth); return; } @@ -308,7 +313,7 @@ sub _field_from_relationship { my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; # maybe has_a select - warn "Dumper of relmeta. " . Dumper($rel_meta); +# warn "Dumper of relmeta. " . Dumper($rel_meta); if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) { # This condictions allows for trumping of the has_a args if (not $rel_meta->{args}{no_select} and not $args->{no_select}) @@ -339,7 +344,7 @@ sub _field_from_relationship { } return; } - + =head2 _field_from_column($field, $args) Returns an input based on the column's characteristics, namely type, or nothing. @@ -417,7 +422,7 @@ sub _to_textfield { $val = $self->$col; if (ref $val) { if (my $meta = $self->related_meta('',$col)) { - warn "Meta for $col"; +# warn "Meta for $col"; if (my $code = $meta->{args}{deflate4edit} ) { $val = ref $code ? &$code($val) : $val->$code; } @@ -566,7 +571,7 @@ sub _to_select { } else { $args->{selected} ||= [ $self->$col ] if ref $self; - warn "selected is " . Dumper($args->{selected}); +# warn "selected is " . Dumper($args->{selected}); my $c = $rel_meta->{args}{constraint} || {}; my $j = $rel_meta->{args}{join} || {}; my @join ; @@ -595,7 +600,7 @@ sub _to_select { # Get items to select from $args->{items} = _select_items($args); - warn "Items selecting from are " . Dumper($args->{items}); +# warn "Items selecting from are " . Dumper($args->{items}); #use Data::Dumper; #warn "Just got items. They are " . Dumper($args->{items}); @@ -642,7 +647,7 @@ sub _select_items { $sql .= " WHERE " . $args->{where} if $args->{where}; $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by}; $sql .= " LIMIT " . $args->{limit} if $args->{limit}; -warn "_select_items sql is : $sql"; +#warn "_select_items sql is : $sql"; return $fclass->db_Main->selectall_arrayref($sql); @@ -779,7 +784,7 @@ sub _to_link_hidden { my $r = $args->{r} || ''; my $url = $args->{url} || ''; use Data::Dumper; - warn "$self Args are " . Dumper($args); +# warn "$self Args are " . Dumper($args); $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.") unless $r; my ($obj, $name); @@ -914,12 +919,10 @@ sub _hash_selected { return \%hashed; } else { warn "AsForm Could not hash the selected argument: $selected"; } -} - - +} -=head2 _select_guts +=head2 _select_guts Internal api method to make the actual select box form elements. @@ -927,8 +930,8 @@ Internal api method to make the actual select box form elements. Array of CDBI objects. Array of scalars , Array or Array refs with cols from class. -=cut +=cut sub _select_guts { @@ -1037,23 +1040,23 @@ sub _options_from_scalars { } sub _options_from_hashes { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my $pk = eval {$args->{class}->primary_column} || 'id'; - my $fclass = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; - my @res; - for (@$items) { - my $val = $_->{$pk}; - my $opt = HTML::Element->new("option", value => $val ); - $opt->attr(selected => "selected") if $selected->{$val}; - my $content = $fclass and $stringify and $fclass->can($stringify) ? - $fclass->$stringify($_) : - join(' ', @$_); - $opt->push_content( $content ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my $pk = eval {$args->{class}->primary_column} || 'id'; + my $fclass = $args->{class} || ''; + my $stringify = $args->{stringify} || ''; + my @res; + for (@$items) { + my $val = $_->{$pk}; + my $opt = HTML::Element->new("option", value => $val ); + $opt->attr(selected => "selected") if $selected->{$val}; + my $content = ($fclass && $stringify && $fclass->can($stringify)) ? + $fclass->$stringify($_) : + join(' ', @$_); + $opt->push_content( $content ); + push (@res, $opt); + } + return @res; } # diff --git a/t/maypole.t b/t/maypole.t index 9e49186..b4f9c8b 100755 --- a/t/maypole.t +++ b/t/maypole.t @@ -5,9 +5,11 @@ use Test::More tests => 84; use Test::MockModule; # module compilation +# Test 1 require_ok('Maypole'); -# loaded modules +# loaded modules +# Tests 2 - 8 { ok($Maypole::VERSION, 'defines $VERSION'); ok($INC{'Maypole/Config.pm'}, 'loads Maypole::Config'); @@ -35,11 +37,10 @@ my @API = qw/ config init_done view_object params query param objects model_clas get_session get_user /; - -can_ok(Maypole => @API); - -ok( ! UNIVERSAL::can(Maypole => 'is_applicable'), 'no is_applicable() method' ); +# Tests 9 to 13 +can_ok(Maypole => @API); +ok( UNIVERSAL::can(Maypole => 'is_applicable'), 'is_applicable() method' ); # added is_applicable back in ok(Maypole->config->isa('Maypole::Config'), 'config is a Maypole::Config object'); ok(! Maypole->init_done, '... which is false by default'); is(Maypole->view_object, undef, '... which is undefined'); @@ -54,6 +55,7 @@ is(Maypole->view_object, undef, '... which is undefined'); # back to package main; my $driver_class = 'MyDriver'; +# Test 14 # subclass inherits API can_ok($driver_class => @API); @@ -74,6 +76,8 @@ $mock_model->mock( ); +# Tests 15 - 21 +warn "Tests 15 to 21\n\n"; # setup { # 2.11 - removed tests to check the installed handler was a different ref after setup(). @@ -106,6 +110,9 @@ $mock_model->mock( $driver_class->config->model($model_class); } + +# Tests 22 - 27 +warn "Tests 22 to 27\n\n"; # Mock the view class my $view_class = 'Maypole::View::TT'; my $mock_view = Test::MockModule->new($view_class); @@ -136,6 +143,8 @@ $mock_view->mock( my ($r, $req); # request objects +# Tests 28 - 38 +warn "tests 28 to 38\n\n"; # handler() { my $init = 0; @@ -176,6 +185,10 @@ my ($r, $req); # request objects ok($init && $driver_class->init_done, "... init() called if !init_done()"); } + +# Tests 39 - 48 +warn "Tests 39 - 48\n\n"; +# Testing handler_guts { # handler_guts() { @@ -189,7 +202,7 @@ my ($r, $req); # request objects my $mock_table = new Test::MockModule($table_class, no_auto => 1); $mock_driver->mock( - #is_applicable => sub {push @{$called{applicable}},\@_; $applicable}, + is_applicable => sub {push @{$called{applicable}},\@_; $applicable}, is_model_applicable => sub {push @{$called{applicable}},\@_; $applicable}, get_request => sub {($r, $req) = @_}, @@ -212,11 +225,13 @@ my ($r, $req); # request objects # allow request $applicable = 1; - $r->{path} = '/table/action'; + $r->{path} = '/table/action'; $r->parse_path; my $status = $r->handler_guts(); + warn "model class ", $r->model_class, "table class : $table_class\n"; + is($r->model_class, $table_class, '... sets model_class from table()'); ok($called{additional_data}, '... call additional_data()'); is($status, $OK, '... return status = OK'); @@ -263,6 +278,8 @@ my ($r, $req); # request objects # ... TODO view processing error handling } +# Tests 49 - 53 +warn "Tests 49 to 53\n\n"; # is_model_applicable() { $r->config->display_tables([qw(one two)]); @@ -287,9 +304,11 @@ my ($r, $req); # request objects is($true_false, 0, '... returns 0 unless $r->table is in ok_tables'); } + +# Tests 54 - 58 +warn "Tests 54 to 58\n\n"; my $mock_driver = new Test::MockModule($driver_class, no_auto => 1); my $mock_table = new Test::MockModule($table_class, no_auto => 1); - # call_authenticate() { my %auth_calls; @@ -298,21 +317,23 @@ my $mock_table = new Test::MockModule($table_class, no_auto => 1); ); my $status = $r->call_authenticate; is_deeply($auth_calls{model_auth}, [$table_class, $r], - '... calls model_class->authenticate if it exists'); - is($status, $OK, '... and returns its status (OK)'); + '... calls model_class->authenticate if it exists'); # 54 + is($status, $OK, '... and returns its status (OK)'); # 55 $mock_table->mock(authenticate => sub {$DECLINED}); $status = $r->call_authenticate; - is($status, $DECLINED, '... or DECLINED, as appropriate'); + is($status, $DECLINED, '... or DECLINED, as appropriate'); # 56 $mock_table->unmock('authenticate'); $mock_driver->mock(authenticate => sub {return $DECLINED}); $status = $r->call_authenticate; - is($status, $DECLINED, '... otherwise it calls authenticte()'); + is($status, $DECLINED, '... otherwise it calls authenticte()'); # 57 $mock_driver->unmock('authenticate'); $status = $r->call_authenticate; - is($status, $OK, '... the default authenticate is OK'); + is($status, $OK, '... the default authenticate is OK'); # 58 } +# Tests 59 - 63 +warn "Tests 59 to 63\n\n"; # call_exception() { my %ex_calls; @@ -338,16 +359,20 @@ my $mock_table = new Test::MockModule($table_class, no_auto => 1); is($status, $ERROR, '... the default exception is ERROR'); } +# Test 64 # authenticate() { is(Maypole->authenticate(), $OK, '... returns OK'); } +# Test 65 # exception() { is(Maypole->exception(), $ERROR, '... returns ERROR'); } +# Tests 66 to 71 +warn "Tests 66 to 71\n\n"; # parse_path() { $r->path(undef); @@ -378,24 +403,28 @@ my $mock_table = new Test::MockModule($table_class, no_auto => 1); # make_uri() and make_path() - see pathtools.t - +# Test 72 # get_template_root() { is(Maypole->get_template_root(), '.', '... returns "."'); } +# Test 73 # parse_location() { eval {Maypole->parse_location()}; like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden'); } +# Test 74 # send_output() { eval {Maypole->send_output}; like($@, qr/Do not use Maypole directly/, '... croaks - must be overriden'); } +# Tests 75 - 84 +warn "Tests 75 to 84\n\n"; # param() { my $p = { foo => 'bar', @@ -407,26 +436,26 @@ my $mock_table = new Test::MockModule($table_class, no_auto => 1); $r->{params} = $p; - is_deeply( [keys %$p], [$r->param] ); + is_deeply( [keys %$p], [$r->param] ); # 75 - cmp_ok( $r->param('foo'), eq => 'bar' ); - cmp_ok( $r->param('num'), '==' => 3 ); - cmp_ok( $r->param('zero'), '==' => 0 ); + cmp_ok( $r->param('foo'), eq => 'bar' ); # 76 + cmp_ok( $r->param('num'), '==' => 3 ); # 77 + cmp_ok( $r->param('zero'), '==' => 0 ); # 78 - ok( ! defined $r->param('buz') ); + ok( ! defined $r->param('buz') ); # 79 # scalar context returns the 1st value, not a ref - cmp_ok( scalar $r->param('quux'), eq => 'one' ); - is_deeply( [$r->param('quux')], [ qw/one two three/ ] ); + cmp_ok( scalar $r->param('quux'), eq => 'one' ); # 80 + is_deeply( [$r->param('quux')], [ qw/one two three/ ] ); # 81 $r->param(foo => 'booze'); - cmp_ok( $r->param('foo'), 'eq', 'booze' ); + cmp_ok( $r->param('foo'), 'eq', 'booze' ); # 82 $r->param(foo => undef); - ok( ! defined $r->param('foo') ); + ok( ! defined $r->param('foo') ); # 83 # cannot introduce new keys $r->param(new => 'sox'); - ok( ! defined $r->param('new') ); + ok( ! defined $r->param('new') ); # 84 } -- 2.39.5