X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FApp.pm;h=9ccbab3e31ca43c0559f937d64a25371c82f4780;hb=aa030874456c91d688e6c9b25e82d2bf9575ea6f;hp=a177c7f7af7eba18546b536a2eba7eb5a530cc9d;hpb=4eee158dce82376f2f37de29d91c53f60a24aebe;p=chaz%2Fp5-CGI-Ex

diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm
index a177c7f..9ccbab3 100644
--- a/lib/CGI/Ex/App.pm
+++ b/lib/CGI/Ex/App.pm
@@ -2,7 +2,7 @@ package CGI::Ex::App;
 
 ###----------------------------------------------------------------###
 #  See the perldoc in CGI/Ex/App.pod
-#  Copyright 2006 - Paul Seamons                                     #
+#  Copyright 2007 - Paul Seamons                                     #
 #  Distributed under the Perl Artistic License without warranty      #
 ###----------------------------------------------------------------###
 
@@ -10,9 +10,10 @@ use strict;
 use vars qw($VERSION);
 
 BEGIN {
-    $VERSION = '2.00';
+    $VERSION = '2.14';
 
     Time::HiRes->import('time') if eval {require Time::HiRes};
+    eval {require Scalar::Util};
 }
 
 sub croak {
@@ -37,6 +38,8 @@ sub new {
 
 sub init {}
 
+sub destroy {}
+
 ###----------------------------------------------------------------###
 
 sub navigate {
@@ -74,6 +77,8 @@ sub navigate {
 
     $self->{'_time'} = time;
 
+    $self->destroy;
+
     return $self;
 }
 
@@ -117,14 +122,34 @@ sub nav_loop {
         ### allow for becoming another package (allows for some steps in external files)
         $self->morph($step);
 
-        ### run the guts of the step
-        my $status = $self->run_hook('run_step', $step);
+        ### allow for mapping path_info pieces to form elements
+        if (my $info = $ENV{'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'));
+            foreach my $map (@$maps) {
+                my @match = $info =~ $map->[0];
+                next if ! @match;
+                $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
+                last;
+            }
+        }
 
-        $self->unmorph($step);
+        ### run the guts of the step
+        my $handled = $self->run_hook('run_step', $step);
 
         ### Allow for the run_step to intercept.
         ### A true status means the run_step took over navigation.
-        return if $status;
+        if ($handled) {
+            $self->unmorph($step);
+            return;
+        }
+
+        ### if there are no future steps - allow for this step to designate one to follow
+        my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
+        $self->run_hook('refine_path', $step, $is_at_end);
+
+        $self->unmorph($step);
     }
 
     ### allow for one exit point after the loop
@@ -170,10 +195,21 @@ sub path {
     if (! $self->{'path'}) {
         my $path = $self->{'path'} = []; # empty path
 
-        my $step = $self->form->{ $self->step_key };
-        $step = lc($1) if ! $step && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|;
+        ### add initial items to the form hash from path_info
+        if (my $info = $ENV{'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'));
+            foreach my $map (@$maps) {
+                my @match = $info =~ $map->[0];
+                next if ! @match;
+                $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
+                last;
+            }
+        }
 
         ### make sure the step is valid
+        my $step = $self->form->{$self->step_key};
         if (defined $step) {
             if ($step =~ /^_/) {         # can't begin with _
                 $self->stash->{'forbidden_step'} = $step;
@@ -193,6 +229,11 @@ sub path {
     return $self->{'path'};
 }
 
+sub path_info_map_base {
+    my $self = shift;
+    return [[qr{/(\w+)}, $self->step_key]];
+}
+
 sub set_path {
     my $self = shift;
     my $path = $self->{'path'} ||= [];
@@ -320,31 +361,26 @@ sub step_by_path_index {
 
 sub previous_step {
     my $self = shift;
-    croak "previous_step is readonly" if $#_ != -1;
     return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
 }
 
 sub current_step {
     my $self = shift;
-    croak "current_step is readonly" if $#_ != -1;
     return $self->step_by_path_index( ($self->{'path_i'} || 0) );
 }
 
-sub next_step {
+sub next_step { # method and hook
     my $self = shift;
-    croak "next_step is readonly" if $#_ != -1;
     return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
 }
 
 sub last_step {
     my $self = shift;
-    croak "last_step is readonly" if $#_ != -1;
     return $self->step_by_path_index( $#{ $self->path } );
 }
 
 sub first_step {
     my $self = shift;
-    croak "first_step is readonly" if $#_ != -1;
     return $self->step_by_path_index( 0 );
 }
 
@@ -376,9 +412,10 @@ sub run_hook {
     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,
@@ -460,9 +497,9 @@ sub allow_nested_morph {
 }
 
 sub morph {
-    my $self = shift;
-    my $step = shift || return;
-    return if ! (my $allow = $self->allow_morph($step));
+    my $self  = shift;
+    my $step  = shift || return;
+    my $allow = $self->allow_morph($step) || return;
 
     ### place to store the lineage
     my $lin = $self->{'__morph_lineage'} ||= [];
@@ -474,13 +511,14 @@ sub morph {
         meth  => 'morph',
         found => 'morph',
         time  => time,
-        elapsed => 0,
+        elapsed  => 0,
+        response => 0
     };
     push @{ $self->history }, $hist;
 
     if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
         $hist->{'found'} .= " (not allowed to morph to that step)";
-        return;
+        return 0;
     }
 
     ### make sure we haven't already been reblessed
@@ -489,7 +527,7 @@ sub morph {
             || (ref($allow) && ! $allow->{$step})         # hash - but no step
             )) {
         $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
-        return; # just return - don't die so that we can morph early
+        return 0; # just return - don't die so that we can morph early
     }
 
     ### if we are not already that package - bless us there
@@ -516,6 +554,8 @@ sub morph {
         }
     }
 
+    $hist->{'response'} = 1;
+    return 1;
 }
 
 sub unmorph {
@@ -533,7 +573,8 @@ sub unmorph {
         meth  => 'unmorph',
         found => 'unmorph',
         time  => time,
-        elapsed => 0,
+        elapsed  => 0,
+        response => 0,
     };
     push @{ $self->history }, $hist;
 
@@ -545,6 +586,7 @@ sub unmorph {
         $hist->{'found'} .= " (already isa $cur)";
     }
 
+    $hist->{'response'} = 1;
     return $self;
 }
 
@@ -661,9 +703,34 @@ sub stash {
     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;
@@ -698,6 +765,16 @@ sub run_step {
     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;
@@ -737,29 +814,37 @@ sub print {
 sub print_out {
     my ($self, $step, $out) = @_;
 
-    $self->cgix->print_content_type();
+    $self->cgix->print_content_type;
     print $out;
 }
 
 sub swap_template {
     my ($self, $step, $file, $swap) = @_;
 
-    require CGI::Ex::Template;
     my $args = $self->run_hook('template_args', $step);
-    my $t = CGI::Ex::Template->new($args);
+    my $copy = $self;
+    eval {require Scalar::Util; Scalar::Util::weaken($copy)};
+    $args->{'INCLUDE_PATH'} ||= sub {
+        my $dir = $copy->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"";
+        $dir = $dir->() if UNIVERSAL::isa($dir, 'CODE');
+        return $dir;
+    };
 
+    my $t   = $self->template_obj($args);
     my $out = '';
+
     $t->process($file, $swap, \$out) || die $t->error;
 
     return $out;
 }
 
-sub template_args {
-    my $self = shift;
-    my $step = shift;
-    return {
-        INCLUDE_PATH => sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" },
-    };
+sub template_args { {} }
+
+sub template_obj {
+    my ($self, $args) = @_;
+
+    require CGI::Ex::Template;
+    my $t = CGI::Ex::Template->new($args);
 }
 
 sub fill_template {
@@ -781,14 +866,9 @@ sub pre_step   { 0 } # success indicates we handled step (don't continue step or
 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 } # success indicates we handled step (don't continue loop)
+sub post_print { 0 }
 sub post_step  { 0 } # success indicates we handled step (don't continue step or loop)
 
-sub name_step {
-    my ($self, $step) = @_;
-    return $step;
-}
-
 sub morph_package {
     my $self = shift;
     my $step = shift || '';
@@ -810,6 +890,11 @@ sub name_module {
     };
 }
 
+sub name_step {
+    my ($self, $step) = @_;
+    return $step;
+}
+
 sub file_print {
     my $self = shift;
     my $step = shift;
@@ -828,42 +913,51 @@ sub file_val {
     my $self = shift;
     my $step = shift;
 
-    my $abs      = $self->base_dir_abs || return {};
+    ### determine the path to begin looking for files - allow for an arrayref
+    my $abs = $self->base_dir_abs || [];
+    $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);
+    my $_step    = $self->run_hook('name_step', $step) || die "Missing name_step";
     $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
 
-    foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+    foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+
+    if (@$abs > 1) {
+        foreach my $_abs (@$abs) {
+            my $path = $_abs . $base_dir . $module . $_step;
+            return $path if -e $path;
+        }
+    }
 
-    return $abs . $base_dir . $module . $_step;
+    return $abs->[0] . $base_dir . $module . $_step;
 }
 
 sub info_complete {
-    my $self = shift;
-    my $step = shift;
-
+    my ($self, $step) = @_;
     return 0 if ! $self->run_hook('ready_validate', $step);
-    return 0 if ! $self->run_hook('validate', $step);
+    return 0 if ! $self->run_hook('validate', $step, $self->form);
     return 1;
 }
 
 sub ready_validate {
-    my $self = shift;
-    my $step = shift;
-
+    my ($self, $step) = @_;
     return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
 }
 
-sub set_ready_validate {
-    my ($self, $ready) = @_;
-    $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET';
+sub set_ready_validate { # hook and method
+    my $self = shift;
+    my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
+    $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
+    return $is_ready;
 }
 
 sub validate {
-    my $self = shift;
-    my $step = shift;
-    my $form = shift || $self->form;
+    my ($self, $step, $form) = @_;
+
     my $hash = $self->run_hook('hash_validation', $step);
     my $what_was_validated = [];
 
@@ -919,9 +1013,9 @@ sub hash_validation {
       if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
           $hash = $file;
 
-      ### read the file - if it fails - errors should be in the webserver error logs
+      ### read the file - if it is not found, errors will be in the webserver logs (all else dies)
       } elsif ($file) {
-          $hash = eval { $self->vob->get_validation($file) } || {};
+          $hash = $self->vob->get_validation($file) || {};
 
       } else {
           $hash = {};
@@ -936,14 +1030,8 @@ sub hash_base {
 
     return $self->{'hash_base'} ||= do {
         ### create a weak copy of self to use in closures
-        my $copy;
-        if (eval {require Scalar::Util} && defined &Scalar::Util::weaken) {
-            $copy = $self;
-            Scalar::Util::weaken($copy);
-        } else {
-            $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8)
-        }
-
+        my $copy = $self;
+        eval {require Scalar::Util; Scalar::Util::weaken($copy)};
         my $hash = {
             script_name     => $ENV{'SCRIPT_NAME'} || $0,
             path_info       => $ENV{'PATH_INFO'}   || '',
@@ -1013,18 +1101,18 @@ sub base_dir_abs {
     return $self->{'base_dir_abs'} || '';
 }
 
-sub ext_val {
-    my $self = shift;
-    $self->{'ext_val'} = shift if $#_ != -1;
-    return $self->{'ext_val'} || 'val';
-}
-
 sub ext_print {
     my $self = shift;
     $self->{'ext_print'} = shift if $#_ != -1;
     return $self->{'ext_print'} || 'html';
 }
 
+sub ext_val {
+    my $self = shift;
+    $self->{'ext_val'} = shift if $#_ != -1;
+    return $self->{'ext_val'} || 'val';
+}
+
 ### where to find the javascript files
 ### default to using this script as a handler
 sub js_uri_path {