From 419d9570723c210429e2be23875160f57dd36156 Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Wed, 20 Jun 2007 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.15 --- Changes | 8 + MANIFEST | 9 -- META.yml | 4 +- Makefile.PL | 2 +- lib/CGI/Ex.pm | 2 +- lib/CGI/Ex/App.pm | 94 +++++++----- lib/CGI/Ex/App.pod | 175 +++++++++++++++------ lib/CGI/Ex/Auth.pm | 2 +- lib/CGI/Ex/Conf.pm | 2 +- lib/CGI/Ex/Die.pm | 2 +- lib/CGI/Ex/Dump.pm | 2 +- lib/CGI/Ex/Fill.pm | 2 +- lib/CGI/Ex/JSONDump.pm | 2 +- lib/CGI/Ex/Template.pm | 4 +- lib/CGI/Ex/Validate.pm | 2 +- samples/benchmark/bench_conf_readers.pl | 164 ++++++++++++++++++-- t/4_app_00_base.t | 196 ++++++++++++++++++++---- 17 files changed, 520 insertions(+), 152 deletions(-) diff --git a/Changes b/Changes index aa0bd82..d3f9bcd 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,11 @@ +2.15 + 2007-06-20 + * Fix some warning issues with the Recipe sample in App + * Cleanup require_auth interface in App (you will want to + double check if you have overwritten require_auth in your + application to make sure your implementation is still compatible) + * Require latest Template::Alloy + 2.14 2007-06-12 * Moved CGI::Ex::Template to Template::Alloy diff --git a/MANIFEST b/MANIFEST index f2440d7..c800d2f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -26,23 +26,14 @@ samples/benchmark/bench_cgix_hfif.pl samples/benchmark/bench_conf_readers.pl samples/benchmark/bench_conf_writers.pl samples/benchmark/bench_jsondump.pl -samples/benchmark/bench_method_calling.pl -samples/benchmark/bench_operator_storage.pl -samples/benchmark/bench_optree.pl -samples/benchmark/bench_template.pl -samples/benchmark/bench_template_tag_parser.pl samples/benchmark/bench_validation.pl -samples/benchmark/bench_various_templaters.pl -samples/benchmark/bench_various_templaters.pl.out samples/devel/dprof_conf.d -samples/devel/dprof_template.d samples/devel/dprof_validation.d samples/generate_js.pl samples/index.cgi samples/js_validate_1.html samples/js_validate_2.html samples/js_validate_3.html -samples/memory_template.pl samples/yaml_js_1.html samples/yaml_js_2.html samples/yaml_js_3.html diff --git a/META.yml b/META.yml index 0baa453..9025e12 100644 --- a/META.yml +++ b/META.yml @@ -1,11 +1,11 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: CGI-Ex -version: 2.14 +version: 2.15 version_from: lib/CGI/Ex.pm installdirs: site requires: - Template::Alloy: 1.002 + Template::Alloy: 1.003 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01 diff --git a/Makefile.PL b/Makefile.PL index 754fca4..6b47c5a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,7 +12,7 @@ WriteMakefile( VERSION_FROM => "lib/CGI/Ex.pm", INSTALLDIRS => 'site', PREREQ_PM => { - 'Template::Alloy' => '1.002', + 'Template::Alloy' => '1.003', }, dist => { diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index 6737649..750b5ce 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.14'; + $VERSION = '2.15'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index 9ccbab3..ec3ff6a 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -10,7 +10,7 @@ use strict; use vars qw($VERSION); BEGIN { - $VERSION = '2.14'; + $VERSION = '2.15'; Time::HiRes->import('time') if eval {require Time::HiRes}; eval {require Scalar::Util}; @@ -49,12 +49,6 @@ sub navigate { $self->{'_time'} = time; eval { - ### allow for authentication - my $ref = $self->require_auth; - if ($ref && ! ref $ref) { - return $self if ! $self->get_valid_auth; - } - ### a chance to do things at the very beginning return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate; @@ -98,8 +92,6 @@ sub nav_loop { ### allow for an early return return if $self->pre_loop($path); # a true value means to abort the navigate - my $req_auth = ref($self->require_auth) ? $self->require_auth : undef; - ### iterate on each step of the path foreach ($self->{'path_i'} ||= 0; $self->{'path_i'} <= $#$path; @@ -113,17 +105,18 @@ sub nav_loop { $step = $1; # untaint ### allow for per-step authentication - if ($req_auth - && $req_auth->{$step} - && ! $self->get_valid_auth) { - return; + if (! $self->is_authed) { + my $req = $self->run_hook('require_auth', $step, 1); + if (ref($req) ? $req->{$step} : $req) { # in the hash - or true + return if ! $self->get_valid_auth; + } } ### allow for becoming another package (allows for some steps in external files) $self->morph($step); ### allow for mapping path_info pieces to form elements - if (my $info = $ENV{'PATH_INFO'}) { + if (my $info = $self->path_info) { my $maps = $self->run_hook('path_info_map', $step) || []; croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY')); @@ -195,8 +188,8 @@ sub path { if (! $self->{'path'}) { my $path = $self->{'path'} = []; # empty path - ### add initial items to the form hash from path_info - if (my $info = $ENV{'PATH_INFO'}) { + ### add initial items to the form hash from path_info5B + if (my $info = $self->path_info) { my $maps = $self->path_info_map_base || []; croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY')); @@ -464,6 +457,8 @@ sub dump_history { $note .= ' - {}'; } elsif (ref($resp) eq 'ARRAY' && ! @$resp) { $note .= ' - []'; + } elsif (! defined $resp) { + $note .= ' - undef'; } elsif (! ref $resp || ! $all) { my $max = $self->{'history_max'} || 30; if (length($resp) > $max) { @@ -601,6 +596,10 @@ sub navigate_authenticated { my ($self, $args) = @_; $self = $self->new($args) if ! ref $self; + if ($self->can('require_auth') != \&CGI::Ex::App::require_auth) { + require Carp; + Carp::croak("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting"); + } $self->require_auth(1); return $self->navigate; @@ -608,8 +607,8 @@ sub navigate_authenticated { sub require_auth { my $self = shift; - $self->{'require_auth'} = shift if @_ == 1; - return $self->{'require_auth'}; + $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/); + return $self->{'require_auth'} || 0; } sub is_authed { shift->auth_data } @@ -624,8 +623,16 @@ sub get_valid_auth { my $self = shift; return 1 if $self->is_authed; - ### augment the args with sensible defaults my $args = $self->auth_args; + + ### allow passed in args + if (my $extra = shift) { + $args = {%$args, %$extra}; + } + + ### augment the args with sensible defaults + $args->{'script_name'} ||= $self->script_name; + $args->{'path_info'} ||= $self->path_info; $args->{'cgix'} ||= $self->cgix; $args->{'form'} ||= $self->form; $args->{'cookies'} ||= $self->cookies; @@ -635,9 +642,15 @@ sub get_valid_auth { $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) }; $args->{'login_print'} ||= sub { my ($auth, $template, $hash) = @_; - my $out = $self->run_hook('swap_template', '__login', $template, $hash); - $self->run_hook('fill_template', '__login', \$out, $hash); - $self->run_hook('print_out', '__login', $out); + my $step = '__login'; + my $hash_base = $self->run_hook('hash_base', $step) || {}; + my $hash_comm = $self->run_hook('hash_common', $step) || {}; + my $hash_swap = $self->run_hook('hash_swap', $step) || {}; + my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash}; + + my $out = $self->run_hook('swap_template', $step, $template, $swap); + $self->run_hook('fill_template', $step, \$out, $hash); + $self->run_hook('print_out', $step, \$out); }; require CGI::Ex::Auth; @@ -660,6 +673,19 @@ sub verify_user { 1 } ###----------------------------------------------------------------### ### a few standard base accessors +sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 } + +sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' } + +sub cgix { + my $self = shift; + $self->{'cgix'} = shift if @_ == 1; + return $self->{'cgix'} ||= do { + require CGI::Ex; + CGI::Ex->new; # return of the do + }; +} + sub form { my $self = shift; $self->{'form'} = shift if @_ == 1; @@ -672,15 +698,6 @@ sub cookies { return $self->{'cookies'} ||= $self->cgix->get_cookies; } -sub cgix { - my $self = shift; - $self->{'cgix'} = shift if @_ == 1; - return $self->{'cgix'} ||= do { - require CGI::Ex; - CGI::Ex->new; # return of the do - }; -} - sub vob { my $self = shift; $self->{'vob'} = shift if @_ == 1; @@ -807,15 +824,14 @@ sub print { my $out = $self->run_hook('swap_template', $step, $file, $swap); $self->run_hook('fill_template', $step, \$out, $fill); - - $self->run_hook('print_out', $step, $out); + $self->run_hook('print_out', $step, \$out); } sub print_out { my ($self, $step, $out) = @_; $self->cgix->print_content_type; - print $out; + print ref($out) ? $$out : $out; } sub swap_template { @@ -884,7 +900,7 @@ sub name_module { return $self->{'name_module'} ||= do { # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo" - my $script = $ENV{'SCRIPT_NAME'} || $0; + my $script = $self->script_name; $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)"; $1; # return of the do }; @@ -1033,8 +1049,8 @@ sub hash_base { my $copy = $self; eval {require Scalar::Util; Scalar::Util::weaken($copy)}; my $hash = { - script_name => $ENV{'SCRIPT_NAME'} || $0, - path_info => $ENV{'PATH_INFO'} || '', + script_name => $copy->script_name, + path_info => $copy->path_info, js_validation => sub { $copy->run_hook('js_validation', $step, shift) }, form_name => sub { $copy->run_hook('form_name', $step) }, $self->step_key => $step, @@ -1117,7 +1133,7 @@ sub ext_val { ### default to using this script as a handler sub js_uri_path { my $self = shift; - my $script = $ENV{'SCRIPT_NAME'} || return ''; + my $script = $self->script_name; my $js_step = $self->js_step; return ($self->can('path') == \&CGI::Ex::App::path) ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own) @@ -1132,7 +1148,7 @@ sub js_run_step { my $self = shift; ### make sure path info looks like /js/CGI/Ex/foo.js - my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || ''; + my $file = $self->form->{'js'} || $self->path_info; $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; $self->cgix->print_js($file); diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod index 0188cdc..6fe9746 100644 --- a/lib/CGI/Ex/App.pod +++ b/lib/CGI/Ex/App.pod @@ -202,6 +202,9 @@ The nav_loop method will run as follows: foreach step of path { + ->require_auth (hook) + # exits nav_loop if true + ->morph # check ->allow_morph # check ->allow_nested_morph @@ -314,31 +317,31 @@ The default out of the box configuration will map URIs to steps as follows: # Assuming /cgi-bin/my_app is the program being run - URI: /cgi-bin/my_app + URI: /cgi-bin/my_app STEP: main FORM: {} WHY: No other information is passed. The path method is called which eventually calls ->default_step which defaults to "main" - URI: /cgi-bin/my_app?foo=bar + URI: /cgi-bin/my_app?foo=bar STEP: main FORM: {foo => "bar"} WHY: Same as previous example except that QUERY_STRING information was passed and placed in form. - URI: /cgi-bin/my_app?step=my_step + URI: /cgi-bin/my_app?step=my_step STEP: my_step FORM: {step => "my_step"} WHY: The path method is called which looks in $self->form for the key ->step_key (which defaults to "step"). - URI: /cgi-bin/my_app?step=my_step&foo=bar + URI: /cgi-bin/my_app?step=my_step&foo=bar STEP: my_step FORM: {foo => "bar", step => "my_step"} - WHY: Same as before but has other parameters were passed. + WHY: Same as before but another parameter was passed. - URI: /cgi-bin/my_app/my_step + URI: /cgi-bin/my_app/my_step STEP: my_step FORM: {step => "my_step"} WHY: The path method is called which called path_info_map_base @@ -348,12 +351,12 @@ The default out of the box configuration will map URIs to steps as follows: $self->form->{$self->step_key} for the initial step. See the path_info_map_base method for more information. - URI: /cgi-bin/my_app/my_step?foo=bar + URI: /cgi-bin/my_app/my_step?foo=bar STEP: my_step FORM: {foo => "bar", step => "my_step"} WHY: Same as before but other parameters were passed. - URI: /cgi-bin/my_app/my_step?step=other_step + URI: /cgi-bin/my_app/my_step?step=other_step STEP: other_step FORM: {step => "other_step"} WHY: The same procedure took place, but when the PATH_INFO @@ -371,7 +374,7 @@ that the following method is installed in your script. ]; } - URI: /cgi-bin/my_app/my_step/bar + URI: /cgi-bin/my_app/my_step/bar STEP: my_step FORM: {foo => "bar"} WHY: The step was matched as in previous examples using @@ -381,7 +384,7 @@ that the following method is installed in your script. and the corresponding matched value was placed into the form using the keys specified following the regex. - URI: /cgi-bin/my_app/my_step/bar/1234 + URI: /cgi-bin/my_app/my_step/bar/1234 STEP: my_step FORM: {foo => "bar", id => "1234"} WHY: Same as the previous example, except that the first @@ -391,19 +394,19 @@ that the following method is installed in your script. order that will match the most data. The third regex would also match this PATH_INFO. - URI: /cgi-bin/my_app/my_step/some/other/type/of/data + URI: /cgi-bin/my_app/my_step/some/other/type/of/data STEP: my_step FORM: {anything_else => 'some/other/type/of/data'} WHY: Same as the previous example, except that the third regex matched. - URI: /cgi-bin/my_app/my_step/bar?bling=blang + URI: /cgi-bin/my_app/my_step/bar?bling=blang STEP: my_step FORM: {foo => "bar", bling => "blang"} - WHY: Same as the first step, but additional QUERY_STRING + WHY: Same as the first sample, but additional QUERY_STRING information was passed. - URI: /cgi-bin/my_app/my_step/one%20two?bar=three%20four + URI: /cgi-bin/my_app/my_step/one%20two?bar=three%20four STEP: my_step FORM: {anything_else => "one two", bar => "three four"} WHY: The third path_info_map regex matched. Note that the @@ -440,7 +443,7 @@ for more information about the many ways you can validate your data. The default hash_validation hook returns an empty hashref. This means that passed in data is all valid and the script will automatically call the step's finalize method. -The following shows how to some contrived validation to a step called "my_step". +The following shows how to add some contrived validation to a step called "my_step". sub my_step_hash_validation { return { @@ -564,7 +567,9 @@ validation files). The default file_print hook will look for content on your file system, but it can also be completely overridden to return a reference to a -scalar containing the contents of your file. Actually it can return +scalar containing the contents of your file (beginning with version 2.14 +string references can be cached which makes templates passed this way +"first class" citizens). Actually it can return anything that Template::Alloy (Template::Toolkit compatible) will treat as input. This templated html is displayed to the user during any step that enters the "print" phase. @@ -1171,6 +1176,7 @@ called is "view". debug: admin/Recipe.pm line 14 shift->dump_history = [ "Elapsed: 0.00562", + "view - require_auth - require_auth - 0.00001 - 0", "view - run_step - run_step - 0.00488 - 1", " view - pre_step - pre_step - 0.00003 - 0", " view - skip - view_skip - 0.00004 - 0", @@ -1382,8 +1388,7 @@ to the authentication object during the get_valid_auth method. =item get_valid_auth (method) -If require_auth is true at either the application level or at the -step level, get_valid_auth will be called. +If require_auth hook returns true on any given step then get_valid_auth will be called. It will call auth_args to get some default args to pass to CGI::Ex::Auth->new. It augments the args with sensible defaults that @@ -1772,8 +1777,9 @@ This starts the process flow for the path and its steps. =item navigate_authenticated (method) -Same as the method navigate but sets require_auth(1) before -running. See the require_auth method. +Same as the method navigate but calls ->require_auth(1) before +running. It will only work if the navigate_authenticated method +has not been overwritten. See the require_auth method. =item new (class method) @@ -2022,45 +2028,104 @@ had been successfully validated and acted upon. Arguments are the steps used to replace. Can be called any time. Replaces the remaining steps (if any) of the current path. -=item require_auth (method) +=item require_auth (hook) -Default undef. Can return either a true value or a hashref of step names. +Defaults to self->{require_auth} which defaults to undef. +If called as a method and passed a single value of 1, 0, or undef it will +set the value of $self->{require_auth} to that value. If set to a true +value then any subsequent step will require authentication (unless its +hook has been overwritten). -If a hashref of stepnames is returned, authentication will be turned on -at the step level. In this mode if any step is accessed, the get_valid_auth -method will be called. If it fails, then the nav_loop will be stopped -(the post_navigate method will be called - use the is_authed method to perform -different functions). Any step of the path not in the hash will not require -authentication. For example, to add authentication to add authentication -to the add, edit and delete steps you could do: +Any of the following ways can be used to require authentication on +every step. - sub require_auth { {add => 1, edit => 1, delete => 1} } +=over 4 -If a non-hash true value is returned from the require_auth method then -authentication will take place before the pre_navigation or the nav_loop methods. -If authentication fails the navigation process is exited (the post_navigate -method will not be called). +=item sub require_auth { 1 } -Alternatively you can also could do either of the following: +=item __PACKAGE__->navigate_authenticated; # instead of __PACKAGE__->navigate; - # OR +=item + + __PACKAGE__->new({require_auth => 1}->navigate; + +=item sub init { shift->require_auth(1) } - # OR +=back - __PACKAGE__->new({require_auth => 1}->navigate; +Because it is called as a hook, the current step is passed as the +first argument. If the hook returns false, no authentication will be +required on this step. If the hook returns a true, non-hashref value, +authentication will be required via the get_valid_auth method. If the +method returns a hashref of stepnames to require authentication on, +the step will require authentication via the get_valid_auth method if +the current step is in the hashref. If authentication is required and +succeeds, the step will proceed. If authentication is required and +fails at the step level the current step will be aborted, +authentication will be asked for (the post_navigate method will still +be called). + +For example you could add authentication to the add, edit, and delete +steps in any of the following ways: -If get_valid_auth returns true, in either case, the is_authed method will -return true and the auth_data will contain the authenticated user's data. -If it returns false, auth_data may possibly contain a defined but false -data object with details as to why authentication failed. +=over 4 -See the get_valid_auth method. +=item + + sub require_auth { {add => 1, edit => 1, delete => 1} } + +=item + + sub add_require_auth { 1 } + sub edit_require_auth { 1 } + sub delete_require_auth { 1 } + +=item + + sub require_auth { + my ($self, $step) = @_; + return 1 if $step && $step =~ /^(add|edit|delete)$/; + return 0; + } + +=back + +If however you wanted to require authentication on all but one or two methods +(such as requiring authentication on all but a forgot_password step) you could do +either of the following: + +=over 4 + +=item + + sub require_auth { + my ($self, $step) = @_; + return 0 if $step && $step eq 'forgot_password'; + return 1; # require auth on all other steps + } + +=item + + sub require_auth { 1 } # turn it on for all steps + + sub forgot_password_require_auth { 0 } # turn it off + +=back + +See the get_valid_auth method for what occurs should authentication be required. + +There is one key difference from the 2.14 version of App. In 2.14 and +previous versions, the pre_navigate and post_navigate methods would +not be called if require_auth returned a true non-hashref value. In +version 2.15 and later, the 2.15 pre_navigate and post_navigate +methods are always called - even if authentication fails. Also in 2.15 +and later, the method is called as a hook meaning the step is passed in. =item run_hook (method) @@ -2601,7 +2666,7 @@ the core logic of the application. return 0; } - my $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?"; + $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?"; $self->dbh->do($s, {}, $form->{'title'}, $form->{'ingredients'}, $form->{'directions'}, @@ -2983,6 +3048,18 @@ will cause all steps to require validation): sub require_auth { {add => 1, edit => 1, delete => 1} } +We could also enable authentication by using individual hooks as in: + + sub add_require_auth { 1 } + sub edit_require_auth { 1 } + sub delete_require_auth { 1 } + +Or we could require authentication on everything - but let a few steps in: + + sub require_auth { 1 } # turn authentication on for all + sub main_require_auth { 0 } # turn it off for main and view + sub view_require_auth { 0 } + That's it. The add, edit, and delete steps will now require authentication. See the require_auth, get_valid_auth, and auth_args methods for more information. Also see the L perldoc. @@ -2992,13 +3069,15 @@ Also see the L perldoc. The following corporation and individuals contributed in some part to the original versions. - Bizhosting.com - giving a problem that fit basic design patterns. + Bizhosting.com - giving a problem that fit basic design patterns. + + Earl Cahill - pushing the idea of more generic frameworks. - Earl Cahill - pushing the idea of more generic frameworks. + Adam Erickson - design feedback, bugfixing, feature suggestions. - Adam Erickson - design feedback, bugfixing, feature suggestions. + James Lance - design feedback, bugfixing, feature suggestions. - James Lance - design feedback, bugfixing, feature suggestions. + Krassimir Berov - feedback and some warnings issues with POD examples. =head1 AUTHOR diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index d7056e2..99ca4a6 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -18,7 +18,7 @@ use MIME::Base64 qw(encode_base64 decode_base64); use Digest::MD5 qw(md5_hex); use CGI::Ex; -$VERSION = '2.14'; +$VERSION = '2.15'; ###----------------------------------------------------------------### diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index fcd00a4..118f4a8 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -29,7 +29,7 @@ use vars qw($VERSION ); @EXPORT_OK = qw(conf_read conf_write in_cache); -$VERSION = '2.14'; +$VERSION = '2.15'; $DEFAULT_EXT = 'conf'; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index 345468a..287bed6 100644 --- a/lib/CGI/Ex/Die.pm +++ b/lib/CGI/Ex/Die.pm @@ -23,7 +23,7 @@ use CGI::Ex; use CGI::Ex::Dump qw(debug ctrace dex_html); BEGIN { - $VERSION = '2.14'; + $VERSION = '2.15'; $SHOW_TRACE = 0 if ! defined $SHOW_TRACE; $IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL; $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS; diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index 1a9070c..41bece5 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION use strict; use Exporter; -$VERSION = '2.14'; +$VERSION = '2.15'; @ISA = qw(Exporter); @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace); @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug); diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index b15b773..c3e079a 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.14'; + $VERSION = '2.15'; @EXPORT = qw(form_fill); @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); }; diff --git a/lib/CGI/Ex/JSONDump.pm b/lib/CGI/Ex/JSONDump.pm index c07a138..2d90a99 100644 --- a/lib/CGI/Ex/JSONDump.pm +++ b/lib/CGI/Ex/JSONDump.pm @@ -17,7 +17,7 @@ use strict; use base qw(Exporter); BEGIN { - $VERSION = '2.14'; + $VERSION = '2.15'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 2f6fbfa..0e00f76 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -8,7 +8,7 @@ CGI::Ex::Template - Template::Alloy based TT2/TT3/HT/HTE/Tmpl/Velocity engine. use strict; use warnings; -use Template::Alloy 1.002; +use Template::Alloy 1.003; use base qw(Template::Alloy); use vars qw($VERSION $QR_PRIVATE @@ -25,7 +25,7 @@ use vars qw($VERSION $VOBJS ); -$VERSION = '2.14'; +$VERSION = '2.15'; ### install true symbol table aliases that can be localized *QR_PRIVATE = *Template::Alloy::QR_PRIVATE; diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm index f97d425..b49193c 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -22,7 +22,7 @@ use vars qw($VERSION @UNSUPPORTED_BROWSERS ); -$VERSION = '2.14'; +$VERSION = '2.15'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; diff --git a/samples/benchmark/bench_conf_readers.pl b/samples/benchmark/bench_conf_readers.pl index 20f1b45..845c807 100644 --- a/samples/benchmark/bench_conf_readers.pl +++ b/samples/benchmark/bench_conf_readers.pl @@ -2,7 +2,7 @@ use strict; use vars qw($PLACEHOLDER); -use Benchmark qw(cmpthese); +use Benchmark qw(cmpthese timethese); use CGI::Ex::Conf; use POSIX qw(tmpnam); @@ -42,6 +42,152 @@ my $str = '{ one8 => {key1 => "val8", key2 => "ralph"}, }'; +my $str = '[ + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], + foo => [key1 => "bar", key2 => "ralph"], + pass => [key1 => "word", key2 => "ralph"], + garbage => [key1 => "can", key2 => "ralph"], + mighty => [key1 => "ducks", key2 => "ralph"], + quack => [key1 => "moo", key2 => "ralph"], + one1 => [key1 => "val1", key2 => "ralph"], + one2 => [key1 => "val2", key2 => "ralph"], + one3 => [key1 => "val3", key2 => "ralph"], + one4 => [key1 => "val4", key2 => "ralph"], + one5 => [key1 => "val5", key2 => "ralph"], + one6 => [key1 => "val6", key2 => "ralph"], + one7 => [key1 => "val7", key2 => "ralph"], + one8 => [key1 => "val8", key2 => "ralph"], +]'; + ###----------------------------------------------------------------### # Rate yaml yaml2 xml g_conf pl sto sto2 yaml3 @@ -87,13 +233,13 @@ $TESTS{pl} = sub { $files{pl} = $file; ### do a generic conf_write -my $file2 = tmpnam(). '.g_conf'; -&generic_conf_write($file2, $conf); -local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read; -$TESTS{g_conf} = sub { - my $hash = $cob->read_ref($file2); -}; -$files{g_conf} = $file2; +#my $file2 = tmpnam(). '.g_conf'; +#&generic_conf_write($file2, $conf); +#local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read; +#$TESTS{g_conf} = sub { +# my $hash = $cob->read_ref($file2); +#}; +#$files{g_conf} = $file2; if (eval {require JSON}) { @@ -187,7 +333,7 @@ foreach my $key (sort keys %files) { print "$key => $files{$key}\n"; } -cmpthese($n, \%TESTS); +cmpthese timethese ($n, \%TESTS); ### comment out this line to inspect files unlink $_ foreach values %files; diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t index 1520d7a..ec223d8 100644 --- a/t/4_app_00_base.t +++ b/t/4_app_00_base.t @@ -8,57 +8,61 @@ These tests are extremely stripped down to test the basic path flow. Normally unit tests are useful for garnering information about a module. For CGI::Ex::App -it is suggested to stick to live use cases or the CGI::Ex::App perldoc. +it is suggested to stick to live use cases or the CGI::Ex::App perldoc - though +we do try to put it through most paces. =cut -use Test::More tests => 9; +use Test::More tests => 20; use strict; { - package Foo; + package Foo; - use base qw(CGI::Ex::App); - use vars qw($test_stdout); + use base qw(CGI::Ex::App); + use vars qw($test_stdout); - sub ready_validate { 1 } + sub init { $test_stdout = '' } - sub print_out { - my $self = shift; - my $step = shift; - $test_stdout = shift; - } + sub ready_validate { 1 } - sub swap_template { - my ($self, $step, $file, $swap) = @_; - my $out = ref($file) ? $$file : "No filenames allowed during test mode"; - $self->cgix->swap_template(\$out, $swap); - return $out; - } + sub print_out { + my $self = shift; + my $step = shift; + my $str = shift; + $test_stdout = ref($str) ? $$str : $str; + } - ###----------------------------------------------------------------### + sub swap_template { + my ($self, $step, $file, $swap) = @_; + my $out = ref($file) ? $$file : "No filenames allowed during test mode"; + $self->cgix->swap_template(\$out, $swap); + return $out; + } - sub main_info_complete { 0 } + sub auth_args { {login_template => \q{Login Form}} } - sub main_file_print { return \ "Main Content" } + ###----------------------------------------------------------------### - sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} } + sub main_info_complete { 0 } - sub step2_path_info_map { [[qr{^/step2/(\w+)$}, 'wow']] } + sub main_file_print { return \ "Main Content" } - sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) [% wow_error %]" } + sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} } - sub step2_hash_swap { return {foo => 'bar', one => 'two'} } + sub step2_path_info_map { [[qr{^/step2/(\w+)$}x, 'wow']] } - sub step2_hash_fill { return {wow => 'wee'} } + sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) [% wow_error %]" } - sub step2_finalize { shift->append_path('step3') } + sub step2_hash_swap { return {foo => 'bar', one => 'two'} } - sub step3_info_complete { 0 } + sub step2_hash_fill { return {wow => 'wee'} } - sub step3_file_print { return \ "All good" } + sub step2_finalize { shift->append_path('step3') } + sub step3_info_complete { 0 } + sub step3_file_print { return \ "All good" } } ###----------------------------------------------------------------### @@ -67,7 +71,7 @@ use strict; #$ENV{'QUERY_STRING'} = ''; Foo->new({ - form => {}, + form => {}, })->navigate; ok($Foo::test_stdout eq "Main Content", "Got the right output"); @@ -77,7 +81,7 @@ ok($Foo::test_stdout eq "Main Content", "Got the right output"); #$ENV{'QUERY_STRING'} = 'step=step2'; Foo->new({ - form => {step => 'step2'}, + form => {step => 'step2'}, })->navigate; ok($Foo::test_stdout eq "Some step2 content (bar, two) wow is required", "Got the right output"); @@ -87,7 +91,7 @@ ok($Foo::test_stdout eq "Some step2 content (bar, two) new({ - form=> {step => 'step2', wow => 'something'}, + form=> {step => 'step2', wow => 'something'}, })->navigate; ok($Foo::test_stdout eq "All good", "Got the right output"); @@ -98,7 +102,7 @@ ok($Foo::test_stdout eq "All good", "Got the right output"); local $ENV{'PATH_INFO'} = '/step2'; Foo->new({ - form=> {}, + form=> {}, })->navigate; ok($Foo::test_stdout eq "Some step2 content (bar, two) wow is required", "Got the right output"); @@ -109,7 +113,7 @@ ok($Foo::test_stdout eq "Some step2 content (bar, two) new({ - form=> {wow => 'something'}, + form=> {wow => 'something'}, })->navigate; ok($Foo::test_stdout eq "All good", "Got the right output"); ok($f->form->{'step'} eq 'step2', "Got the right variable set in form"); @@ -121,10 +125,134 @@ ok($f->form->{'step'} eq 'step2', "Got the right variable set in form"); local $ENV{'PATH_INFO'} = '/step2/something'; $f = Foo->new({ - form => {}, + form => {}, })->navigate; ok($Foo::test_stdout eq "All good", "Got the right output"); ok($f->form->{'step'} eq 'step2', "Got the right variable set in form"); ok($f->form->{'wow'} eq 'something', "Got the right variable set in form"); ###----------------------------------------------------------------### + +local $ENV{'PATH_INFO'} = ''; +local $ENV{'SCRIPT_NAME'} = ''; + +Foo->new({ + form => {}, + require_auth => 1, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output"); + +###----------------------------------------------------------------### + +Foo->new({ + form => {}, +})->navigate_authenticated; +ok($Foo::test_stdout eq "Login Form", "Got the right output"); + +###----------------------------------------------------------------### + +{ + package Bar; + @Bar::ISA = qw(Foo); + sub require_auth { 1 } +} + +Bar->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar"); + +###----------------------------------------------------------------### + +{ + package Bar1; + @Bar1::ISA = qw(Foo); + sub require_auth { 1 } +} + +my $ok = eval { Bar1->new({ + form => {}, +})->navigate_authenticated; 1 }; # can't call navigate_authenticated with overwritten require_auth +ok(! $ok, "Got the right output for Bar1"); + +###----------------------------------------------------------------### + +{ + package Bar2; + @Bar2::ISA = qw(Foo); + sub main_require_auth { 1 } +} + +Bar2->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar2"); + +###----------------------------------------------------------------### + +{ + package Bar3; + @Bar3::ISA = qw(Foo); + sub require_auth { 1 } + sub main_require_auth { 0 } +} + +Bar3->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar3"); + +###----------------------------------------------------------------### + +Foo->new({ + form => {}, + require_auth => {main => 0}, +})->navigate; +ok($Foo::test_stdout eq "Main Content", "Got the right output"); + +###----------------------------------------------------------------### + +Foo->new({ + form => {}, + require_auth => {main => 1}, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output"); + +###----------------------------------------------------------------### + +{ + package Bar4; + @Bar4::ISA = qw(Foo); + sub pre_navigate { shift->require_auth(0); 0 } +} + +Bar4->new({ + form => {}, +})->navigate_authenticated; +ok($Foo::test_stdout eq "Main Content", "Got the right output for Bar4"); + +###----------------------------------------------------------------### + +{ + package Bar5; + @Bar5::ISA = qw(Foo); + sub pre_navigate { shift->require_auth(1); 0 } +} + +Bar5->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar5 ($@)"); + +###----------------------------------------------------------------### + +{ + package Bar6; + @Bar6::ISA = qw(Foo); + sub pre_navigate { shift->require_auth({main => 1}); 0 } +} + +Bar6->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar6 ($@)"); -- 2.43.0