From 18123183bfb2737ea337306c9d705fca5b5e50d6 Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Tue, 24 Jul 2007 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.18 --- Changes | 13 + META.yml | 2 +- lib/CGI/Ex.pm | 2 +- lib/CGI/Ex/App.pm | 1454 ++++++++++++++++------------------------ lib/CGI/Ex/App.pod | 39 +- lib/CGI/Ex/Auth.pm | 7 +- 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 | 2 +- lib/CGI/Ex/Validate.pm | 3 +- t/1_validate_00_base.t | 13 +- t/4_app_00_base.t | 737 +++++++++++++++++++- 15 files changed, 1373 insertions(+), 909 deletions(-) diff --git a/Changes b/Changes index f13b758..c5d4506 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,16 @@ +2.18 + 2007-07-24 + * Merry Pioneer Day - http://en.wikipedia.org/wiki/Pioneer_Day_(Utah) + * Allow for check_valid_auth in App + * Allow for set_cookie, delete_cookie, location_bounce to be overridden in Auth + * Add get_valid_auth to the history + * Massive refactor of CGI::Ex::App + * Rename conf_ext to ext_conf to be similar to ext_print and ext_val + * Add undocumented conf_die_on_fail (which defaults to true) + * Fix bug in handle_error + * Allow empty hashrefs passed to Validate - (broken in 2.17) + * Add tests to help with Devel::Cover coverage. + 2.17 2007-06-26 * Add load_conf and conf* methods to App to allow for easier external configuration diff --git a/META.yml b/META.yml index 53b67de..e53e35e 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # 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.17 +version: 2.18 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index 4b3b8a8..fa848bc 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.17'; + $VERSION = '2.18'; $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 c44d716..f85becd 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -2,48 +2,30 @@ package CGI::Ex::App; ###----------------------------------------------------------------### # See the perldoc in CGI/Ex/App.pod -# Copyright 2007 - Paul Seamons # -# Distributed under the Perl Artistic License without warranty # +# Copyright 2007 - Paul Seamons +# Distributed under the Perl Artistic License without warranty ###----------------------------------------------------------------### use strict; -use vars qw($VERSION); - +use Carp qw(croak); BEGIN { - $VERSION = '2.17'; - - Time::HiRes->import('time') if eval {require Time::HiRes}; - eval {require Scalar::Util}; -} - -sub croak { - my $msg = shift; - $msg = 'Something happened' if ! defined $msg; - die $msg if ref $msg || $msg =~ /\n\z/; - my ($pkg, $file, $line, $sub) = caller(1); - die "$msg in ${sub}() at $file line $line\n"; + eval { use Time::HiRes qw(time) }; + eval { use Scalar::Util }; } -###----------------------------------------------------------------### +our $VERSION = '2.18'; sub new { - my $class = shift || croak "Usage: Package->new"; - my $self = shift || {}; + my $class = shift || croak "Usage: ".__PACKAGE__."->new"; + my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_}; bless $self, $class; $self->init; - $self->init_from_conf; return $self; } -sub init {} - -sub destroy {} - -###----------------------------------------------------------------### - sub init_from_conf { my $self = shift; return if ! $self->load_conf; @@ -52,85 +34,25 @@ sub init_from_conf { return; } -sub load_conf { shift->{'load_conf'} ||= @_ ? 1 : 0 } - -sub conf { - my $self = shift; - return $self->{'conf'} ||= do { - my $conf = $self->conf_obj->read($self->conf_file, {no_warn_on_fail => 1}) || croak $@; - my $hash = $self->conf_validation; - if ($hash && scalar keys %$hash) { - my $err_obj = $self->vob->validate($conf, $hash); - die $err_obj if $err_obj; - } - $conf; - } -} - -sub conf_path { - my $self = shift; - return $self->{'conf_path'} || $self->base_dir_abs; -} - -sub conf_file { - my $self = shift; - return $self->{'conf_file'} ||= do { - my $module = $self->name_module || croak 'Missing name_module during conf_file call'; - $module .'.'. $self->conf_ext; - }; -} - -sub conf_ext { - my $self = shift; - $self->{'conf_ext'} = shift if @_ == 1; - return $self->{'conf_ext'} || 'pl'; -} - -sub conf_args { shift->{'conf_args'} || {} } - -sub conf_obj { - my $self = shift; - return $self->{'conf_obj'} || do { - my $args = $self->conf_args; - $args->{'paths'} ||= $self->conf_path; - $args->{'directive'} ||= 'MERGE'; - require CGI::Ex::Conf; - CGI::Ex::Conf->new($args); - }; -} - -sub conf_validation {} - -###----------------------------------------------------------------### +###---------------------### sub navigate { my ($self, $args) = @_; $self = $self->new($args) if ! ref $self; $self->{'_time'} = time; - eval { - ### a chance to do things at the very beginning return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate; - ### run the step loop eval { local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []}; $self->nav_loop; }; - if ($@) { - ### rethrow the error unless we long jumped out of recursive nav_loop calls - croak $@ if $@ ne "Long Jump\n"; - } + croak $@ if $@ && $@ ne "Long Jump\n"; - ### one chance to do things at the very end $self->post_navigate if ! $self->{'_no_post_navigate'}; - - }; - $self->handle_error($@) if $@; # catch any errors - - $self->{'_time'} = time; + $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors $self->destroy; @@ -169,7 +91,7 @@ sub nav_loop { 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; + return if ! $self->run_hook('get_valid_auth', $step); } } @@ -179,9 +101,9 @@ sub nav_loop { ### allow for mapping path_info pieces to form elements 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')); + croak 'Usage: sub path_info_map { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY'); foreach my $map (@$maps) { + croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY'); my @match = $info =~ $map->[0]; next if ! @match; $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map; @@ -216,41 +138,6 @@ sub nav_loop { return; } -sub pre_navigate { 0 } # true means to not enter nav_loop - -sub post_navigate {} - -sub pre_loop { 0 } # true value means to abort the nav_loop routine - -sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse - -sub recurse_limit { shift->{'recurse_limit'} || 15 } - -### default die handler - show what happened and die (so its in the error logs) -sub handle_error { - my $self = shift; - my $err = shift; - - die $err if $self->{'_handling_error'}; - local $self->{'_handling_error'} = 1; - local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error - - $self->stash->{'error_step'} = $self->current_step; - $self->stash->{'error'} = $err; - $self->replace_path($self->error_step); - $self->jump; # exits nav loop when finished -} - -###----------------------------------------------------------------### - -sub default_step { shift->{'default_step'} || 'main' } -sub js_step { shift->{'js_step'} || 'js' } -sub login_step { shift->{'login_step'} || '__login' } -sub error_step { shift->{'error_step'} || '__error' } -sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' } - -sub step_key { shift->{'step_key'} || 'step' } - sub path { my $self = shift; if (! $self->{'path'}) { @@ -259,9 +146,9 @@ sub path { ### 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')); + croak 'Usage: sub path_info_map_base { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY'); foreach my $map (@$maps) { + croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY'); my @match = $info =~ $map->[0]; next if ! @match; $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map; @@ -290,56 +177,311 @@ sub path { return $self->{'path'}; } -sub path_info_map_base { +sub run_hook { my $self = shift; - return [[qr{/(\w+)}, $self->step_key]]; + my $hook = shift; + my $step = shift; + my ($code, $found) = @{ $self->find_hook($hook, $step) }; + croak "Could not find a method named ${step}_${hook} or ${hook}" if ! $code; + croak "Value for $hook ($found) is not a code ref ($code)" if ! UNIVERSAL::isa($code, 'CODE'); + + my $hist; + if (! $self->{'no_history'}) { + $hist = { + step => $step, + meth => $hook, + found => $found, + time => time, + }; + push @{ $self->history }, $hist; + $hist->{'level'} = $self->{'_level'}; + $hist->{'elapsed'} = time - $hist->{'time'}; + } + local $self->{'_level'} = 1 + ($self->{'_level'} || 0); + + my $resp = $self->$code($step, @_); + + if (! $self->{'no_history'}) { + $hist->{'elapsed'} = time - $hist->{'time'}; + $hist->{'response'} = $resp; + } + + return $resp; } -sub set_path { +sub run_step { my $self = shift; - my $path = $self->{'path'} ||= []; - croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'}; - splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref) + my $step = shift; + + ### if the pre_step exists and returns true, exit the nav_loop + return 1 if $self->run_hook('pre_step', $step); + + ### allow for skipping this step (but stay in the nav_loop) + return 0 if $self->run_hook('skip', $step); + + ### see if we have complete valid information for this step + ### if so, do the next step + ### if not, get necessary info and print it out + if ( ! $self->run_hook('prepare', $step) + || ! $self->run_hook('info_complete', $step) + || ! $self->run_hook('finalize', $step)) { + + ### show the page requesting the information + $self->run_hook('prepared_print', $step); + + ### a hook after the printing process + $self->run_hook('post_print', $step); + + return 1; + } + + ### a hook before end of loop + ### if the post_step exists and returns true, exit the nav_loop + return 1 if $self->run_hook('post_step', $step); + + ### let the nav_loop continue searching the path + return 0; +} + +sub prepared_print { + my $self = shift; + my $step = shift; + + my $hash_base = $self->run_hook('hash_base', $step) || {}; + my $hash_comm = $self->run_hook('hash_common', $step) || {}; + my $hash_form = $self->run_hook('hash_form', $step) || {}; + my $hash_fill = $self->run_hook('hash_fill', $step) || {}; + my $hash_swap = $self->run_hook('hash_swap', $step) || {}; + my $hash_errs = $self->run_hook('hash_errors', $step) || {}; + + $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs; + $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs; + + my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill}; + my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs}; + + $self->run_hook('print', $step, $swap, $fill); +} + +sub print { + my ($self, $step, $swap, $fill) = @_; + my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path + 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); } -### legacy - same as append_path -sub add_to_path { +sub handle_error { + my ($self, $err) = @_; + + die $err if $self->{'_handling_error'}; + local $self->{'_handling_error'} = 1; + local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error + + $self->stash->{'error_step'} = $self->current_step; + $self->stash->{'error'} = $err; + $self->replace_path($self->error_step); + + eval { $self->jump }; + die $@ if $@ && $@ ne "Long Jump\n"; +} + +###---------------------### +# read only accessors + +sub allow_morph { $_[0]->{'allow_morph'} } +sub allow_nested_morph { $_[0]->{'allow_nested_morph'} } +sub auth_args { $_[0]->{'auth_args'} } +sub charset { $_[0]->{'charset'} || '' } +sub conf_args { $_[0]->{'conf_args'} } +sub conf_die_on_fail { $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} } +sub conf_path { $_[0]->{'conf_path'} || $_[0]->base_dir_abs } +sub conf_validation { $_[0]->{'conf_validation'} } +sub default_step { $_[0]->{'default_step'} || 'main' } +sub error_step { $_[0]->{'error_step'} || '__error' } +sub fill_args { $_[0]->{'fill_args'} } +sub forbidden_step { $_[0]->{'forbidden_step'} || '__forbidden' } +sub form_name { $_[0]->{'form_name'} || 'theform' } +sub history { $_[0]->{'history'} ||= [] } +sub js_step { $_[0]->{'js_step'} || 'js' } +sub login_step { $_[0]->{'login_step'} || '__login' } +sub mimetype { $_[0]->{'mimetype'} || 'text/html' } +sub path_info { $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' } +sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] } +sub recurse_limit { $_[0]->{'recurse_limit'} || 15 } +sub script_name { $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 } +sub stash { $_[0]->{'stash'} ||= {} } +sub step_key { $_[0]->{'step_key'} || 'step' } +sub template_args { $_[0]->{'template_args'} } +sub template_path { $_[0]->{'template_path'} || $_[0]->base_dir_abs } +sub val_args { $_[0]->{'val_args'} } +sub val_path { $_[0]->{'val_path'} || $_[0]->template_path } + +sub conf_obj { my $self = shift; - push @{ $self->path }, @_; + return $self->{'conf_obj'} || do { + my $args = $self->conf_args || {}; + $args->{'paths'} ||= $self->conf_path; + $args->{'directive'} ||= 'MERGE'; + require CGI::Ex::Conf; + CGI::Ex::Conf->new($args); + }; +} + +sub template_obj { + my ($self, $args) = @_; + return $self->{'template_obj'} || do { + require Template::Alloy; + my $t = Template::Alloy->new($args); + }; } -sub append_path { +sub val_obj { my $self = shift; - push @{ $self->path }, @_; + return $self->{'val_obj'} || do { + my $args = $self->val_args || {}; + $args->{'cgix'} ||= $self->cgix; + require CGI::Ex::Validate; + CGI::Ex::Validate->new($args); + }; } -sub replace_path { +###---------------------### +# read/write accessors + +sub auth_data { (@_ == 2) ? $_[0]->{'auth_data'} = pop : $_[0]->{'auth_data'} } +sub base_dir_abs { (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.'] } +sub base_dir_rel { (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || '' } +sub cgix { (@_ == 2) ? $_[0]->{'cgix'} = pop : $_[0]->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } } +sub cookies { (@_ == 2) ? $_[0]->{'cookies'} = pop : $_[0]->{'cookies'} ||= $_[0]->cgix->get_cookies } +sub ext_conf { (@_ == 2) ? $_[0]->{'ext_conf'} = pop : $_[0]->{'ext_conf'} || 'pl' } +sub ext_print { (@_ == 2) ? $_[0]->{'ext_print'} = pop : $_[0]->{'ext_print'} || 'html' } +sub ext_val { (@_ == 2) ? $_[0]->{'ext_val'} = pop : $_[0]->{'ext_val'} || 'val' } +sub form { (@_ == 2) ? $_[0]->{'form'} = pop : $_[0]->{'form'} ||= $_[0]->cgix->get_form } +sub load_conf { (@_ == 2) ? $_[0]->{'load_conf'} = pop : $_[0]->{'load_conf'} } + +sub conf { my $self = shift; - my $ref = $self->path; - my $i = $self->{'path_i'} || 0; - if ($i + 1 > $#$ref) { - push @$ref, @_; - } else { - splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries + $self->{'conf'} = pop if @_ == 1; + return $self->{'conf'} ||= do { + my $conf = $self->conf_file; + $conf = ($self->conf_obj->read($conf, {no_warn_on_fail => 1}) || $self->conf_die_on_fail ? croak $@ : {}) if ! $conf; + my $hash = $self->conf_validation; + if ($hash && scalar keys %$hash) { + my $err_obj = $self->val_obj->validate($conf, $hash); + die $err_obj if $err_obj; + } + $conf; } } -sub insert_path { +sub conf_file { my $self = shift; - my $ref = $self->path; - my $i = $self->{'path_i'} || 0; - if ($i + 1 > $#$ref) { - push @$ref, @_; - } else { - splice(@$ref, $i + 1, 0, @_); # insert a path at the current location + $self->{'conf_file'} = pop if @_ == 1; + return $self->{'conf_file'} ||= do { + my $module = $self->name_module || croak 'Missing name_module during conf_file call'; + $module .'.'. $self->ext_conf; + }; +} + +###---------------------### +# general methods + +sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) } +sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) } +sub add_to_errors { shift->add_errors(@_) } +sub add_to_fill { my $self = shift; $self->add_to_hash($self->hash_fill, @_) } +sub add_to_form { my $self = shift; $self->add_to_hash($self->hash_form, @_) } +sub add_to_path { shift->append_path(@_) } # legacy +sub add_to_swap { my $self = shift; $self->add_to_hash($self->hash_swap, @_) } +sub cleanup_user { my ($self, $user) = @_; $user } +sub current_step { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) } +sub destroy {} +sub first_step { $_[0]->step_by_path_index(0) } +sub fixup_after_morph {} +sub fixup_before_unmorph {} +sub format_error { my ($self, $error) = @_; $error } +sub get_pass_by_user { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" } +sub has_errors { scalar keys %{ $_[0]->hash_errors } } +sub init {} +sub last_step { $_[0]->step_by_path_index($#{ $_[0]->path }) } +sub path_info_map {} +sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse +sub post_navigate {} +sub pre_loop { 0 } # true value means to abort the nav_loop routine +sub pre_navigate { 0 } # true means to not enter nav_loop +sub previous_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) } +sub valid_steps {} +sub verify_user { 1 } + +sub add_errors { + my $self = shift; + my $hash = $self->hash_errors; + my $args = ref($_[0]) ? shift : {@_}; + foreach my $key (keys %$args) { + my $_key = ($key =~ /error$/) ? $key : "${key}_error"; + if ($hash->{$_key}) { + $hash->{$_key} .= '
' . $args->{$key}; + } else { + $hash->{$_key} = $args->{$key}; + } } + $hash->{'has_errors'} = 1; +} + +sub add_to_hash { + my $self = shift; + my $old = shift; + my $new = shift; + $new = {$new, @_} if ! ref $new; # non-hashref + $old->{$_} = $new->{$_} foreach keys %$new; } -### a hash of paths that are allowed, default undef is all are allowed -sub valid_steps {} +sub append_path { my $self = shift; push @{ $self->path }, @_ } -###----------------------------------------------------------------### -### allow for checking where we are in the path and for jumping around +sub clear_app { + my $self = shift; + delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history + _morph_lineage _morph_lineage_start_index path path_i stash val_obj)}; + return $self; +} + +sub dump_history { + my ($self, $all) = @_; + + my $hist = $self->history; + my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}]; + + foreach my $row (@$hist) { + if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) { + push @$dump, $row; + next; + } + my $note = (' ' x ($row->{'level'} || 0)) + . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'})); + my $resp = $row->{'response'}; + if (ref($resp) eq 'HASH' && ! scalar keys %$resp) { + $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) { + $resp = substr($resp, 0, $max); + $resp =~ s/\n.+//s; + $resp = "$resp ..."; + } + $note .= " - $resp"; + } else { + $note = [$note, $resp]; + } + push @$dump, $note; + } + + return $dump; +} sub exit_nav_loop { my $self = shift; @@ -352,10 +494,32 @@ sub exit_nav_loop { $self->unmorph while $#$ref != $index; } - ### long jump back die "Long Jump\n"; } +sub find_hook { + my ($self, $hook, $step) = @_; + croak "Missing hook name" if ! $hook; + if ($step && (my $code = $self->can("${step}_${hook}"))) { + return [$code, "${step}_${hook}"], + } elsif ($code = $self->can($hook)) { + return [$code, $hook]; + } else { + return []; + } +} + +sub insert_path { + my $self = shift; + my $ref = $self->path; + my $i = $self->{'path_i'} || 0; + if ($i + 1 > $#$ref) { + push @$ref, @_; + } else { + splice(@$ref, $i + 1, 0, @_); # insert a path at the current location + } +} + sub jump { my $self = shift; my $i = @_ == 1 ? shift : 1; @@ -363,19 +527,13 @@ sub jump { my $path_i = $self->{'path_i'}; croak "Can't jump if nav_loop not started" if ! defined $path_i; - ### validate where we are jumping to if ($i =~ /^\w+$/) { - if ($i eq 'FIRST') { - $i = - $path_i - 1; - } elsif ($i eq 'LAST') { - $i = $#$path - $path_i; - } elsif ($i eq 'NEXT') { - $i = 1; - } elsif ($i eq 'CURRENT') { - $i = 0; - } elsif ($i eq 'PREVIOUS') { - $i = -1; - } else { # look for a step by that name + if ( $i eq 'FIRST' ) { $i = - $path_i - 1 } + elsif ($i eq 'LAST' ) { $i = $#$path - $path_i } + elsif ($i eq 'NEXT' ) { $i = 1 } + elsif ($i eq 'CURRENT' ) { $i = 0 } + elsif ($i eq 'PREVIOUS') { $i = -1 } + else { # look for a step by that name for (my $j = $#$path; $j >= 0; $j --) { if ($path->[$j] eq $i) { $i = $j - $path_i; @@ -384,200 +542,42 @@ sub jump { } } } - if ($i !~ /^-?\d+$/) { - require Carp; - Carp::croak("Invalid jump index ($i)"); - } + croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/; ### manipulate the path to contain the new jump location - my @replace; - my $cut_i = $path_i + $i; - if ($cut_i > $#$path) { - push @replace, $self->default_step; - } elsif ($cut_i < 0) { - push @replace, @$path; - } else { - push @replace, @$path[$cut_i .. $#$path]; - } + my $cut_i = $path_i + $i; + my @replace = ($cut_i > $#$path) ? $self->default_step + : ($cut_i < 0) ? @$path + : @$path[$cut_i .. $#$path]; $self->replace_path(@replace); - ### record the number of jumps - $self->{'jumps'} ||= 0; - $self->{'jumps'} ++; + $self->{'jumps'} = ($self->{'jumps'} || 0) + 1; - ### run the newly fixed up path (recursively) - $self->{'path_i'} ++; # move along now that the path is updated - $self->nav_loop; + $self->{'path_i'}++; # move along now that the path is updated + $self->nav_loop; # recurse on the path $self->exit_nav_loop; } -sub step_by_path_index { - my $self = shift; - my $i = shift || 0; - my $ref = $self->path; - return '' if $i < 0; - return $self->default_step if $i > $#$ref; - return $ref->[$i]; -} - -sub previous_step { - my $self = shift; - return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 ); -} - -sub current_step { - my $self = shift; - return $self->step_by_path_index( ($self->{'path_i'} || 0) ); -} - -sub next_step { # method and hook - my $self = shift; - return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 ); -} - -sub last_step { - my $self = shift; - return $self->step_by_path_index( $#{ $self->path } ); -} - -sub first_step { - my $self = shift; - return $self->step_by_path_index( 0 ); -} - -###----------------------------------------------------------------### -### hooks and history - -sub find_hook { - my $self = shift; - my $hook = shift || do { require Carp; Carp::confess("Missing hook name") }; - my $step = shift || ''; - my $code; - if ($step && ($code = $self->can("${step}_${hook}"))) { - return [$code, "${step}_${hook}"], - - } elsif ($code = $self->can($hook)) { - return [$code, $hook]; - - } else { - return []; - - } -} - -sub run_hook { - my $self = shift; - my $hook = shift; - my $step = shift; - - my ($code, $found) = @{ $self->find_hook($hook, $step) }; - if (! $code) { - croak "Could not find a method named ${step}_${hook} or ${hook}"; - } elsif (! UNIVERSAL::isa($code, 'CODE')) { - croak "Value for $hook ($found) is not a code ref ($code)"; - } - - ### record history - my $hist = { - step => $step, - meth => $hook, - found => $found, - time => time, - }; - - push @{ $self->history }, $hist; - - $hist->{'level'} = $self->{'_level'}; - local $self->{'_level'} = 1 + ($self->{'_level'} || 0); - - $hist->{'elapsed'} = time - $hist->{'time'}; - - my $resp = $self->$code($step, @_); - - $hist->{'elapsed'} = time - $hist->{'time'}; - $hist->{'response'} = $resp; - - return $resp; -} - -sub history { - return shift->{'history'} ||= []; -} - -sub dump_history { - my $self = shift; - my $all = shift || 0; - my $hist = $self->history; - my $dump = []; - push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'}); - - ### show terse - yet informative info - foreach my $row (@$hist) { - if (! ref($row) - || ref($row) ne 'HASH' - || ! exists $row->{'elapsed'}) { - push @$dump, $row; - } else { - my $note = (' ' x ($row->{'level'} || 0)) - . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'})); - my $resp = $row->{'response'}; - if (ref($resp) eq 'HASH' && ! scalar keys %$resp) { - $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) { - $resp = substr($resp, 0, $max); - $resp =~ s/\n.+//s; - $resp = "$resp ..."; - } - $note .= " - $resp"; - } else { - $note = [$note, $resp]; - } - - push @$dump, $note; - } - } - - return $dump; -} - -###----------------------------------------------------------------### -### utility methods to allow for storing separate steps in other modules - -sub allow_morph { - my $self = shift; - return $self->{'allow_morph'} ? 1 : 0; +sub js_uri_path { + my $self = shift; + 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) + : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths } -sub allow_nested_morph { - my $self = shift; - return $self->{'allow_nested_morph'} ? 1 : 0; -} sub morph { my $self = shift; my $step = shift || return; - my $allow = $self->allow_morph($step) || return; - - ### place to store the lineage - my $lin = $self->{'_morph_lineage'} ||= []; - my $cur = ref $self; # what are we currently - push @$lin, $cur; # store so subsequent unmorph calls can do the right thing - - my $hist = { - step => $step, - meth => 'morph', - found => 'morph', - time => time, - elapsed => 0, - response => 0 - }; - push @{ $self->history }, $hist; + my $allow = $self->run_hook('allow_morph', $step) || return; + my $lin = $self->{'_morph_lineage'} ||= []; + my $cur = ref $self; # what are we currently + push @$lin, $cur; # store so subsequent unmorph calls can do the right thing + + my $hist = {step => $step, meth => 'morph', found => 'morph', time => time, elapsed => 0, response => 0}; + push @{ $self->history }, $hist if ! $self->{'no_history'}; if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless $hist->{'found'} .= " (not allowed to morph to that step)"; @@ -596,396 +596,87 @@ sub morph { ### if we are not already that package - bless us there my $new = $self->run_hook('morph_package', $step); if ($cur ne $new) { - my $file = $new .'.pm'; - $file =~ s|::|/|g; + (my $file = "$new.pm") =~ s|::|/|g; if (UNIVERSAL::can($new, 'can') # check if the package space exists || eval { require $file }) { # check for a file that holds this package - ### become that package - bless $self, $new; + bless $self, $new; # become that package $hist->{'found'} .= " (changed $cur to $new)"; $self->fixup_after_morph($step); - } else { - if ($@) { - if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened - $hist->{'found'} .= " (failed from $cur to $new: $1)"; - } else { - $hist->{'found'} .= " (failed from $cur to $new: $@)"; - my $err = "Trouble while morphing to $file: $@"; - warn $err; - } + } elsif ($@) { + if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened + $hist->{'found'} .= " (failed from $cur to $new: $1)"; + } else { + $hist->{'found'} .= " (failed from $cur to $new: $@)"; + my $err = "Trouble while morphing to $file: $@"; + warn $err; } } } - - $hist->{'response'} = 1; - return 1; -} - -sub unmorph { - my $self = shift; - my $step = shift || '_no_step'; - my $lin = $self->{'_morph_lineage'} || return; - my $cur = ref $self; - - my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)"; - delete $self->{'_morph_lineage'} if ! @$lin; - - ### if we are not already that package - bless us there - my $hist = { - step => $step, - meth => 'unmorph', - found => 'unmorph', - time => time, - elapsed => 0, - response => 0, - }; - push @{ $self->history }, $hist; - - if ($cur ne $prev) { - $self->fixup_before_unmorph($step); - bless $self, $prev; - $hist->{'found'} .= " (changed from $cur to $prev)"; - } else { - $hist->{'found'} .= " (already isa $cur)"; - } - - $hist->{'response'} = 1; - return $self; -} - -sub fixup_after_morph {} - -sub fixup_before_unmorph {} - -###----------------------------------------------------------------### -### allow for authentication - -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; -} - -sub require_auth { - my $self = shift; - $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/); - return $self->{'require_auth'} || 0; -} - -sub is_authed { shift->auth_data } - -sub auth_data { - my $self = shift; - $self->{'auth_data'} = shift if @_ == 1; - return $self->{'auth_data'}; -} - -sub get_valid_auth { - my $self = shift; - return 1 if $self->is_authed; - - 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; - $args->{'js_uri_path'} ||= $self->js_uri_path; - $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) }; - $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) }; - $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) }; - $args->{'login_print'} ||= sub { - my ($auth, $template, $hash) = @_; - my $step = $self->login_step; - 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; - my $obj = CGI::Ex::Auth->new($args); - my $resp = $obj->get_valid_auth; - - my $data = $obj->last_auth_data; - delete $data->{'real_pass'} if defined $data; # data may be defined but false - $self->auth_data($data); # failed authentication may still have auth_data - - return ($resp && $data) ? 1 : 0; -} - -sub auth_args { {} } - -sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" } -sub cleanup_user { my ($self, $user) = @_; $user } -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; - return $self->{'form'} ||= $self->cgix->get_form; -} - -sub cookies { - my $self = shift; - $self->{'cookies'} = shift if @_ == 1; - return $self->{'cookies'} ||= $self->cgix->get_cookies; -} - -sub vob { - my $self = shift; - $self->{'vob'} = shift if @_ == 1; - return $self->{'vob'} ||= do { - require CGI::Ex::Validate; - my $args = $self->vob_args; - $args->{'cgix'} ||= $self->cgix; - CGI::Ex::Validate->new($self->vob_args); # return of the do - }; -} - -sub vob_args { shift->{'vob_args'} || {} } - -sub vob_path { - my $self = shift; - return $self->{'vob_path'} || $self->template_path; -} - -### provide a place for placing variables -sub stash { - my $self = shift; - return $self->{'stash'} ||= {}; -} - -sub clear_app { - my $self = shift; - - delete @{ $self }{qw( - cgix - vob - form - cookies - stash - path - path_i - history - _morph_lineage_start_index - _morph_lineage - hash_errors - hash_fill - hash_swap - hash_common - )}; - - return $self; -} - -###----------------------------------------------------------------### -### default hook implementations - -sub path_info_map { } - -sub run_step { - my $self = shift; - my $step = shift; - - ### if the pre_step exists and returns true, exit the nav_loop - return 1 if $self->run_hook('pre_step', $step); - - ### allow for skipping this step (but stay in the nav_loop) - return 0 if $self->run_hook('skip', $step); - - ### see if we have complete valid information for this step - ### if so, do the next step - ### if not, get necessary info and print it out - if ( ! $self->run_hook('prepare', $step) - || ! $self->run_hook('info_complete', $step) - || ! $self->run_hook('finalize', $step)) { - - ### show the page requesting the information - $self->run_hook('prepared_print', $step); - - ### a hook after the printing process - $self->run_hook('post_print', $step); - - return 1; - } - - ### a hook before end of loop - ### if the post_step exists and returns true, exit the nav_loop - return 1 if $self->run_hook('post_step', $step); - - ### let the nav_loop continue searching the path - return 0; -} - -sub refine_path { - my ($self, $step, $is_at_end) = @_; - return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything - - my $next_step = $self->run_hook('next_step', $step) || return 0; - $self->run_hook('set_ready_validate', $step, 0); - $self->append_path($next_step); - return 1; -} - -sub prepared_print { - my $self = shift; - my $step = shift; - - my $hash_base = $self->run_hook('hash_base', $step) || {}; - my $hash_comm = $self->run_hook('hash_common', $step) || {}; - my $hash_form = $self->run_hook('hash_form', $step) || {}; - my $hash_fill = $self->run_hook('hash_fill', $step) || {}; - my $hash_swap = $self->run_hook('hash_swap', $step) || {}; - my $hash_errs = $self->run_hook('hash_errors', $step) || {}; - - ### fix up errors - $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) - foreach keys %$hash_errs; - $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs; - - ### layer hashes together - my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill}; - my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs}; - - ### run the print hook - passing it the form and fill info - $self->run_hook('print', $step, $swap, $fill); -} - -sub print { - my ($self, $step, $swap, $fill) = @_; - my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path - 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); -} - -sub print_out { - my ($self, $step, $out) = @_; - - $self->cgix->print_content_type($self->mimetype($step), $self->charset($step)); - print ref($out) eq 'SCALAR' ? $$out : $out; -} - -sub mimetype { shift->{'mimetype'} || 'text/html' } -sub charset { shift->{'charset'} || '' } - -sub swap_template { - my ($self, $step, $file, $swap) = @_; - - my $args = $self->run_hook('template_args', $step); - $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path; - - my $t = $self->template_obj($args); - my $out = ''; - $t->process($file, $swap, \$out) || die $t->error; - - return $out; -} - -sub template_path { - my $self = shift; - return $self->{'template_path'} || $self->base_dir_abs; -} - -sub template_args { shift->{'template_args'} || {} } - -sub template_obj { - my ($self, $args) = @_; - - require CGI::Ex::Template; - my $t = CGI::Ex::Template->new($args); -} - -sub fill_template { - my ($self, $step, $outref, $fill) = @_; - - return if ! $fill; - - my $args = $self->run_hook('fill_args', $step); - local $args->{'text'} = $outref; - local $args->{'form'} = $fill; - - require CGI::Ex::Fill; - CGI::Ex::Fill::fill($args); + + $hist->{'response'} = 1; + return 1; } -sub fill_args { shift->{'fill_args'} || {} } +sub replace_path { + my $self = shift; + my $ref = $self->path; + my $i = $self->{'path_i'} || 0; + if ($i + 1 > $#$ref) { + push @$ref, @_; + } else { + splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries + } +} -sub pre_step { 0 } # success indicates we handled step (don't continue step or loop) -sub skip { 0 } # success indicates to skip the step (and continue loop) -sub prepare { 1 } # failure means show step -sub finalize { 1 } # failure means show step -sub post_print { 0 } -sub post_step { 0 } # success indicates we handled step (don't continue step or loop) +sub set_path { + my $self = shift; + my $path = $self->{'path'} ||= []; + croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'}; + splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref) +} -sub morph_package { +sub step_by_path_index { my $self = shift; - my $step = shift || ''; - my $cur = ref $self; # default to using self as the base for morphed modules - my $new = $cur .'::'. $step; - $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName - return $new; + my $i = shift || 0; + my $ref = $self->path; + return '' if $i < 0; +# return $self->default_step if $i > $#$ref; + return $ref->[$i]; } -sub name_module { +sub unmorph { my $self = shift; - my $step = shift || ''; + my $step = shift || '_no_step'; + my $lin = $self->{'_morph_lineage'} || return; + my $cur = ref $self; - return $self->{'name_module'} ||= do { - # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo" - 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 - }; -} + my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)"; + delete $self->{'_morph_lineage'} if ! @$lin; -sub name_step { - my ($self, $step) = @_; - return $step; + my $hist = {step => $step, meth => 'unmorph', found => 'unmorph', time => time, elapsed => 0, response => 0}; + push @{ $self->history }, $hist if ! $self->{'no_history'}; + + if ($cur ne $prev) { + $self->fixup_before_unmorph($step); + bless $self, $prev; + $hist->{'found'} .= " (changed from $cur to $prev)"; + } else { + $hist->{'found'} .= " (already isa $cur)"; + } + + $hist->{'response'} = 1; + return $self; } +###---------------------### +# hooks + sub file_print { - my $self = shift; - my $step = shift; + my ($self, $step) = @_; my $base_dir = $self->base_dir_rel; my $module = $self->run_hook('name_module', $step); - my $_step = $self->run_hook('name_step', $step) || die "Missing name_step"; + my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step"; $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/; foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| } @@ -994,19 +685,19 @@ sub file_print { } sub file_val { - my $self = shift; - my $step = shift; + my ($self, $step) = @_; ### determine the path to begin looking for files - allow for an arrayref - my $abs = $self->vob_path || []; + my $abs = $self->val_path || []; $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE'); $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY'); return {} if @$abs == 0; my $base_dir = $self->base_dir_rel; my $module = $self->run_hook('name_module', $step); - my $_step = $self->run_hook('name_step', $step) || die "Missing name_step"; - $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/; + my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step"; + $_step =~ s/\.\w+$//; + $_step .= '.'. $self->ext_val; foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| } @@ -1020,6 +711,52 @@ sub file_val { return $abs->[0] . $base_dir . $module . $_step; } +sub fill_template { + my ($self, $step, $outref, $fill) = @_; + return if ! $fill || ! scalar keys %$fill; + + my $args = $self->run_hook('fill_args', $step) || {}; + local $args->{'text'} = $outref; + local $args->{'form'} = $fill; + + require CGI::Ex::Fill; + CGI::Ex::Fill::fill($args); +} + +sub finalize { 1 } # failure means show step + +sub hash_base { + my ($self, $step) = @_; + + return $self->{'hash_base'} ||= do { + ### create a weak copy of self to use in closures + my $copy = $self; + eval {require Scalar::Util; Scalar::Util::weaken($copy)}; + my $hash = { + script_name => $self->script_name, + path_info => $self->path_info, + js_validation => sub { $copy->run_hook('js_validation', $step, shift) }, + form_name => $self->run_hook('form_name', $step), + $self->step_key => $step, + }; # return of the do + }; +} + +sub hash_common { $_[0]->{'hash_common'} ||= {} } +sub hash_errors { $_[0]->{'hash_errors'} ||= {} } +sub hash_fill { $_[0]->{'hash_fill'} ||= {} } +sub hash_form { $_[0]->form } +sub hash_swap { $_[0]->{'hash_swap'} ||= {} } + +sub hash_validation { + my ($self, $step) = @_; + return $self->{'hash_validation'}->{$step} ||= do { + my $file = $self->run_hook('file_val', $step); + my $hash = $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies) + $hash; # return of the do + }; +} + sub info_complete { my ($self, $step) = @_; return 0 if ! $self->run_hook('ready_validate', $step); @@ -1027,9 +764,57 @@ sub info_complete { return 1; } -sub ready_validate { +sub js_validation { + my ($self, $step) = @_; + return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself + + my $form_name = $_[2] || $self->run_hook('form_name', $step); + my $hash_val = $_[3] || $self->run_hook('hash_validation', $step); + my $js_uri = $self->js_uri_path; + return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val; + + return $self->val_obj->generate_js($hash_val, $form_name, $js_uri); +} + +sub morph_package { + my ($self, $step) = @_; + my $cur = ref $self; # default to using self as the base for morphed modules + my $new = $cur .'::'. ($step || croak "Missing step"); + $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName + return $new; +} + +sub name_module { my ($self, $step) = @_; - return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0; + return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x) + ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo" + : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")"; +} + +sub name_step { my ($self, $step) = @_; $step } +sub next_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) } +sub post_print { 0 } +sub post_step { 0 } # success indicates we handled step (don't continue step or loop) +sub pre_step { 0 } # success indicates we handled step (don't continue step or loop) +sub prepare { 1 } # failure means show step + +sub print_out { + my ($self, $step, $out) = @_; + + $self->cgix->print_content_type($self->mimetype($step), $self->charset($step)); + print ref($out) eq 'SCALAR' ? $$out : $out; +} + +sub ready_validate { ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0 } + +sub refine_path { + my ($self, $step, $is_at_end) = @_; + return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything + + my $next_step = $self->run_hook('next_step', $step) || return 0; + $self->run_hook('set_ready_validate', $step, 0); + $self->append_path($next_step); + return 1; } sub set_ready_validate { # hook and method @@ -1039,13 +824,28 @@ sub set_ready_validate { # hook and method return $is_ready; } +sub skip { 0 } # success indicates to skip the step (and continue loop) + +sub swap_template { + my ($self, $step, $file, $swap) = @_; + + my $args = $self->run_hook('template_args', $step) || {}; + $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path; + + my $t = $self->template_obj($args); + my $out = ''; + $t->process($file, $swap, \$out) || die $t->error; + return $out; +} + sub validate { my ($self, $step, $form) = @_; my $hash = $self->run_hook('hash_validation', $step); my $what_was_validated = []; - my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) }; + return 1 if ! ref($hash) || ! scalar keys %$hash; + my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) }; die "Step $step: $@" if $@ && ! $err_obj; ### had an error - store the errors and return false @@ -1068,150 +868,89 @@ sub validate { return 1; } -### creates javascript suitable for validating the form -sub js_validation { - my $self = shift; - my $step = shift; - return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself - - my $form_name = shift || $self->run_hook('form_name', $step); - my $hash_val = shift || $self->run_hook('hash_validation', $step); - my $js_uri = $self->js_uri_path; - return '' if UNIVERSAL::isa($hash_val, 'HASH') && ! scalar keys %$hash_val - || UNIVERSAL::isa($hash_val, 'ARRAY') && ! @$hash_val; - - return $self->vob->generate_js($hash_val, $form_name, $js_uri); -} - -sub form_name { 'theform' } - -sub hash_validation { - my ($self, $step) = @_; - - return $self->{'hash_validation'}->{$step} ||= do { - my $hash; - my $file = $self->run_hook('file_val', $step); - - ### allow for returning the validation hash in the filename - ### a scalar ref means it is a yaml document to be read by get_validation - if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) { - $hash = $file; +###---------------------### +# authentication - ### read the file - if it is not found, errors will be in the webserver logs (all else dies) - } elsif ($file) { - $hash = $self->vob->get_validation($file) || {}; - - } else { - $hash = {}; - } +sub navigate_authenticated { + my ($self, $args) = @_; + $self = $self->new($args) if ! ref $self; - $hash; # return of the do - }; -} + croak "The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting" + if $self->can('require_auth') != \&CGI::Ex::App::require_auth; -sub hash_base { - my ($self, $step) = @_; + $self->require_auth(1); - return $self->{'hash_base'} ||= do { - ### create a weak copy of self to use in closures - my $copy = $self; - eval {require Scalar::Util; Scalar::Util::weaken($copy)}; - my $hash = { - script_name => $self->script_name, - path_info => $self->path_info, - js_validation => sub { $copy->run_hook('js_validation', $step, shift) }, - form_name => $self->run_hook('form_name', $step), - $self->step_key => $step, - }; # return of the do - }; + return $self->navigate; } -sub hash_common { shift->{'hash_common'} ||= {} } -sub hash_form { shift->form } -sub hash_fill { shift->{'hash_fill'} ||= {} } -sub hash_swap { shift->{'hash_swap'} ||= {} } -sub hash_errors { shift->{'hash_errors'} ||= {} } - -###----------------------------------------------------------------### -### routines to support the base hooks - -sub add_errors { +sub require_auth { my $self = shift; - my $hash = $self->hash_errors; - my $args = ref($_[0]) ? shift : {@_}; - foreach my $key (keys %$args) { - my $_key = ($key =~ /error$/) ? $key : "${key}_error"; - if ($hash->{$_key}) { - $hash->{$_key} .= '
' . $args->{$key}; - } else { - $hash->{$_key} = $args->{$key}; - } - } - $hash->{'has_errors'} = 1; + $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/); + return $self->{'require_auth'} || 0; } -sub has_errors { scalar keys %{ shift->hash_errors } } - -sub format_error { - my ($self, $error) = @_; - return $error; +sub is_authed { + my $data = shift->auth_data; + return $data && ! $data->{'error'}; } -sub add_to_errors { shift->add_errors(@_) } -sub add_to_swap { my $self = shift; $self->add_to_hash($self->hash_swap, @_) } -sub add_to_fill { my $self = shift; $self->add_to_hash($self->hash_fill, @_) } -sub add_to_form { my $self = shift; $self->add_to_hash($self->hash_form, @_) } -sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) } -sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) } +sub check_valid_auth { + return shift->_do_auth({ + login_print => sub {}, # check only - don't login if not + location_bounce => sub {}, # call get_valid_auth - but don't bounce to other locations + }); +} -sub add_to_hash { +sub get_valid_auth { my $self = shift; - my $old = shift; - my $new = shift; - $new = {$new, @_} if ! ref $new; # non-hashref - $old->{$_} = $new->{$_} foreach keys %$new; -} + return $self->_do_auth({ + login_print => sub { # use CGI::Ex::Auth - but use our formatting and printing + my ($auth, $template, $hash) = @_; + my $step = $self->login_step; + 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}; -sub base_dir_rel { - my $self = shift; - $self->{'base_dir_rel'} = shift if @_ == 1; - return $self->{'base_dir_rel'} || ''; + 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); + } + }); } -sub base_dir_abs { - my $self = shift; - $self->{'base_dir_abs'} = shift if @_ == 1; - return $self->{'base_dir_abs'} || ['.']; # default to the current directory -} +sub _do_auth { + my ($self, $extra) = @_; + return $self->auth_data if $self->is_authed; -sub ext_print { - my $self = shift; - $self->{'ext_print'} = shift if @_ == 1; - return $self->{'ext_print'} || 'html'; -} + my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } }; + $args->{'script_name'} ||= $self->script_name; + $args->{'path_info'} ||= $self->path_info; + $args->{'cgix'} ||= $self->cgix; + $args->{'form'} ||= $self->form; + $args->{'cookies'} ||= $self->cookies; + $args->{'js_uri_path'} ||= $self->js_uri_path; + $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) }; + $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) }; + $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) }; -sub ext_val { - my $self = shift; - $self->{'ext_val'} = shift if @_ == 1; - return $self->{'ext_val'} || 'val'; -} + require CGI::Ex::Auth; + my $obj = CGI::Ex::Auth->new($args); + my $resp = $obj->get_valid_auth; -### where to find the javascript files -### default to using this script as a handler -sub js_uri_path { - my $self = shift; - 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) - : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths + my $data = $obj->last_auth_data; + delete $data->{'real_pass'} if defined $data; # data may be defined but false + $self->auth_data($data); # failed authentication may still have auth_data + + return ($resp && $data) ? $data : undef; } -###----------------------------------------------------------------### -### a simple step that allows for printing javascript libraries that -### are stored in perls @INC. Which ever step is in js_step should do something similar. +###---------------------### +# default steps +### A simple step that allows for printing javascript libraries that are stored in perls @INC. +### Which ever step is in js_step should do something similar for js validation to work. sub js_run_step { my $self = shift; @@ -1224,29 +963,16 @@ sub js_run_step { return 1; } -###----------------------------------------------------------------### -### a step that will be used if a valid_steps is defined -### and the current step of the path is not in valid_steps -### or if the step is a "hidden" step that begins with _ -### or if the step name contains \W - +### A step that will be used the path method determines it is forbidden sub __forbidden_info_complete { 0 } - -sub __forbidden_hash_swap { shift->stash } - +sub __forbidden_hash_swap { shift->stash } sub __forbidden_file_print { \ "

Denied

You do not have access to the step \"[% forbidden_step %]\"" } -###----------------------------------------------------------------### -### a step that is used by the default handle_error - +### A step that is used by the default handle_error sub __error_info_complete { 0 } - -sub __error_hash_swap { shift->stash } - +sub __error_hash_swap { shift->stash } sub __error_file_print { \ "

