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
+++ /dev/null
-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<CGI>. L<perlsec>. L<CGI::Untaint>.
-
-=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;
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";
$self->view_object->error($self, $error) : ERROR;
}
}
-
if ( $self->debug and $status != OK and $status != DECLINED )
{
$self->view_object->error( $self,
# 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;
}
sub __setup_plain_template
{
my ($self) = @_;
-
+
# It's just a plain template
$self->model_class(undef);
use Lingua::EN::Inflect::Number qw(to_PL);
use attributes ();
+use Data::Dumper;
+
###############################################################################
# Helper methods
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) {
}
+=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) = @_;
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) ||
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;
}
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})
}
return;
}
-
+
=head2 _field_from_column($field, $args)
Returns an input based on the column's characteristics, namely type, or nothing.
$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;
}
}
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 ;
# 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});
$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);
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);
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.
Array of CDBI objects.
Array of scalars ,
Array or Array refs with cols from class.
-=cut
+=cut
sub _select_guts {
}
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;
}
#
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');
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');
# back to package main;
my $driver_class = 'MyDriver';
+# Test 14
# subclass inherits API
can_ok($driver_class => @API);
);
+# 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().
$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);
my ($r, $req); # request objects
+# Tests 28 - 38
+warn "tests 28 to 38\n\n";
# handler()
{
my $init = 0;
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()
{
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) = @_},
# 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');
# ... 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)]);
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;
);
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;
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);
# 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',
$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
}
projects / maypole.git / commitdiff