package CGI::Ex::App;
-### CGI Extended Application
-
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# See the perldoc in CGI/Ex/App.pod
+# Copyright 2006 - 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.00';
- ### 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};
}
+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 navigate {
- my $self = shift;
- my $args = ref($_[0]) ? shift : {@_};
- $self = $self->new($args) if ! ref $self;
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
- eval {
+ $self->{'_time'} = time;
- ### a chance to do things at the very beginning
- return $self if $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
- 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($@);
- }
+ };
+ $self->handle_error($@) if $@; # catch any errors
+
+ $self->{'_time'} = time;
- return $self;
+ 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
-
- ### run the default step as a last resort
- $self->insert_path($self->default_step);
- $self->nav_loop; # go recursive
+ ### 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
- return;
-}
+ ### allow for per-step authentication
+ if ($req_auth
+ && $req_auth->{$step}
+ && ! $self->get_valid_auth) {
+ return;
+ }
-sub pre_navigate {}
+ ### allow for becoming another package (allows for some steps in external files)
+ $self->morph($step);
-sub post_navigate {}
+ ### run the guts of the step
+ my $status = $self->run_hook('run_step', $step);
-sub recurse_limit { shift->{'recurse_limit'} || $RECURSE_LIMIT || 15 }
+ $self->unmorph($step);
-sub run_step {
- my $self = shift;
- my $step = shift;
+ ### Allow for the run_step to intercept.
+ ### A true status means the run_step took over navigation.
+ return if $status;
+ }
- ### 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;
-
- ### 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};
- $fill = {} if $self->no_fill($step);
+ my $err = shift;
- ### run the print hook - passing it the form and fill info
- $self->run_hook('print', $step, undef,
- $swap, $fill);
+ die $err;
}
-sub no_fill { shift->{'no_fill'} }
-
-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 default_step { shift->{'default_step'} || 'main' }
-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;
- }
- }
- }
- }
- 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 js_step { shift->{'js_step'} || 'js' }
-###----------------------------------------------------------------###
+sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
-sub step_key {
- my $self = shift;
- return $self->{'step_key'} || 'step';
-}
+sub step_key { shift->{'step_key'} || 'step' }
-### 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);
+ my $self = shift;
+ 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+)|;
+
+ ### make sure the step is valid
+ 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;
+ }
+ }
}
- \@path; # return of the do
- };
+ return $self->{'path'};
}
-### 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;
+ croak "previous_step is readonly" if $#_ != -1;
+ 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;
+ croak "current_step is readonly" if $#_ != -1;
+ 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 );
+ 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;
- die "last_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( $#{ $self->path } );
+ my $self = shift;
+ croak "last_step is readonly" if $#_ != -1;
+ 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;
+ croak "first_step is readonly" if $#_ != -1;
+ 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}";
+ }
+
+
+ ### 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;
}
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;
+ return if ! (my $allow = $self->allow_morph($step));
+
+ ### 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,
+ };
+ 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;
+ }
+
+ ### 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; # 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;
+ }
+ }
}
- }
}
- }
}
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,
+ };
+ 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;
+ return $self;
}
+sub fixup_after_morph {}
+
+sub fixup_before_unmorph {}
+
###----------------------------------------------------------------###
-### allow for cleanup including deep nested objects
+### allow for authentication
-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 navigate_authenticated {
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
+
+ $self->require_auth(1);
+
+ return $self->navigate;
}
+sub require_auth {
+ my $self = shift;
+ $self->{'require_auth'} = shift if @_ == 1;
+ return $self->{'require_auth'};
+}
+
+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;
+
+ ### 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);
+ };
+
+ 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 form {
- my $self = shift;
- if ($#_ != -1) {
- $self->{form} = shift || die "Invalid form";
- }
- return $self->{form} ||= $self->cgix->get_form;
+ my $self = shift;
+ $self->{'form'} = shift if @_ == 1;
+ 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;
+ my $self = shift;
+ $self->{'cookies'} = shift if @_ == 1;
+ return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
sub cgix {
- my $self = shift;
- return $self->{cgix} ||= do {
- my $args = shift || {};
- require CGI::Ex;
- CGI::Ex->new($args); # return of the do
- };
-}
-
-sub set_cgix {
- my $self = shift;
- $self->{cgix} = shift;
+ my $self = shift;
+ $self->{'cgix'} = shift if @_ == 1;
+ return $self->{'cgix'} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new; # return of the do
+ };
}
sub vob {
- my $self = shift;
- 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;
-}
-
-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
- };
+ 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 set_auth {
- my $self = shift;
- $self->{auth} = shift;
+sub vob_args {
+ my $self = shift;
+ return {
+ cgix => $self->cgix,
+ };
}
### 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 {
my $self = shift;
- $self->{$key} = shift() if $#_ != -1;
- $self->{$key};
- } if ! defined &$name;
- $self->$prop(shift()) if $#_ != -1;
+ return $self->{'stash'} ||= {};
}
###----------------------------------------------------------------###
-### js_validation items
+### default hook implementations
-### 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 run_step {
+ my $self = shift;
+ my $step = shift;
- 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;
+ ### if the pre_step exists and returns true, exit the nav_loop
+ return 1 if $self->run_hook('pre_step', $step);
- return $self->vob->generate_js($hash_val, $form_name, $js_uri);
-}
+ ### allow for skipping this step (but stay in the nav_loop)
+ return 0 if $self->run_hook('skip', $step);
-### 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
-}
+ ### 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)) {
-### name to attach js validation to
-sub form_name { 'theform' }
+ ### show the page requesting the information
+ $self->run_hook('prepared_print', $step);
-### provide some rudimentary javascript support
-### if valid_steps is defined - it should include "js"
-sub js_run_step {
- my $self = shift;
+ ### a hook after the printing process
+ $self->run_hook('post_print', $step);
- ### 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 : '';
+ return 1;
+ }
- $self->cgix->print_js($file);
- return 1; # intercepted
+ ### 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;
}
-###----------------------------------------------------------------###
-### implementation specific subs
+sub prepared_print {
+ my $self = shift;
+ my $step = shift;
-sub template_args {
- my $self = shift;
- my $step = shift;
- return {
- INCLUDE_PATH => $self->base_dir_abs,
- };
+ 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 = shift;
- my $step = shift;
- my $swap = shift;
- my $fill = shift;
+ my ($self, $step, $swap, $fill) = @_;
- ### get a filename relative to base_dir_abs
- my $file = $self->run_hook('file_print', $step);
+ my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
- require Template;
- my $t = Template->new($self->template_args($step));
+ my $out = $self->run_hook('swap_template', $step, $file, $swap);
- ### process the document
- my $out = '';
- my $status = $t->process($file, $swap, \$out) || die $Template::ERROR;
+ $self->run_hook('fill_template', $step, \$out, $fill);
- ### fill in any forms
- $self->cgix->fill(\$out, $fill) if $fill && ! $self->{no_fill};
-
- ### now print
- $self->cgix->print_content_type();
- print $out;
+ $self->run_hook('print_out', $step, $out);
}
-sub base_dir_rel {
- my $self = shift;
- $self->{base_dir_rel} = shift if $#_ != -1;
- return $self->{base_dir_rel} ||= $BASE_DIR_REL;
-}
+sub print_out {
+ my ($self, $step, $out) = @_;
-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";
+ $self->cgix->print_content_type();
+ print $out;
}
-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 swap_template {
+ my ($self, $step, $file, $swap) = @_;
-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";
+ require CGI::Ex::Template;
+ my $args = $self->run_hook('template_args', $step);
+ my $t = CGI::Ex::Template->new($args);
+
+ my $out = '';
+ $t->process($file, $swap, \$out) || die $t->error;
+
+ return $out;
}
-sub has_errors {
- my $self = shift;
- return 1 if scalar keys %{ $self->hash_errors };
+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 format_error {
- my $self = shift;
- my $error = shift;
-# return $error if $error =~ /<span/i;
-# return "<span class=\"error\">$error</span>";
+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);
}
-###----------------------------------------------------------------###
-### default stub subs
+sub fill_args { {} }
-### 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 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 } # success indicates we handled step (don't continue loop)
+sub post_step { 0 } # success indicates we handled step (don't continue step or loop)
+
+sub name_step {
+ my ($self, $step) = @_;
+ return $step;
}
-sub base_name_module {
- my $self = shift;
- $self->{base_name_module} = shift if $#_ != -1;
- return $self->{base_name_module} ||= $BASE_NAME_MODULE;
+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;
}
-### 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)";
- }
+ my $self = shift;
+ my $step = shift || '';
+
+ return $self->{'name_module'} ||= do {
+ # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
+ my $script = $ENV{'SCRIPT_NAME'} || $0;
+ $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
+ $1; # return of the do
+ };
}
-### which file is used for templating
sub file_print {
- my $self = shift;
- my $step = shift;
+ my $self = shift;
+ my $step = shift;
- 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;
+ 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_print if $_step !~ /\.\w+$/;
- return "$base_dir_rel/$module/$_step.$ext";
+ foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+
+ return $base_dir . $module . $_step;
}
-### which file is used for validation
sub file_val {
- my $self = shift;
- my $step = shift;
+ my $self = shift;
+ my $step = shift;
- 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;
+ my $abs = $self->base_dir_abs || return {};
+ my $base_dir = $self->base_dir_rel;
+ my $module = $self->run_hook('name_module', $step);
+ my $_step = $self->run_hook('name_step', $step);
+ $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
- ### get absolute if necessary
- if ($base_dir !~ m|^/|) {
- $base_dir = $self->base_dir_abs . "/$base_dir";
- }
+ foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
- return "$base_dir/$module/$_step.$ext";
+ return $abs . $base_dir . $module . $_step;
}
-
sub info_complete {
- my $self = shift;
- my $step = shift;
-
- return 0 if ! $self->run_hook('ready_validate', $step);
+ my $self = shift;
+ my $step = shift;
- return $self->run_hook('validate', $step);
+ return 0 if ! $self->run_hook('ready_validate', $step);
+ return 0 if ! $self->run_hook('validate', $step);
+ return 1;
}
sub ready_validate {
- my $self = shift;
- my $step = shift;
+ 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;
+ return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
}
sub set_ready_validate {
- my $self = shift;
- my $ready = shift;
- $ENV{REQUEST_METHOD} = ($ready) ? 'POST' : 'GET';
+ my ($self, $ready) = @_;
+ $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET';
}
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 => "<br>\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;
+ my $self = shift;
+ my $step = shift;
+ my $form = shift || $self->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) };
+ die "Step $step: $@" if $@ && ! $err_obj;
+
+ ### had an error - store the errors and return false
+ if ($err_obj) {
+ $self->add_errors($err_obj->as_hash({
+ as_hash_join => "<br>\n",
+ as_hash_suffix => '_error',
+ }));
+ return 0;
}
- }
- return 1;
+ ### allow for the validation to give us some redirection
+ foreach my $ref (@$what_was_validated) {
+ foreach my $method (qw(append_path replace_path insert_path)) {
+ next if ! (my $val = $ref->{$method});
+ $self->$method(ref $val ? @$val : $val);
+ }
+ }
+
+ 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);
}
-### allow for using ConfUtil instead of yaml
+sub form_name { 'theform' }
+
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);
+ my ($self, $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;
+ return $self->{'hash_validation'}->{$step} ||= do {
+ my $hash;
+ my $file = $self->run_hook('file_val', $step);
- ### read the file - it it fails - errors should shown in the error logs
- } elsif ($file) {
- $hash = eval { $self->vob->get_validation($file) } || {};
+ ### 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;
- } else {
- $hash = {};
- }
+ ### read the file - if it fails - errors should be in the webserver error logs
+ } elsif ($file) {
+ $hash = eval { $self->vob->get_validation($file) } || {};
+
+ } else {
+ $hash = {};
+ }
- $hash; # return of the do
+ $hash; # return of the do
};
}
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) },
- };
+ my ($self, $step) = @_;
+
+ 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 $hash = {
+ script_name => $ENV{'SCRIPT_NAME'} || $0,
+ path_info => $ENV{'PATH_INFO'} || '',
+ js_validation => sub { $copy->run_hook('js_validation', $step, shift) },
+ form_name => sub { $copy->run_hook('form_name', $step) },
+ $self->step_key => $step,
+ }; # return of the do
+ };
}
sub hash_common { shift->{'hash_common'} ||= {} }
sub hash_swap { shift->{'hash_swap'} ||= {} }
sub hash_errors { shift->{'hash_errors'} ||= {} }
+###----------------------------------------------------------------###
+### routines to support the base hooks
+
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} .= '<br>' . $args->{$key};
- } else {
- $hash->{$_key} = $args->{$key};
+ 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} .= '<br>' . $args->{$key};
+ } else {
+ $hash->{$_key} = $args->{$key};
+ }
}
- }
- $hash->{'has_errors'} = 1;
+ $hash->{'has_errors'} = 1;
+}
+
+sub has_errors { scalar keys %{ shift->hash_errors } }
+
+sub format_error {
+ my ($self, $error) = @_;
+ return $error;
}
sub add_to_errors { shift->add_errors(@_) }
sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) }
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 $self = shift;
+ my $old = shift;
+ my $new = shift;
+ $new = {$new, @_} if ! ref $new; # non-hashref
+ $old->{$_} = $new->{$_} foreach keys %$new;
}
-###----------------------------------------------------------------###
-
-sub forbidden_info_complete { 0 }
-sub forbidden_file_print {
- my $self = shift;
- my $step = $self->stash->{'forbidden_step'};
- my $str = "You do not have access to \"$step\"";
- return \$str;
+sub base_dir_rel {
+ my $self = shift;
+ $self->{'base_dir_rel'} = shift if $#_ != -1;
+ return $self->{'base_dir_rel'} || '';
}
-###----------------------------------------------------------------###
-
-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 \ "<h1>Main Step</h1>
- <form method=post name=[% form_name %]>
- <input type=text name=foo>
- <span style='color:red' id=foo_error>[% foo_error %]</span><br>
- <input type=submit>
- </form>
- [% js_validation %]
- <a href='[% script_name %]?step=foo'>Link to forbidden step</a>
- ";
- }
-
- sub post_print {
- debug shift->history;
- } # show what happened
-
- sub main_file_val {
- # reference to string means ref to yaml document
- # non-reference means filename
- return \ "foo:
- required: 1
- min_len: 2
- max_len: 20
- match: 'm/^([a-z]\\d)+[a-z]?\$/'
- match_error: Characters must alternate letter digit letter.
- \n";
- }
-
- sub main_finalize {
+sub base_dir_abs {
my $self = shift;
+ $self->{'base_dir_abs'} = shift if $#_ != -1;
+ return $self->{'base_dir_abs'} || '';
+}
- debug $self->form, "Do something useful with form here";
-
- ### add success step
- $self->add_to_swap({success_msg => "We did something"});
- $self->append_path('success');
- $self->set_ready_validate(0);
- return 1;
- }
-
- sub success_file_print {
- \ "<h1>Success Step</h1> All done.<br>
- ([% success_msg %])<br>
- (foo = [% foo %])";
- }
-
- ### not necessary - this is the default hash_base
- sub hash_base { # used to include js_validation
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{SCRIPT_NAME} || '',
- js_validation => sub { $self->run_hook('js_validation', $step) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
- }
-
- __END__
-
-Note: This example would be considerably shorter if the html file
-(file_print) and the validation file (file_val) had been placed in
-separate files. Though CGI::Ex::App will work "out of the box" as
-shown it is more probable that any platform using it will customize
-the various hooks to their own tastes (for example, switching print to
-use a system other than Template::Toolkit).
-
-=head1 HOOKS / METHODS
-
-CGI::Ex::App works on the principles of hooks which are essentially
-glorified method lookups. When a hook is called, CGI::Ex::App will
-look for a corresponding method call for that hook for the current
-step name. See the discussion under the method named "hook" for more
-details. The methods listed below are normal method calls.
-Hooks and methods are looked for in the following order:
-
-=over 4
-
-=item Method C<-E<gt>new>
-
-Object creator. Takes a hash or hashref.
-
-=item Method C<-E<gt>init>
-
-Called by the default new method. Allows for any object
-initilizations.
-
-=item Method C<-E<gt>form>
-
-Returns a hashref of the items passed to the CGI. Returns
-$self->{form}. Defaults to CGI::Ex::get_form.
-
-=item Method C<-E<gt>navigate>
-
-Takes a class name or a CGI::Ex::App object as arguments. If a class
-name is given it will instantiate an object by that class. All returns
-from navigate will return the object.
-
-The method navigate is essentially a safe wrapper around the ->nav_loop
-method. It will catch any dies and pass them to ->handle_error.
-
-=item Method C<-E<gt>nav_loop>
-
-This is the main loop runner. It figures out the current path
-and runs all of the appropriate hooks for each step of the path. If
-nav_loop runs out of steps to run (which happens if no path is set, or if
-all other steps run successfully), it will insert the ->default_step into
-the path and run nav_loop again (recursively). This way a step is always
-assured to run. There is a method ->recurse_limit (default 15) that
-will catch logic errors (such as inadvertently running the same
-step over and over and over).
-
-The basic outline of navigation is as follows (the default actions for hooks
-are shown):
-
- navigate {
- eval {
- ->pre_navigate
- ->nav_loop
- ->post_navigate
- }
- # dying errors will run the ->handle_error method
- }
-
-
- nav_loop {
- ->path (get the path steps)
- # DEFAULT ACTION
- # look in $ENV{'PATH_INFO'}
- # look in ->form for ->step_key
-
- ->pre_loop
- # navigation stops if true
-
- ->valid_steps (get list of valid paths)
-
- foreach step of path {
-
- # check that path is valid
-
- ->morph
- # DEFAULT ACTION
- # check ->allow_morph
- # check ->allow_nested_morph
- # ->morph_package (hook - get the package to bless into)
- # ->fixup_after_morph if morph_package exists
-
- ->run_step (hook)
-
- ->unmorph
- # DEFAULT ACTION
- # ->fixup_before_unmorph if blessed to previous package
-
- # exit loop if ->run_step returned true (intercepted)
-
- } end of step foreach
-
- ->post_loop
- # navigation stops if true
-
- ->default_step (inserted into path at current location)
- ->nav_loop (called again recursively)
-
- } end of nav_loop
-
-
- run_step {
- ->pre_step (hook)
- # exits nav_loop if true
-
- ->skip (hook)
- # skips this step if true (stays in nav_loop)
-
- ->prepare (hook - defaults to true)
-
- ->info_complete (hook - ran if prepare was true)
- # DEFAULT ACTION
- # ->ready_validate (hook)
- # return false if ! ready_validate
- # ->validate (hook)
- # ->hash_validation (hook)
- # ->file_val (hook - uses base_dir_rel, name_module, name_step, ext_val)
- # uses CGI::Ex::Validate to validate the hash
- # returns true if validate is true
-
- ->finalize (hook - defaults to true - ran if prepare and info_complete were true)
-
- if ! ->prepare || ! ->info_complete || ! ->finalize {
- ->prepared_print
- # DEFAULT ACTION
- # ->hash_base (hook)
- # ->hash_common (hook)
- # ->hash_form (hook)
- # ->hash_fill (hook)
- # ->hash_swap (hook)
- # ->hash_errors (hook)
- # merge form, base, common, and fill into merged fill
- # merge form, base, common, swap, and errors into merged swap
- # ->print (hook - passed current step, merged swap hash, and merged fill)
- # DEFAULT ACTION
- # ->file_print (hook - uses base_dir_rel, name_module, name_step, ext_print)
- # ->template_args
- # Processes the file with Template Toolkit
- # Fills the any forms with CGI::Ex::Fill
- # Prints headers and the content
-
- ->post_print (hook - used for anything after the print process)
-
- # return true to exit from nav_loop
- }
-
- ->post_step (hook)
- # exits nav_loop if true
-
- } end of run_step
-
-
-=item Method C<-E<gt>pre_navigate>
-
-Called from within navigate. Called before the nav_loop method is started.
-If a true value is returned then navigation is skipped (the nav_loop is never
-started).
-
-=item Method C<-E<gt>post_navigate>
-
-Called from within navigate. Called after the nav_loop has finished running.
-Will only run if there were no errors which died during the nav_loop
-process.
-
-=item Method C<-E<gt>handle_error>
-
-If anything dies during execution, handle_error will be called with
-the error that had happened. Default is to debug the error and path
-history.
-
-=item Method C<-E<gt>history>
-
-Returns an arrayref of which hooks of which steps of the path were ran.
-Useful for seeing what happened. In general - each line of the history
-will show the current step, the hook requested, and which hook was
-actually called. (hooks that don't find a method don't add to history)
-
-=item Method C<-E<gt>path>
-
-Return an arrayref (modifyable) of the steps in the path. For each
-step the remaining hooks can be run. Hook methods are looked up and
-ran using the method "run_hook" which uses the method "hook" to lookup
-the hook. A history of ran hooks is stored in the array ref returned
-by $self->history. Default will be a single step path looked up in
-$form->{path} or in $ENV{PATH_INFO}. By default, path will look for
-$ENV{'PATH_INFO'} or the value of the form by the key step_key. For
-the best functionality, the arrayref returned should be the same
-reference returned for every call to path - this ensures that other
-methods can add to the path (and will most likely break if the
-arrayref is not the same). If navigation runs out of steps to run,
-the default step found in default_step will be run.
-
-=item Method C<-E<gt>default_step>
-
-Step to show if the path runs out of steps. Default value is the
-'default_step' property or the value 'main'.
-
-=item Method C<-E<gt>step_key>
-
-Used by default to determine which step to put in the path. The
-default path will only have one step within it
-
-=item Method C<-E<gt>set_path>
-
-Arguments are the steps to set. Should be called before navigation
-begins. This will set the path arrayref to the passed steps.
-
-=item Method C<-E<gt>append_path>
-
-Arguments are the steps to append. Can be called any time. Adds more
-steps to the end of the current path.
-
-=item Method C<-E<gt>replace_path>
-
-Arguments are the steps used to replace. Can be called any time.
-Replaces the remaining steps (if any) of the current path.
-
-=item Method C<-E<gt>insert_path>
-
-Arguments are the steps to insert. Can be called any time. Inserts
-the new steps at the current path location.
-
-=item Method C<-E<gt>jump>
-
-This method should not normally be used. It provides for moving to the
-next step at any point during the nav_loop. It effectively short circuits
-the remaining hooks for the current step. It does increment the recursion
-counter (which has a limit of ->recurse_limit - default 15). It is normally
-better to allow the other hooks in the loop to carry on their normal functions
-and avoid jumping. (Essentially, this hook behaves like a goto method to
-bypass everything else and continue at a different location in the path - there
-are times when it is necessary or useful - but most of the time should be
-avoided)
-
-Jump takes a single argument which is the location in the path to jump
-to. This argument may be either a step name, the special words
-"FIRST, LAST, CURRENT, PREVIOUS, OR NEXT" or the number of steps to
-jump forward (or backward) in the path. The default value, 1,
-indicates that CGI::Ex::App should jump to the next step (the default action for
-jump). A value of 0 would repeat the current step (watch out for
-recursion). A value of -1 would jump to the previous step. The
-special value of "LAST" will jump to the last step. The special value
-of "FIRST" will jump back to the first step. In each of these cases,
-the path array retured by ->path is modified to allow for the jumping.
-
- ### goto previous step
- $self->jump($self->previous_step);
- $self->jump('PREVIOUS');
- $self->jump(-1);
-
- ### goto next step
- $self->jump($self->next_step);
- $self->jump('NEXT');
- $self->jump(1);
- $self->jump;
-
- ### goto current step (repeat)
- $self->jump($self->current_step);
- $self->jump('CURRENT');
- $self->jump(0);
-
- ### goto last step
- $self->jump($self->last_step);
- $self->jump('LAST');
-
- ### goto first step
- $self->jump($self->first_step);
- $self->jump('FIRST');
-
-=item Method C<-E<gt>exit_nav_loop>
-
-This method should not normally used. It allows for a long jump to the
-end of all nav_loops (even if they are recursively nested). This
-effectively short circuits all remaining hooks for the current and
-remaining steps. It is used to allow the ->jump functionality. If the
-application has morphed, it will be unmorphed before returning.
-
-=item Method C<-E<gt>recurse_limit>
-
-Default 15. Maximum number of times to allow nav_loop to call itself.
-If ->jump is used alot - the recurse_limit will be reached more quickly.
-It is safe to raise this as high as is necessary - so long as it is intentional.
-
-=item Method C<-E<gt>valid_steps>
-
-Returns a hashref of path steps that are allowed. If step found in
-default method path is not in the hash, the method path will return a
-single step "forbidden" and run its hooks. If no hash or undef is
-returned, all paths are allowed (default). A key "forbidden_step"
-containing the step that was not valid will be placed in the stash.
-Often the valid_steps method does not need to be defined as arbitrary
-method calls are not possible with CGI::Ex::App.
-
-=item Method C<-E<gt>previous_step, -E<gt>current_step, -E<gt>next_step, -E<gt>last_step, -E<gt>first_step>
-
-Return the previous, current, next, last, and first step name - useful for figuring
-out where you are in the path. Note that first_step may not be the same
-thing as default_step if the path was overridden.
-
-=item Method C<-E<gt>pre_loop>
-
-Called right before the navigation loop is started. At this point the
-path is set (but could be modified). The only argument is a reference
-to the path array. If it returns a true value - the navigation
-routine is aborted.
-
-=item Method C<-E<gt>run_hook>
-
-Calls "hook" to get a code ref which it then calls and returns the
-result. Arguments are the same as that for "hook".
-
-=item Method C<-E<gt>hook>
-
-Arguments are a hook name, a pathstep name, and an optional code sub
-or default value (default value will be turned to a sub) (code sub
-will be called as method of $self).
-
- my $code = $self->hook('main', 'info_complete', sub {return 0});
- ### will look first for $self->main_info_complete;
- ### will then look for $self->info_complete;
- ### will then run $self->$default_passed_sub; # sub {return 0}
-
-This system is used to allow for multiple steps to be in the same
-file and still allow for moving some steps out to external sub classed
-packages. If the application has successfully morphed then it is not
-necessary to add the step name to the beginning of the method name as
-the morphed packages method will override the base package (it is still
-OK to use the full method name "${step}_hookname").
-
-If a hook is found (or a default value is found) then an entry is added
-to the arrayref contained in ->history.
-
-=item Method C<-E<gt>morph>
-
-Allows for temporarily "becoming" another object type for the
-execution of the current step. This allows for separating some steps
-out into their own packages. Morph will only run if the method
-allow_morph returns true. Additionally if the allow_morph returns a hash
-ref, morph will only run if the step being morphed to is in the hash.
-The morph call occurs at the beginning of the step loop. A
-corresponding unmorph call occurs before the loop is exited. An
-object can morph several levels deep if allow_nested_morph returns
-true. For example, an object running as Foo::Bar that is looping on
-the step "my_step" that has allow_morph = 1, will do the following:
-call the hook morph_package (which would default to returning
-Foo::Bar::MyStep in this case), translate this to a package filename
-(Foo/Bar/MyStep.pm) and try and require it, if the file can be
-required, the object is blessed into that package. If that package
-has a "fixup_after_morph" method, it is called. The navigate loop
-then continues for the current step. At any exit point of the loop,
-the unmorph call is made which reblesses the object into the original
-package.
-
-It is possible to call morph earlier on in the program. An example of
-a useful early use of morph would be as in the following code:
-
- sub allow_morph { 1 }
-
- sub pre_navigate {
+sub ext_val {
my $self = shift;
- if ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ s|^/(\w+)||) {
- my $step = $1;
- $self->morph($step);
- $ENV{'PATH_INFO'} = "/$step";
- $self->stash->{'base_morphed'} = 1;
- }
- return 0;
- }
+ $self->{'ext_val'} = shift if $#_ != -1;
+ return $self->{'ext_val'} || 'val';
+}
- sub post_navigate {
+sub ext_print {
my $self = shift;
- $self->unmorph if $self->stash->{'base_morphed'};
- }
-
-If this code was in a module Base.pm and the cgi running was cgi/base
-and called:
-
- Base->navigate;
- # OR - for mod_perl resident programs
- Base->navigate->cleanup;
- # OR
- sub post_navigate { shift->cleanup }
-
-and you created a sub module that inherited Base.pm called
-Base/Ball.pm -- you could then access it using cgi/base/ball. You
-would be able to pass it steps using either cgi/base/ball/step_name or
-cgi/base/ball?step=step_name - Or Base/Ball.pm could implement its
-own path. It should be noted that if you do an early morph, it is
-suggested to provide a call to unmorph. And if you want to let your
-early morphed object morph again - you will need to provide
-
- sub allow_nested_morph { 1 }
-
-With allow_nested_morph enabled you could create the file
-Base/Ball/StepName.pm which inherits Base/Ball.pm. The Base.pm, with
-the custom init and default path method, would automatically morph us
-first into a Base::Ball object (during init) and then into a
-Base::Ball::StepName object (during the navigation loop).
-
-=item Method C<-E<gt>unmorph>
-
-Allows for returning an object back to its previous blessed state.
-This only happens if the object was previously morphed into another
-object type. Before the object is reblessed the method
-"fixup_before_unmorph" is called if it exists.
-
-=item Method C<-E<gt>allow_morph>
-
-Boolean value. Specifies whether or not morphing is allowed.
-Defaults to the property "allow_morph" if found, otherwise false.
-For more granularity, if true value is a hash, the step being
-morphed to must be in the hash.
-
-=item Method C<-E<gt>allow_nested_morph>
-
-Boolean value. Specifies whether or not nested morphing is allowed.
-Defaults to the property "allow_nested_morph" if found, otherwise
-false. For more granularity, if true value is a hash, the step being
-morphed to must be in the hash.
-
-=item Hook C<-E<gt>morph_package>
-
-Used by morph. Return the package name to morph into during a morph
-call. Defaults to using the current object type as a base. For
-example, if the current object running is a Foo::Bar object and the
-step running is my_step, then morph_package will return
-Foo::Bar::MyStep.
-
-=item Hook C<-E<gt>run_step>
-
-Runs all of the hooks specific to each step, beginning with pre_step
-and ending with post_step. Called after ->morph($step) has been
-run. If this returns true, the nav_loop is exited (meaning the
-run_step hook displayed the information). If it returns false,
-the nav_loop continues on to run the next step. This is essentially
-the same thing as a method defined in CGI::Applications ->run_modes.
-
-=item Hook C<-E<gt>pre_step>
-
-Ran at the beginning of the loop before prepare, info_compelete, and
-finalize are called. If it returns true, execution of nav_loop is
-returned and no more steps are processed.
-
-=item Hook C<-E<gt>skip>
-
-Ran at the beginning of the loop before prepare, info_compelete, and
-finalize are called. If it returns true, nav_loop moves on to the
-next step (the current step is skipped).
-
-=item Hook C<-E<gt>prepare>
-
-Defaults to true. A hook before checking if the info_complete is true.
-
-=item Hook C<-E<gt>info_complete>
-
-Checks to see if all the necessary form elements have been passed in.
-Calls hooks ready_validate, and validate. Will not be run unless
-prepare returns true (default).
-
-=item Hook C<-E<gt>finalize>
-
-Defaults to true. Used to do whatever needs to be done with the data once
-prepare has returned true and info_complete has returned true. On failure
-the print operations are ran. On success navigation moves on to the next
-step.
-
-=item Hook C<-E<gt>ready_validate>
-
-Should return true if enough information is present to run validate.
-Default is to look if $ENV{'REQUEST_METHOD'} is 'POST'. A common
-usage is to pass a common flag in the form such as 'processing' => 1
-and check for its presence - such as the following:
-
- sub ready_validate { shift->form->{'processing'} }
+ $self->{'ext_print'} = shift if $#_ != -1;
+ return $self->{'ext_print'} || 'html';
+}
-=item Method C<-E<gt>set_ready_validate>
+### 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'} || return '';
+ 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
+}
-Sets that the validation is ready to validate. Should set the value
-checked by the hook ready_validate. The following would complement the
-processing flag above:
+###----------------------------------------------------------------###
+### 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.
- sub set_ready_validate {
+sub js_run_step {
my $self = shift;
- if (shift) {
- $self->form->{'processing'} = 1;
- } else {
- delete $self->form->{'processing'};
- }
- }
-
-Note thate for this example the form key "processing" was deleted. This
-is so that the call to fill in any html forms won't swap in a value of
-zero for form elements named "processing."
-
-=item Hook C<-E<gt>validate>
-
-Runs validation on the information posted in $self->form. Uses
-CGI::Ex::Validate for the validation. Calls the hook hash_validation
-to load validation information. Should return true if enough
-information is present to run validate. Errors are stored as a hash
-in $self->{hash_errors} via method add_errors and can be checked for
-at a later time with method has_errors (if the default validate was
-used).
-
-Upon success, it will look through all of the items which
-were validated, if any of them contain the keys append_path, insert_path,
-or replace_path, that method will be called with the value as arguments.
-This allows for the validation to apply redirection to the path. A
-validation item of:
-
- {field => 'foo', required => 1, append_path => ['bar', 'baz']}
-
-would append 'bar' and 'baz' to the path should all validation succeed.
-=item Hook C<-E<gt>hash_validation>
-
-Returns a hash of the validation information to check form against.
-By default, will look for a filename using the hook file_val and will
-pass it to CGI::Ex::Validate::get_validation. If no file_val is
-returned or if the get_validation fails, an empty hash will be returned.
-Validation is implemented by ->vob which loads a CGI::Ex::Validate object.
-
-=item Hook C<-E<gt>file_val>
-
-Returns a filename containing the validation. Adds method
-base_dir_rel to hook name_module, and name_step and adds on the
-default file extension found in $self->ext_val which defaults to the
-global $EXT_VAL (the property $self->{ext_val} may also be set). File
-should be readible by CGI::Ex::Validate::get_validation.
-
-=item Hook C<-E<gt>js_validation>
-
-Requires YAML.pm.
-Will return Javascript that is capable of validating the form. This
-is done using the capabilities of CGI::Ex::Validate. This will call
-the hook hash_validation which will then be encoded into yaml and
-placed in a javascript string. It will also call the hook form_name
-to determine which html form to attach the validation to. The method
-js_uri_path is called to determine the path to the appropriate
-yaml_load.js and validate.js files. If the method ext_val is htm,
-then js_validation will return an empty string as it assumes the htm
-file will take care of the validation itself. In order to make use
-of js_validation, it must be added to either the hash_base, hash_common, hash_swap or
-hash_form hook (see examples of hash_base used in this doc).
-
-=item Hook C<-E<gt>form_name>
-
-Return the name of the form to attach the js validation to. Used by
-js_validation.
-
-=item Method C<-E<gt>js_uri_path>
-
-Return the URI path where the CGI/Ex/yaml_load.js and
-CGI/Ex/validate.js files can be found. This will default to
-"$ENV{SCRIPT_NAME}/js" if the path method has not been overridden,
-otherwise it will default to "$ENV{SCRIPT_NAME}?step=js&js=" (the
-latter is more friendly with overridden paths). A default handler for
-the "js" step has been provided in "js_run_step" (this handler will
-nicely print out the javascript found in the js files which are
-included with this distribution - if valid_steps is defined, it must
-include the step "js" - js_run_step will work properly with the
-default "path" handler.
-
-=item Hook C<-E<gt>hash_swap>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any items needed to be swapped
-into the html during print. Will be merged with hash_base, hash_common, hash_form,
-and hash_errors. Can be populated by passing a hash to ->add_to_swap.
-
-=item Hook C<-E<gt>hash_form>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Defaults to ->form. Can be populated by passing a hash
-to ->add_to_form.
-
-=item Hook C<-E<gt>hash_fill>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any items needed to be filled
-into the html form during print. Items from hash_form, hash_base, and hash_common
-will be layered on top during a print cycle. Can be populated by passing
-a hash to ->add_to_fill.
-
-By default - forms are sticky and data from previous requests will
-try and populate the form. There is a method called ->no_fill which
-will turn off sticky forms.
-
-=item Method C<-E<gt>no_fill>
-
-Passed the current step. Should return boolean value of whether or not
-to fill in the form on the printed page. (prevents sticky forms)
-
-=item Hook C<-E<gt>hash_errors>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any errors that occured. Will
-be merged into hash_form before the pass to print. Eash error that
-occured will be passed to method format_error before being added to
-the hash. If an error has occurred, the default validate will
-automatically add {has_errors =>1}. To the error hash at the time of
-validation. has_errors will also be added during the merge incase the
-default validate was not used. Can be populated by passing a hash to
-->add_to_errors or ->add_errors.
-
-=item Hook C<-E<gt>hash_common>
-
-Almost identical in function and purpose to hash_base. It is
-intended that hash_base be used for common items used in various
-scripts inheriting from a common CGI::Ex::App type parent. Hash_common
-is more intended for step level populating of both swap and fill.
+ ### 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 : '';
-=item Hook C<-E<gt>hash_base>
-
-A hash of base items to be merged with hash_form - such as pulldown
-menues. It will now also be merged with hash_fill, so it can contain
-default fillins. Can be populated by passing a hash to ->add_to_base.
-By default the following sub is what is used for hash_common (or something
-similiar). Note the use of values that are code refs - so that the
-js_validation and form_name hooks are only called if requested:
-
- sub hash_base {
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{SCRIPT_NAME},
- js_validation => sub { $self->run_hook('js_validation', $step) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
- }
-
-=item Hook C<-E<gt>name_module>
-
-Return the name (relative path) that should be prepended to name_step
-during the default file_print and file_val lookups. Defaults to
-base_name_module.
-
-=item Hook C<-E<gt>name_step>
-
-Return the step (appended to name_module) that should used when
-looking up the file in file_print and file_val lookups. Defaults to
-the current step.
-
-=item Hook C<-E<gt>file_print>
-
-Returns a filename of the content to be used in the default print
-hook. Adds method base_dir_rel to hook name_module, and name_step and
-adds on the default file extension found in $self->ext_print which
-defaults to the global $EXT_PRINT (the property $self->{ext_print} may
-also be set). Should be a file that can be handled by hook print.
-
-=item Hook C<-E<gt>print>
+ $self->cgix->print_js($file);
+ $self->{'_no_post_navigate'} = 1;
+ return 1;
+}
-Take the information generated by prepared_print, format it, and print it out.
-Default incarnation uses Template::Toolkit. Arguments are: step name, form hashref,
-and fill hashref.
+###----------------------------------------------------------------###
+### 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
-=item Hook C<-E<gt>prepared_print>
+sub __forbidden_info_complete { 0 }
-Called when any of prepare, info_complete, or finalize fail. Prepares
-a form hash and a fill hash to pass to print. The form hash is primarily
-intended for use by the templating system. The fill hash is intended
-to be used to fill in any html forms.
+sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} }
-=item Hook C<-E<gt>post_print>
+sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
-A hook which occurs after the printing has taken place. Is only run
-if the information was not complete. Useful for printing rows of a
-database query.
-
-=item Hook C<-E<gt>post_step>
+###----------------------------------------------------------------###
-Ran at the end of the step's loop if prepare, info_complete, and
-finalize all returned true. Allows for cleanup. If a true value is
-returned, execution of navigate is returned and no more steps are
-processed.
-
-=item Method C<-E<gt>post_loop>
+1;
-Ran after all of the steps in the loop have been processed (if
-prepare, info_complete, and finalize were true for each of the steps).
-If it returns a true value the navigation loop will be aborted. If it
-does not return true, navigation continues by then inserting the step
-$self->default_step and running $self->nav_loop again (recurses) to
-fall back to the default step.
-
-=item Method C<-E<gt>stash>
-
-Returns a hashref that can store arbitrary user space data without
-clobering the internals of the application.
-
-=item Method C<-E<gt>add_property>
-
-Takes the property name as an argument. Creates an accessor that can
-be used to access a new property. If there were additional arguments
-they will call the new accessor. Calling the new accessor with an
-argument will set the property. Using the accessor in an assignment
-will also set the property (it is an lvalue). Calling the accessor in
-any other way will return the value.
-
-=item Method C<-E<gt>cleanup>
-
-Can be used at the end of execution to tear down the structure.
-Default method starts a cleanup_cross_references call.
-
-=item Method C<-E<gt>cleanup_cross_references>
-
-Used to destroy links in nested structures. Will spider through the
-data structure of the passed object and remove any blessed objects
-that are no weakly referenced. This means if you have a reference to
-an object in a global cache, that object should have its reference
-weakened in the global cache. Requires Scalar::Util to function. Use
-of this function is highly recommended in mod_perl environments to
-make sure that there are no dangling objects in memory. There are
-some global caches that can't be fixed (such as Template::Parser's
-reference to Template::Grammar in the Template::Toolkit). For these
-situations there is a %CLEANUP_EXCLUDE hash that contains the names of
-Object types to exclude from the cleanup process. Add any such global
-hashes (or objects with references to the global hashes) there.
-
-=back
-
-=head1 OTHER APPLICATION MODULES
-
-The concepts used in CGI::Ex::App are not novel or unique. However, they
-are all commonly used and very useful. All application builders were
-built because somebody observed that there are common design patterns
-in CGI building. CGI::Ex::App differs in that it has found more common design
-patterns of CGI's.
-
-CGI::Ex::App is intended to be sub classed, and sub sub classed, and each step
-can choose to be sub classed or not. CGI::Ex::App tries to remain simple
-while still providing "more than one way to do it." It also tries to avoid
-making any sub classes have to call ->SUPER::.
-
-There are certainly other modules for building CGI applications. The
-following is a short list of other modules and how CGI::Ex::App is
-different.
-
-=over 4
-
-=item C<CGI::Application>
-
-Seemingly the most well know of application builders.
-CGI::Ex::App is different in that it:
-
- * Uses Template::Toolkit by default
- CGI::Ex::App can easily use another toolkit by simply
- overriding the ->print method.
- CGI::Application uses HTML::Template.
- * Offers integrated data validation.
- CGI::Application has had custom addons created that
- add some of this functionality. CGI::Ex::App has the benefit
- that once validation is created,
- * Allows the user to print at any time (so long as proper headers
- are sent. CGI::Application requires data to be pipelined.
- * Offers hooks into the various phases of each step ("mode" in
- CGI::Application lingo). CGI::Application essentially
- provides ->runmode
- * Support for easily jumping around in navigation steps.
- * Support for storing some steps in another package.
-
-CGI::Ex::App and CGI::Application are similar in that they take care
-of handling headers and they allow for calling other "runmodes" from
-within any given runmode. CGI::Ex::App's ->run_step is essentially
-equivalent to a method call defined in CGI::Application's ->run_modes.
-The ->run method of CGI::Application starts the application in the same
-manner as CGI::Ex::App's ->navigate call. Many of the hooks around
-CGI::Ex::App's ->run_step call are similar in nature to those provided by
-CGI::Application.
-
-=item C<CGI::Prototype>
-
-There are actually many simularities. One of the nicest things about
-CGI::Prototype is that it is extremely short (very very short). The
-->activate starts the application in the same manner as CGI::Ex::App's
-=>navigate call. Both use Template::Tookit as the default template system.
-CGI::Ex::App is differrent in that it:
-
- * Offers integrated data validation.
- CGI::Application has had custom addons created that
- add some of this functionality. CGI::Ex::App has the benefit
- that once validation is created,
- * Offers more hooks into the various phases of each step.
- * Support for easily jumping around in navigation steps.
- * Support for storing some steps in another package.
-
-=item C<CGI::Path>
-
-CGI::Path and CGI::Ex::App are fairly similar in may ways as they
-were created under similar lines of thought. The primary difference
-in these two is that CGI::Ex::App:
-
- * Does not provide "automated path following" based on
- validated key information. CGI::Path works well for
- wizard based applications. CGI::Ex::App assumes that
- the application will chose it's own path (it works very
- well in non-linear paths - it also works fine in
- linear paths but it doesn't provide some of magic that
- CGI::Path provides).
- * Does not provide integrated session support. CGI::Path
- requires it for path navigation. CGI::Ex::App assumes that
- if session support or authentication is needed by an
- application, a custom Application layer that inherits
- from CGI::Ex::App will be written to provide this support.
- * Offers more granularity in the navigation phase. CGI::Path
- has successfully been used as a sub class of CGI::Ex::App
- with limited modifications.
-
-=back
-
-=head1 BUGS
-
-Uses CGI::Ex for header support by default - which means that support
-for mod_perl 2 is limited at this point.
-
-There are a lot of hooks. Actually this is not a bug. Some may
-prefer not calling as many hooks - they just need to override
-methods high in the chain and subsequent hooks will not be called.
-
-=head1 THANKS
-
-Bizhosting.com - giving a problem that fit basic design patterns.
-Earl Cahill - pushing the idea of more generic frameworks.
-Adam Erickson - design feedback, bugfixing, feature suggestions.
-James Lance - design feedback, bugfixing, feature suggestions.
-
-=head1 AUTHOR
-
-Paul Seamons
-
-=cut
+### See the perldoc in CGI/Ex/App.pod
projects / chaz / p5-CGI-Ex / blobdiff