A fatal error occurred

Step: \"[% error_step %]\"
[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" } -###----------------------------------------------------------------### - 1; ### See the perldoc in CGI/Ex/App.pod diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod index 59c5e21..b231a0b 100644 --- a/lib/CGI/Ex/App.pod +++ b/lib/CGI/Ex/App.pod @@ -208,7 +208,7 @@ The nav_loop method will run as follows: # exits nav_loop if true ->morph - # check ->allow_morph + # check ->allow_morph (hook) # check ->allow_nested_morph # ->morph_package (hook - get the package to bless into) # ->fixup_after_morph if morph_package exists @@ -981,7 +981,7 @@ The following is the alphabetical list of methods and hooks. =over 4 -=item allow_morph (method) +=item allow_morph (hook) Should return true if this step is allowed to "morph" the current App object into another package. Default is false. It is passed a single @@ -1139,24 +1139,28 @@ load_conf is false).. Caches results in $self->{'conf'}. +If the conf_file can't be found, the method will die unless +conf_die_on_fail returns 0 (defaults to true). + +=item conf_args + +Used by conf_obj. + +Defaults to $self->{'conf_args'} which defaults to {}. Will have +paths => $self->conf_path added before passing to CGI::Ex::Conf->new. + =item conf_file (method) Used by conf for finding the configuration file to load. Defaults to $self->{'conf_file'} which defaults $self->name_module with the extention -returned by $self->conf_ext added on. For example, if name_module -returns "my_app" and conf_ext returns "ini" the value returned will +returned by $self->ext_conf added on. For example, if name_module +returns "my_app" and ext_conf returns "ini" the value returned will be "my_app.ini". The value returned can absolute. If the value will be searched for in the paths passed to conf_obj. -The conf_ext may be any of those extentions understood by CGI::Ex::Conf. - -=item conf_ext - -Used by the default conf_file method. Defaults to $self->{'conf_ext'} which -defaults to 'pl' meaning that the read configuration file should return a -valid perl hashref. +The ext_conf may be any of those extentions understood by CGI::Ex::Conf. =item conf_obj @@ -1172,13 +1176,6 @@ Defaults to $self->{'conf_path'} which defaults to base_dir_abs. Should be a path or an arrayref of paths to look the configuration file returned by conf_file when that file is not absolute. -=item conf_args - -Used by conf_obj. - -Defaults to $self->{'conf_args'} which defaults to {}. Will have -paths => $self->conf_path added before passing to CGI::Ex::Conf->new. - =item conf_validation Used by default conf method. @@ -1284,6 +1281,12 @@ hooks for the current and remaining steps. It is used to allow the unmorphed before returning. Also - the post_navigate method will still be called. +=item ext_conf + +Used by the default conf_file method. Defaults to $self->{'ext_conf'} which +defaults to 'pl' meaning that the read configuration file should return a +valid perl hashref. + =item ext_print (method) Added as suffix to "name_step" during the default file_print hook. diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 7362ed1..70d754e 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.17'; +$VERSION = '2.18'; ###----------------------------------------------------------------### @@ -61,7 +61,7 @@ sub get_valid_auth { next if ! defined $hash->{$key}; $had_form_info ++ if $is_form; - ### if it looks like a bare username (as in they didn't have javascript)- add in other items + ### if it looks like a bare username (as in they didn't have javascript) - add in other items my $data; if ($is_form && $hash->{$key} !~ m|^[^/]+/| @@ -180,6 +180,7 @@ sub cookies { sub delete_cookie { my $self = shift; my $args = shift; + return $self->{'delete_cookie'}->($self, $args) if $self->{'delete_cookie'}; my $key = $args->{'key'}; $self->cgix->set_cookie({ -name => $key, @@ -193,6 +194,7 @@ sub delete_cookie { sub set_cookie { my $self = shift; my $args = shift; + return $self->{'set_cookie'}->($self, $args) if $self->{'set_cookie'}; my $key = $args->{'key'}; my $val = $args->{'val'}; $self->cgix->set_cookie({ @@ -207,6 +209,7 @@ sub set_cookie { sub location_bounce { my $self = shift; my $url = shift; + return $self->{'location_bounce'}->($self, $url) if $self->{'location_bounce'}; return $self->cgix->location_bounce($url); } diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index d7db3ba..420f4de 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.17'; +$VERSION = '2.18'; $DEFAULT_EXT = 'conf'; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index d592257..876f6ad 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.17'; + $VERSION = '2.18'; $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 54cecdc..d3ecd7a 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.17'; +$VERSION = '2.18'; @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 beeb542..2966817 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.17'; + $VERSION = '2.18'; @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 4e734d7..0c7f9bb 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.17'; + $VERSION = '2.18'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 0d3d7b4..c4374ae 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -25,7 +25,7 @@ use vars qw($VERSION $VOBJS ); -$VERSION = '2.17'; +$VERSION = '2.18'; ### 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 d8b3e7e..146a10e 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.17'; +$VERSION = '2.18'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; @@ -120,6 +120,7 @@ sub validate { push @$fields, { %{$val_hash->{$field}}, field => $field }; } } + return if ! $fields; ### Finally we have our arrayref of hashrefs that each have their 'field' key ### now lets do the validation diff --git a/t/1_validate_00_base.t b/t/1_validate_00_base.t index 12a1b0c..e91428b 100644 --- a/t/1_validate_00_base.t +++ b/t/1_validate_00_base.t @@ -7,7 +7,7 @@ =cut use strict; -use Test::More tests => 3; +use Test::More tests => 5; use_ok('CGI::Ex::Validate'); @@ -37,3 +37,14 @@ $form = { $err_obj = CGI::Ex::Validate::validate($form,$val); ok($err_obj, "Successfully failed"); + +###----------------------------------------------------------------### + +eval { CGI::Ex::Validate::validate($form,undef) }; +ok($@, "Needs to have a hashref"); + +###----------------------------------------------------------------### + +$err_obj = CGI::Ex::Validate::validate($form,{}); + +ok(!$err_obj, "OK with empty hash"); diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t index 78148d5..3fe81be 100644 --- a/t/4_app_00_base.t +++ b/t/4_app_00_base.t @@ -13,8 +13,9 @@ we do try to put it through most paces. =cut -use Test::More tests => 25; +use Test::More tests => 214; use strict; +use warnings; { package Foo; @@ -24,8 +25,6 @@ use strict; sub init { $test_stdout = '' } - sub ready_validate { 1 } - sub print_out { my $self = shift; my $step = shift; @@ -35,12 +34,13 @@ use strict; 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; + die "No filenames allowed during test mode" if ! ref($file); + return $self->SUPER::swap_template($step, $file, $swap); } - sub auth_args { {login_template => \q{Login Form}} } + sub auth_args { {login_template => \q{Login Form}, key_user => 'user', key_pass => 'pass', key_cookie => 'user', set_cookie => sub {}} } + + sub get_pass_by_user { '123qwe' } ###----------------------------------------------------------------### @@ -48,6 +48,8 @@ use strict; sub main_file_print { return \ "Main Content" } + sub main_path_info_map { shift->{'main_path_info_map'} } + sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} } sub step2_path_info_map { [[qr{^/step2/(\w+)$}x, 'wow']] } @@ -63,9 +65,59 @@ use strict; sub step3_info_complete { 0 } sub step3_file_print { return \ "All good" } + + sub step4_file_val { return {wow => {required => 1, required_error => 'wow is required'}} } + + sub step4_path_info_map { [[qr{^/step4/(\w+)$}x, 'wow']] } + + sub step4_file_print { return \ "Some step4 content ([% foo %], [% one %])
[% wow_error %]
[% js_validation %]" } + + sub step4_hash_swap { return {foo => 'bar', one => 'two'} } + + sub step4_hash_fill { return {wow => 'wee'} } + + sub step4_finalize { shift->append_path('step3') } + } ###----------------------------------------------------------------### +###----------------------------------------------------------------### +###----------------------------------------------------------------### +###----------------------------------------------------------------### +print "### Test some basic returns ###\n"; + +ok(! eval { CGI::Ex::App::new() }, "Invalid new"); +ok(! eval { CGI::Ex::App::new(0) }, "Invalid new"); + +my $app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar'}); +ok($app->script_name eq '/cgi-bin/foo_bar', "Can pass in script_name"); +ok($app->name_module eq 'foo_bar', "Can pass in script_name"); + +$app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar.pl'}); +ok($app->script_name eq '/cgi-bin/foo_bar.pl', "Can pass in script_name"); +ok($app->name_module eq 'foo_bar', "Can pass in script_name"); + +ok(Foo->new(name_module => 'foo')->name_module eq 'foo', "Got the name_module"); +ok(! eval { Foo->new(script_name => '%####$')->name_module } && $@, "Bad script_name"); +ok(! eval { Foo->new(script_name => '%####$')->name_module('foo') } && $@, "Bad script_name"); + +ok(! eval { $app->morph_package } && $@, "Can't get a good morph_package"); +ok($app->morph_package('foo') eq 'CGI::Ex::App::Foo', "Got a good morph_package"); +ok($app->morph_package('foo_bar') eq 'CGI::Ex::App::FooBar', "Got a good morph_package"); + +ok(ref($app->path), "Got a good path"); +ok(@{ $app->path } == 0, "Got a good path"); +ok($app->default_step eq 'main', "Got a good default_step"); +ok($app->login_step eq '__login', "Got a good login_step"); +ok($app->error_step eq '__error', "Got a good error_step"); +ok($app->forbidden_step eq '__forbidden', "Got a good forbidden_step"); +ok($app->js_step eq 'js', "Got a good js_step"); + +###----------------------------------------------------------------### +###----------------------------------------------------------------### +###----------------------------------------------------------------### +###----------------------------------------------------------------### +print "### Test basic step selection/form input/validation/filling/template swapping methods ###\n"; #$ENV{'REQUEST_METHOD'} = 'GET'; #$ENV{'QUERY_STRING'} = ''; @@ -73,17 +125,81 @@ use strict; Foo->new({ form => {}, })->navigate; -ok($Foo::test_stdout eq "Main Content", "Got the right output"); +ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo"); + +{ + package Foo2; + our @ISA = qw(Foo); + sub form { {} } +} +Foo2->navigate; +ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2"); ###----------------------------------------------------------------### -#$ENV{'REQUEST_METHOD'} = 'GET'; +{ + package Foo2_1; + our @ISA = qw(Foo); + sub pre_navigate { 1 } +} +Foo2_1->navigate; +ok($Foo::test_stdout eq "", "Got the right output for Foo2_1"); + +Foo2_1->new({_no_pre_navigate => 1})->navigate; +ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_1"); + +{ + package Foo2_2; + our @ISA = qw(Foo); + sub pre_loop { 1 } +} +Foo2_2->navigate; +ok($Foo::test_stdout eq "", "Got the right output for Foo2_2"); + +{ + package Foo2_3; + our @ISA = qw(Foo); + sub post_loop { 1 } +} +Foo2_3->navigate; +ok($Foo::test_stdout eq "", "Got the right output for Foo2_3"); + +{ + package Foo2_4; + our @ISA = qw(Foo); + sub post_navigate { $Foo::test_stdout .= " post"; 1 } +} +Foo2_4->navigate; +ok($Foo::test_stdout eq "Main Content post", "Got the right output for Foo2_4"); + +Foo2_4->new({_no_post_navigate => 1})->navigate; +ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_4"); + +###----------------------------------------------------------------### + +local $ENV{'REQUEST_METHOD'} = 'POST'; #$ENV{'QUERY_STRING'} = 'step=step2'; Foo->new({ form => {step => 'step2'}, })->navigate; -ok($Foo::test_stdout eq "Some step2 content (bar, two) wow is required", "Got the right output"); +ok($Foo::test_stdout eq "Some step2 content (bar, two) wow is required", "Got the right output for Foo"); + +Foo->new({ + form => {step => 'step4'}, +})->navigate; +ok($Foo::test_stdout =~ /Some step4 content.*wow is required.*