X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FApp.pm;h=a0ccaa9c686061fc16967c83e1cb474507ce5d8a;hb=8a1796477c5a835d8c124cfa8504909dc786d93b;hp=552045a7b8ae7a8091f463a528bb95180d595007;hpb=85070b46d0a93ddbeef07341421adb8389a55418;p=chaz%2Fp5-CGI-Ex
diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm
index 552045a..a0ccaa9 100644
--- a/lib/CGI/Ex/App.pm
+++ b/lib/CGI/Ex/App.pm
@@ -1,462 +1,490 @@
package CGI::Ex::App;
-### CGI Extended Application
-
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# See the perldoc in CGI/Ex/App.pod
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
-
use strict;
-use vars qw($VERSION
- $EXT_PRINT $EXT_VAL $BASE_DIR_REL $BASE_DIR_ABS $BASE_NAME_MODULE
- $RECURSE_LIMIT
- %CLEANUP_EXCLUDE);
-
-$VERSION = '1.14';
-use CGI::Ex::Dump qw(debug);
+use vars qw($VERSION);
BEGIN {
- ### Default file locations
- ### these are used for the provided stub functions - if you are not
- ### using the stub functions - then you won't need to worry about these
- $EXT_PRINT ||= 'html';
- $EXT_VAL ||= 'val';
- $BASE_DIR_REL ||= ''; # relative path - stub methods will look in $BASE_DIR_REL/dir/of/content.html
- $BASE_DIR_ABS ||= ''; # content should be found at "$BASE_DIR_ABS/$BASE_DIR_REL/dir/of/content.html"
- $BASE_NAME_MODULE ||= ''; # the cgi name
+ $VERSION = '2.09';
- ### list of modules to exclude during cleanup
- ### this takes care of situations such as
- ### template toolkits rules area which contains
- ### a nested structure of rules and sub references.
- $CLEANUP_EXCLUDE{'Template::Parser'} = 1;
+ 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";
+}
###----------------------------------------------------------------###
sub new {
- my $class = shift || __PACKAGE__;
- my $self = ref($_[0]) ? shift : {@_};
- bless $self, $class;
- $self->init;
- return $self;
+ my $class = shift || croak "Usage: Package->new";
+ my $self = shift || {};
+ bless $self, $class;
+
+ $self->init;
+
+ return $self;
}
sub init {}
+sub destroy {}
+
###----------------------------------------------------------------###
sub navigate {
- my $self = shift;
- my $args = ref($_[0]) ? shift : {@_};
- $self = $self->new($args) if ! ref $self;
-
- eval {
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
- ### a chance to do things at the very beginning
- return $self if $self->pre_navigate;
+ $self->{'_time'} = time;
- ### 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
- die $@ if $@ ne "Long Jump\n";
- }
+ ### allow for authentication
+ my $ref = $self->require_auth;
+ if ($ref && ! ref $ref) {
+ return $self if ! $self->get_valid_auth;
+ }
- ### one chance to do things at the very end
- $self->post_navigate;
+ ### 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";
+ }
- };
+ ### one chance to do things at the very end
+ $self->post_navigate if ! $self->{'_no_post_navigate'};
- ### catch errors - if any
- if ($@) {
- $self->handle_error($@);
- }
- return $self;
+ };
+ $self->handle_error($@) if $@; # catch any errors
+
+ $self->{'_time'} = time;
+
+ $self->destroy;
+
+ return $self;
}
sub nav_loop {
- my $self = shift;
+ my $self = shift;
- ### keep from an infinate nesting
- local $self->{recurse} = $self->{recurse} || 0;
- if ($self->{recurse} ++ >= $self->recurse_limit) {
- my $err = "recurse_limit reached (".$self->recurse_limit.")";
- $err .= " number of jumps (".$self->{jumps}.")" if ($self->{jumps} || 0) > 1;
- die $err;
- }
-
- ### get the path (simple arrayref based thing)
- my $path = $self->path;
-
- ### allow for an early return
- return if $self->pre_loop($path); # a true value means to abort the navigate
-
- ### get a hash of valid paths (if any)
- my $valid_steps = $self->valid_steps;
-
- ### iterate on each step of the path
- foreach ($self->{path_i} ||= 0;
- $self->{path_i} <= $#$path;
- $self->{path_i} ++) {
- my $step = $path->[$self->{path_i}];
- next if $step !~ /^[a-zA-Z_]\w*$/; # don't process the step if it contains odd characters
-
- ### check if this is an allowed step
- if ($valid_steps) {
- if (! $valid_steps->{$step}
- && $step ne $self->default_step
- && $step ne 'forbidden') {
- $self->stash->{'forbidden_step'} = $step;
- $self->replace_path('forbidden');
- next;
- }
+ ### keep from an infinate nesting
+ local $self->{'recurse'} = $self->{'recurse'} || 0;
+ if ($self->{'recurse'} ++ >= $self->recurse_limit) {
+ my $err = "recurse_limit (".$self->recurse_limit.") reached";
+ $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
+ croak $err;
}
- ### 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);
+ my $path = $self->path;
- $self->unmorph($step);
+ ### allow for an early return
+ return if $self->pre_loop($path); # a true value means to abort the navigate
- ### Allow for the run_step to intercept.
- ### A true status means the run_step took over navigation.
- return if $status;
- }
+ my $req_auth = ref($self->require_auth) ? $self->require_auth : undef;
- ### allow for one exit point after the loop
- return if $self->post_loop($path); # a true value means to abort the navigate
+ ### iterate on each step of the path
+ foreach ($self->{'path_i'} ||= 0;
+ $self->{'path_i'} <= $#$path;
+ $self->{'path_i'} ++) {
+ my $step = $path->[$self->{'path_i'}];
+ if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
+ $self->stash->{'forbidden_step'} = $step;
+ $self->replace_path($self->forbidden_step);
+ next;
+ }
+ $step = $1; # untaint
- ### run the default step as a last resort
- $self->insert_path($self->default_step);
- $self->nav_loop; # go recursive
+ ### allow for per-step authentication
+ if ($req_auth
+ && $req_auth->{$step}
+ && ! $self->get_valid_auth) {
+ return;
+ }
- return;
-}
+ ### 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'}) {
+ 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;
+ }
+ }
-sub pre_navigate {}
+ ### run the guts of the step
+ my $handled = $self->run_hook('run_step', $step);
-sub post_navigate {}
+ ### Allow for the run_step to intercept.
+ ### A true status means the run_step took over navigation.
+ if ($handled) {
+ $self->unmorph($step);
+ return;
+ }
-sub recurse_limit { shift->{'recurse_limit'} || $RECURSE_LIMIT || 15 }
+ ### 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);
-sub run_step {
- my $self = shift;
- my $step = shift;
+ $self->unmorph($step);
+ }
- ### if the pre_step exists and returns true, exit the nav_loop
- return 1 if $self->run_hook('pre_step', $step);
+ ### allow for one exit point after the loop
+ return if $self->post_loop($path); # a true value means to abort the navigate
- ### allow for skipping this step (but stay in the nav_loop)
- return 0 if $self->run_hook('skip', $step);
+ ### run the default step as a last resort
+ $self->insert_path($self->default_step);
+ $self->nav_loop; # go recursive
- ### 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, 1)
- || ! $self->run_hook('info_complete', $step)
- || ! $self->run_hook('finalize', $step, 1)) {
+ return;
+}
- ### show the page requesting the information
- $self->run_hook('prepared_print', $step);
+sub pre_navigate { 0 } # true means to not enter nav_loop
- ### a hook after the printing process
- $self->run_hook('post_print', $step);
+sub post_navigate {}
- return 2;
- }
+sub pre_loop { 0 } # true value means to abort the nav_loop routine
- ### 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);
+sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
- ### let the nav_loop continue searching the path
- return 0;
-}
+sub recurse_limit { shift->{'recurse_limit'} || 15 }
-### standard functions for printing - gather information
-sub prepared_print {
+### default die handler - show what happened and die (so its in the error logs)
+sub handle_error {
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);
- $_ ||= {} foreach $hash_base, $hash_comm, $hash_form, $hash_fill, $hash_swap, $hash_errs;
+ my $err = shift;
- ### fix up errors
- $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
- foreach keys %$hash_errs;
- $hash_errs->{has_errors} = 1 if scalar keys %$hash_errs;
+ die $err;
+}
- ### 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};
- $fill = {} if $self->no_fill($step);
+###----------------------------------------------------------------###
- ### run the print hook - passing it the form and fill info
- $self->run_hook('print', $step, undef,
- $swap, $fill);
-}
+sub default_step { shift->{'default_step'} || 'main' }
-sub no_fill { shift->{'no_fill'} }
+sub js_step { shift->{'js_step'} || 'js' }
-sub exit_nav_loop {
- my $self = shift;
+sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
- ### undo morphs
- if (my $ref = $self->{'__morph_lineage'}) {
- ### use the saved index - this allows for early "morphers" to only get rolled back so far
- my $index = $self->{'__morph_lineage_start_index'};
- $index = -1 if ! defined $index;
- $self->unmorph while $#$ref != $index;
- }
+sub step_key { shift->{'step_key'} || 'step' }
- ### long jump back
- die "Long Jump\n";
-}
+sub path {
+ my $self = shift;
+ 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'}) {
+ 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;
+ }
+ }
-sub jump {
- my $self = shift;
- my $i = ($#_ == -1) ? 1 : shift;
- my $path = $self->path;
- my $path_i = $self->{path_i};
- die "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
- for (my $j = $#$path; $j >= 0; $j --) {
- if ($path->[$j] eq $i) {
- $i = $j - $path_i;
- 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;
+ push @$path, $self->forbidden_step;
+ } elsif ($self->valid_steps # must be in valid_steps if defined
+ && ! $self->valid_steps->{$step}
+ && $step ne $self->default_step
+ && $step ne $self->js_step) {
+ $self->stash->{'forbidden_step'} = $step;
+ push @$path, $self->forbidden_step;
+ } else {
+ push @$path, $step;
+ }
}
- }
}
- }
- if ($i !~ /^-?\d+$/) {
- require Carp;
- Carp::croak("Invalid jump index ($i)");
- }
-
- ### 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];
- }
- $self->replace_path(@replace);
-
- ### record the number of jumps
- $self->{jumps} ||= 0;
- $self->{jumps} ++;
-
- ### run the newly fixed up path (recursively)
- $self->{path_i} ++; # move along now that the path is updated
- $self->nav_loop;
- $self->exit_nav_loop;
-}
-
-sub default_step {
- my $self = shift;
- return $self->{'default_step'} || 'main';
-}
-
-###----------------------------------------------------------------###
-sub step_key {
- my $self = shift;
- return $self->{'step_key'} || 'step';
+ return $self->{'path'};
}
-### determine the path to follow
-sub path {
- my $self = shift;
- return $self->{path} ||= do {
- my @path = (); # default to empty path
- my $step_key = $self->step_key;
-
- if (my $step = $self->form->{$step_key}) {
- push @path, $step;
- } elsif ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|) {
- push @path, lc($1);
- }
-
- \@path; # return of the do
- };
+sub path_info_map_base {
+ my $self = shift;
+ return [[qr{/(\w+)}, $self->step_key]];
}
-### really should only be used during initialization
sub set_path {
- my $self = shift;
- my $path = $self->{path} ||= [];
- die "Cannot call set_path after the navigation loop has begun" if $self->{path_i};
- splice @$path, 0, $#$path + 1, @_; # change entries in the ref
+ 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)
}
### legacy - same as append_path
sub add_to_path {
- my $self = shift;
- push @{ $self->path }, @_;
+ my $self = shift;
+ push @{ $self->path }, @_;
}
-### append entries onto the end
sub append_path {
- my $self = shift;
- push @{ $self->path }, @_;
+ my $self = shift;
+ push @{ $self->path }, @_;
}
-### replace all entries that are left
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
- }
+ 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
+ }
}
-### insert more steps into the current path
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
- }
+ 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
+ }
}
-### a hash of paths that are allowed, default undef is all
+### a hash of paths that are allowed, default undef is all are allowed
sub valid_steps {}
###----------------------------------------------------------------###
-### allow for checking where we are in the path
+### allow for checking where we are in the path and for jumping around
+
+sub exit_nav_loop {
+ my $self = shift;
+
+ ### undo morphs
+ if (my $ref = $self->{'__morph_lineage'}) {
+ ### use the saved index - this allows for early "morphers" to only get rolled back so far
+ my $index = $self->{'__morph_lineage_start_index'};
+ $index = -1 if ! defined $index;
+ $self->unmorph while $#$ref != $index;
+ }
+
+ ### long jump back
+ die "Long Jump\n";
+}
+
+sub jump {
+ my $self = shift;
+ my $i = @_ == 1 ? shift : 1;
+ my $path = $self->path;
+ 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
+ for (my $j = $#$path; $j >= 0; $j --) {
+ if ($path->[$j] eq $i) {
+ $i = $j - $path_i;
+ last;
+ }
+ }
+ }
+ }
+ if ($i !~ /^-?\d+$/) {
+ require Carp;
+ Carp::croak("Invalid jump index ($i)");
+ }
+
+ ### 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];
+ }
+ $self->replace_path(@replace);
+
+ ### record the number of jumps
+ $self->{'jumps'} ||= 0;
+ $self->{'jumps'} ++;
+
+ ### run the newly fixed up path (recursively)
+ $self->{'path_i'} ++; # move along now that the path is updated
+ $self->nav_loop;
+ $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];
+ 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;
- die "previous_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) - 1 );
+ my $self = shift;
+ return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
}
sub current_step {
- my $self = shift;
- die "current_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) );
+ my $self = shift;
+ return $self->step_by_path_index( ($self->{'path_i'} || 0) );
}
-sub next_step {
- my $self = shift;
- die "next_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) + 1 );
+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;
- die "last_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( $#{ $self->path } );
+ my $self = shift;
+ return $self->step_by_path_index( $#{ $self->path } );
}
sub first_step {
- my $self = shift;
- die "first_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( 0 );
+ 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 pre_loop {}
-sub post_loop {}
-
-### return the appropriate hook to call
-sub hook {
- my $self = shift;
- my $hook = shift || do { require Carp; Carp::confess("Missing hook name") };
- my $step = shift || '';
- my $default = shift;
- my $hist = $self->history;
- my $code;
- if ($step && ($code = $self->can("${step}_${hook}"))) {
- push @$hist, "$step - $hook - ${step}_${hook}";
- return $code;
- } elsif ($code = $self->can($hook)) {
- push @$hist, "$step - $hook - $hook";
- return $code;
- } elsif (UNIVERSAL::isa($default, 'CODE')) {
- push @$hist, "$step - $hook - DEFAULT CODE";
- return $default;
- } elsif ($default) {
- push @$hist, "$step - $hook - DEFAULT";
- return sub { return $default };
- } else {
- return sub {};
- }
-}
-
-### get and call the appropriate hook
sub run_hook {
- my $self = shift;
- my $hook = shift;
- my $step = shift;
- my $default = shift;
- my $code = $self->hook($hook, $step, $default);
- return $self->$code($step, @_);
+ 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'} ||= [];
}
-### default die handler - show what happened and die (so its in the error logs)
-sub handle_error {
- my $self = shift;
- my $err = shift;
- debug $err, $self->path, $self->history;
- die $err;
+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 (! 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 modules for jeckyl/hyde on self
+### utility methods to allow for storing separate steps in other modules
sub allow_morph {
my $self = shift;
@@ -469,1472 +497,663 @@ sub allow_nested_morph {
}
sub morph {
- my $self = shift;
- my $step = shift || return;
- return if ! (my $allow = $self->allow_morph); # not true
-
- ### 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 = $self->history;
- push @$hist, "$step - morph - morph";
- my $sref = \$hist->[-1]; # get ref so we can add more info in a moment
-
- if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
- $$sref .= " - not allowed to morph to that step";
- return;
- }
-
- ### make sure we haven't already been reblessed
- if ($#$lin != 0 # is this the second morph call
- && (! ($allow = $self->allow_nested_morph) # not true
- || (ref($allow) && ! $allow->{$step}) # hash - but no step
- )) {
- $$sref .= $allow ? " - not allowed to nested_morph to that step" : " - nested_morph disabled";
- return; # just return - don't die so that we can morph early
- }
-
- ### 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;
- 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;
- $$sref .= " - changed $cur to $new";
- if (my $method = $self->can('fixup_after_morph')) {
- $self->$method($step);
- }
- } else {
- if ($@) {
- if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
- $$sref .= " - failed from $cur to $new: $1";
+ 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;
+
+ if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
+ $hist->{'found'} .= " (not allowed to morph to that step)";
+ return 0;
+ }
+
+ ### make sure we haven't already been reblessed
+ if ($#$lin != 0 # is this the second morph call
+ && (! ($allow = $self->allow_nested_morph($step)) # not true
+ || (ref($allow) && ! $allow->{$step}) # hash - but no step
+ )) {
+ $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
+ return 0; # just return - don't die so that we can morph early
+ }
+
+ ### 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;
+ 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;
+ $hist->{'found'} .= " (changed $cur to $new)";
+ $self->fixup_after_morph($step);
} else {
- $$sref .= " - failed from $cur to $new: $@";
- my $err = "Trouble while morphing to $file: $@";
- debug $err;
- warn $err;
+ 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;
+ }
+ }
}
- }
}
- }
+ $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) || die "unmorph called more times than morph - current ($cur)";
-
- ### if we are not already that package - bless us there
- my $hist = $self->history;
- if ($cur ne $prev) {
- if (my $method = $self->can('fixup_before_unmorph')) {
- $self->$method($step);
+ 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)";
}
- bless $self, $prev;
- push @$hist, "$step - unmorph - unmorph - changed from $cur to $prev";
- } else {
- push @$hist, "$step - unmorph - unmorph - already isa $cur";
- }
- return $self;
+ $hist->{'response'} = 1;
+ return $self;
}
-###----------------------------------------------------------------###
-### allow for cleanup including deep nested objects
+sub fixup_after_morph {}
-sub cleanup {
- my $self = shift;
- ref($self)->cleanup_cross_references($self);
-}
-
-sub cleanup_cross_references {
- my $class = shift;
- my $self = shift;
- my $seen = shift || {};
- return if $seen->{$self}; # prevent recursive checking
- $seen->{$self} = 1;
- return if $CLEANUP_EXCLUDE{ ref($self) };
- if (UNIVERSAL::isa($self, 'HASH')) {
- require Scalar::Util; # first self will always be hash
- foreach my $key (keys %$self) {
- next if ! $self->{$key};
- $class->cleanup_cross_references($self->{$key}, $seen);
- # weaken and remove blessed objects
- # this will clober objects in global caches that are referenced in the structure
- # so beware (that means weaken your cached references)
- if (Scalar::Util::blessed($self->{$key})
- && ! Scalar::Util::isweak($self->{$key})) {
- Scalar::Util::weaken($self->{$key});
- $self->{$key} = undef;
- } elsif (UNIVERSAL::isa($self->{$key}, 'CODE')) {
- $self->{$key} = undef;
- }
- }
- } elsif (UNIVERSAL::isa($self, 'ARRAY')) {
- for my $key (0 .. $#$self) {
- next if ! $self->[$key];
- $class->cleanup_cross_references($self->[$key], $seen);
- if (Scalar::Util::blessed($self->[$key])
- && ! Scalar::Util::isweak($self->[$key])) {
- Scalar::Util::weaken($self->[$key]);
- $self->[$key] = undef;
- } elsif (UNIVERSAL::isa($self->[$key], 'CODE')) {
- $self->[$key] = undef;
- }
- }
- }
-}
+sub fixup_before_unmorph {}
###----------------------------------------------------------------###
-### a few standard base accessors
-
-sub form {
- my $self = shift;
- if ($#_ != -1) {
- $self->{form} = shift || die "Invalid form";
- }
- return $self->{form} ||= $self->cgix->get_form;
-}
-
-sub cookies {
- my $self = shift;
- if ($#_ != -1) {
- $self->{cookies} = shift || die "Invalid cookies";
- }
- return $self->{cookies} ||= $self->cgix->get_cookies;
-}
+### allow for authentication
-sub cgix {
- my $self = shift;
- return $self->{cgix} ||= do {
- my $args = shift || {};
- require CGI::Ex;
- CGI::Ex->new($args); # return of the do
- };
-}
+sub navigate_authenticated {
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
-sub set_cgix {
- my $self = shift;
- $self->{cgix} = shift;
-}
+ $self->require_auth(1);
-sub vob {
- my $self = shift;
- return $self->{vob} ||= do {
- my $args = shift || {};
- $args->{cgix} ||= $self->cgix;
- require CGI::Ex::Validate;
- CGI::Ex::Validate->new($args); # return of the do
- };
-}
-
-sub set_vob {
- my $self = shift;
- $self->{vob} = shift;
+ return $self->navigate;
}
-sub auth {
- my $self = shift;
- return $self->{auth} ||= do {
- my $args = shift || {};
- $args->{cgix} ||= $self->cgix,
- $args->{form} ||= $self->form,
- $args->{cookies} ||= $self->cookies,
- require CGI::Ex::Auth;
- CGI::Ex::Auth->new($args); # return of the do
- };
+sub require_auth {
+ my $self = shift;
+ $self->{'require_auth'} = shift if @_ == 1;
+ return $self->{'require_auth'};
}
-sub set_auth {
- my $self = shift;
- $self->{auth} = shift;
-}
+sub is_authed { shift->auth_data }
-### provide a place for placing variables
-sub stash {
- my $self = shift;
- return $self->{'stash'} ||= {};
-}
-
-### allow for adding arbitrary values to self
-sub add_property {
- my $self = shift;
- my $prop = shift;
- my $key = '__prop_'. $prop;
- my $name = __PACKAGE__ ."::". $prop;
- no strict 'refs';
- *$name = sub : lvalue {
+sub auth_data {
my $self = shift;
- $self->{$key} = shift() if $#_ != -1;
- $self->{$key};
- } if ! defined &$name;
- $self->$prop(shift()) if $#_ != -1;
+ $self->{'auth_data'} = shift if @_ == 1;
+ return $self->{'auth_data'};
}
-###----------------------------------------------------------------###
-### js_validation items
-
-### creates javascript suitable for validating the form
-sub js_validation {
- my $self = shift;
- my $step = shift;
- return '' if $self->ext_val eq 'htm'; # let htm validation do it itself
+sub get_valid_auth {
+ my $self = shift;
+ return 1 if $self->is_authed;
+
+ ### augment the args with sensible defaults
+ my $args = $self->auth_args;
+ $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 $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 $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 == -1;
+ require CGI::Ex::Auth;
+ my $obj = CGI::Ex::Auth->new($args);
+ my $resp = $obj->get_valid_auth;
- return $self->vob->generate_js($hash_val, $form_name, $js_uri);
-}
+ 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
-### where to find the javascript files
-### default to using this script as a handler
-sub js_uri_path {
- my $self = shift;
- my $script = $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME";
- return ($self->can('path') == \&CGI::Ex::App::path)
- ? $script . '/js' # try to use a cache friendly URI (if path is our own)
- : $script . '?'.$self->step_key.'=js&js='; # use one that works with more paths
+ return ($resp && $data) ? 1 : 0;
}
-### name to attach js validation to
-sub form_name { 'theform' }
+sub auth_args { {} }
-### provide some rudimentary javascript support
-### if valid_steps is defined - it should include "js"
-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'} || '';
- $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
-
- $self->cgix->print_js($file);
- return 1; # intercepted
-}
+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 }
###----------------------------------------------------------------###
-### implementation specific subs
+### a few standard base accessors
-sub template_args {
- my $self = shift;
- my $step = shift;
- return {
- INCLUDE_PATH => $self->base_dir_abs,
- };
+sub form {
+ my $self = shift;
+ $self->{'form'} = shift if @_ == 1;
+ return $self->{'form'} ||= $self->cgix->get_form;
}
-sub print {
- my $self = shift;
- my $step = shift;
- my $swap = shift;
- my $fill = shift;
-
- ### get a filename relative to base_dir_abs
- my $file = $self->run_hook('file_print', $step);
-
- require Template;
- my $t = Template->new($self->template_args($step));
-
- ### process the document
- my $out = '';
- my $status = $t->process($file, $swap, \$out) || die $Template::ERROR;
-
- ### fill in any forms
- $self->cgix->fill(\$out, $fill) if $fill && ! $self->{no_fill};
-
- ### now print
- $self->cgix->print_content_type();
- print $out;
+sub cookies {
+ my $self = shift;
+ $self->{'cookies'} = shift if @_ == 1;
+ return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
-sub base_dir_rel {
- my $self = shift;
- $self->{base_dir_rel} = shift if $#_ != -1;
- return $self->{base_dir_rel} ||= $BASE_DIR_REL;
+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 base_dir_abs {
- my $self = shift;
- $self->{base_dir_abs} = shift if $#_ != -1;
- return $self->{base_dir_abs} || $BASE_DIR_ABS
- || die "\$BASE_DIR_ABS not set for use in stub functions";
+sub vob {
+ my $self = shift;
+ $self->{'vob'} = shift if @_ == 1;
+ return $self->{'vob'} ||= do {
+ require CGI::Ex::Validate;
+ CGI::Ex::Validate->new($self->vob_args); # return of the do
+ };
}
-sub ext_val {
- my $self = shift;
- $self->{ext_val} = shift if $#_ != -1;
- return $self->{ext_val} || $EXT_VAL || die "\$EXT_VAL not set for use in stub functions";
+sub vob_args {
+ my $self = shift;
+ return {
+ cgix => $self->cgix,
+ };
}
-sub ext_print {
- my $self = shift;
- $self->{ext_print} = shift if $#_ != -1;
- return $self->{ext_print} || $EXT_PRINT || die "\$EXT_PRINT not set for use in stub functions";
+### provide a place for placing variables
+sub stash {
+ my $self = shift;
+ return $self->{'stash'} ||= {};
}
-sub has_errors {
- my $self = shift;
- return 1 if scalar keys %{ $self->hash_errors };
-}
+sub clear_app {
+ my $self = shift;
-sub format_error {
- my $self = shift;
- my $error = shift;
-# return $error if $error =~ /$error";
+ 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 stub subs
+### default hook implementations
-### used for looking up a module to morph into
-sub morph_package {
- 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;
-}
+sub path_info_map { }
-sub base_name_module {
- my $self = shift;
- $self->{base_name_module} = shift if $#_ != -1;
- return $self->{base_name_module} ||= $BASE_NAME_MODULE;
-}
+sub run_step {
+ my $self = shift;
+ my $step = shift;
-### used for looking up template content
-sub name_module {
- my $self = shift;
- my $step = shift || '';
- my $name;
- if ($name = $self->base_name_module) {
- return $name;
- } else {
- return ($0 =~ m/(\w+)(\.\w+)?$/) ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl
- : die "Couldn't determine module name from \"name_module\" lookup ($step)";
- }
-}
+ ### if the pre_step exists and returns true, exit the nav_loop
+ return 1 if $self->run_hook('pre_step', $step);
-### which file is used for templating
-sub file_print {
- my $self = shift;
- my $step = shift;
+ ### allow for skipping this step (but stay in the nav_loop)
+ return 0 if $self->run_hook('skip', $step);
- my $base_dir_rel = $self->base_dir_rel;
- my $module = $self->run_hook('name_module', $step);
- my $_step = $self->run_hook('name_step', $step, $step);
- my $ext = $self->ext_print;
+ ### 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)) {
- return "$base_dir_rel/$module/$_step.$ext";
-}
+ ### show the page requesting the information
+ $self->run_hook('prepared_print', $step);
-### which file is used for validation
-sub file_val {
- my $self = shift;
- my $step = shift;
+ ### a hook after the printing process
+ $self->run_hook('post_print', $step);
- my $base_dir = $self->base_dir_rel;
- my $module = $self->run_hook('name_module', $step);
- my $_step = $self->run_hook('name_step', $step, $step);
- my $ext = $self->ext_val;
+ return 1;
+ }
- ### get absolute if necessary
- if ($base_dir !~ m|^/|) {
- $base_dir = $self->base_dir_abs . "/$base_dir";
- }
+ ### 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);
- return "$base_dir/$module/$_step.$ext";
+ ### 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
-sub info_complete {
- my $self = shift;
- my $step = shift;
-
- return 0 if ! $self->run_hook('ready_validate', $step);
-
- return $self->run_hook('validate', $step);
+ 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 ready_validate {
- my $self = shift;
- my $step = shift;
+sub prepared_print {
+ my $self = shift;
+ my $step = shift;
- ### could do a slightly more complex test
- return 0 if ! $ENV{REQUEST_METHOD} || $ENV{REQUEST_METHOD} ne 'POST';
- return 1;
-}
+ 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) || {};
-sub set_ready_validate {
- my $self = shift;
- my $ready = shift;
- $ENV{REQUEST_METHOD} = ($ready) ? 'POST' : 'GET';
-}
+ ### fix up errors
+ $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
+ foreach keys %$hash_errs;
+ $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
-sub validate {
- my $self = shift;
- my $step = shift;
- my $form = shift || $self->form;
- my $hash = $self->run_hook('hash_validation', $step, {});
- my $what_was_validated = [];
-
- my $eob = eval { $self->vob->validate($form, $hash, $what_was_validated) };
- if (! $eob && $@) {
- die "Step $step: $@";
- }
-
- ### had an error - store the errors and return false
- if ($eob) {
- $self->add_errors($eob->as_hash({
- as_hash_join => "
\n",
- as_hash_suffix => '_error',
- }));
- return 0;
- }
-
- ### allow for the validation to give us some redirection
- my $val;
- OUTER: foreach my $ref (@$what_was_validated) {
- foreach my $method (qw(append_path replace_path insert_path)) {
- next if ! ($val = $ref->{$method});
- $self->$method(ref $val ? @$val : $val);
- last OUTER;
- }
- }
+ ### 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};
- return 1;
+ ### run the print hook - passing it the form and fill info
+ $self->run_hook('print', $step, $swap, $fill);
}
-### allow for using ConfUtil instead of yaml
-sub hash_validation {
- my $self = shift;
- my $step = shift;
- 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;
+sub print {
+ my ($self, $step, $swap, $fill) = @_;
- ### read the file - it it fails - errors should shown in the error logs
- } elsif ($file) {
- $hash = eval { $self->vob->get_validation($file) } || {};
+ my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
- } else {
- $hash = {};
- }
+ my $out = $self->run_hook('swap_template', $step, $file, $swap);
- $hash; # return of the do
- };
-}
+ $self->run_hook('fill_template', $step, \$out, $fill);
-sub hash_base {
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{'SCRIPT_NAME'} || $0,
- path_info => $ENV{'PATH_INFO'} || '',
- js_validation => sub { $self->run_hook('js_validation', $step, shift) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
+ $self->run_hook('print_out', $step, $out);
}
-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'} ||= {} }
+sub print_out {
+ my ($self, $step, $out) = @_;
-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;
+ $self->cgix->print_content_type;
+ print $out;
}
-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 swap_template {
+ my ($self, $step, $file, $swap) = @_;
-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;
-}
+ my $args = $self->run_hook('template_args', $step);
+ 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 = '';
-sub forbidden_info_complete { 0 }
+ $t->process($file, $swap, \$out) || die $t->error;
-sub forbidden_file_print {
- my $self = shift;
- my $step = $self->stash->{'forbidden_step'};
- my $str = "You do not have access to \"$step\"";
- return \$str;
+ return $out;
}
-###----------------------------------------------------------------###
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Ex::App - Full featured (within reason) application builder.
-
-=head1 DESCRIPTION
-
-Fill in the blanks and get a ready made CGI. This module is somewhat
-similar in spirit to CGI::Application, CGI::Path, and CGI::Builder and any
-other "CGI framework." As with the others, CGI::Ex::App tries to do as
-much as possible, in a simple manner, without getting in the
-developer's way. Your milage may vary.
-
-=head1 SYNOPSIS
-
-More examples will come with time. Here are the basics for now.
-
- #!/usr/bin/perl -w
-
- MyApp->navigate;
- # OR you could do the following which cleans
- # circular references - useful for a mod_perl situation
- # MyApp->navigate->cleanup;
- exit;
-
- package MyApp;
- use strict;
- use base qw(CGI::Ex::App);
- use CGI::Ex::Dump qw(debug);
-
- sub valid_steps { return {success => 1, js => 1} }
- # default_step (main) is a valid path
- # note the inclusion of js step to allow the
- # javascript scripts in js_validation to function properly.
-
- # base_dir_abs is only needed if default print is used
- # template toolkit needs an INCLUDE_PATH
- sub base_dir_abs { '/tmp' }
-
- sub main_file_print {
- # reference to string means ref to content
- # non-reference means filename
- return \ "