package CGI::Ex::App;
###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/App.pod
# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use strict;
use vars qw($VERSION);
BEGIN {
$VERSION = '2.06';
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 || croak "Usage: Package->new";
my $self = shift || {};
bless $self, $class;
$self->init;
return $self;
}
sub init {}
sub destroy {}
###----------------------------------------------------------------###
sub navigate {
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
$self->{'_time'} = time;
eval {
### allow for authentication
my $ref = $self->require_auth;
if ($ref && ! ref $ref) {
return $self if ! $self->get_valid_auth;
}
### a chance to do things at the very beginning
return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
### 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'};
};
$self->handle_error($@) if $@; # catch any errors
$self->{'_time'} = time;
$self->destroy;
return $self;
}
sub nav_loop {
my $self = shift;
### 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;
}
my $path = $self->path;
### allow for an early return
return if $self->pre_loop($path); # a true value means to abort the navigate
my $req_auth = ref($self->require_auth) ? $self->require_auth : undef;
### iterate on each step of the path
foreach ($self->{'path_i'} ||= 0;
$self->{'path_i'} <= $#$path;
$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
### allow for per-step authentication
if ($req_auth
&& $req_auth->{$step}
&& ! $self->get_valid_auth) {
return;
}
### allow for becoming another package (allows for some steps in external files)
$self->morph($step);
### run the guts of the step
my $handled = $self->run_hook('run_step', $step);
### Allow for the run_step to intercept.
### A true status means the run_step took over navigation.
if ($handled) {
$self->unmorph($step);
return;
}
### if there are no future steps - allow for this step to designate one to follow
my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
$self->run_hook('refine_path', $step, $is_at_end);
$self->unmorph($step);
}
### allow for one exit point after the loop
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
return;
}
sub pre_navigate { 0 } # true means to not enter nav_loop
sub post_navigate {}
sub pre_loop { 0 } # true value means to abort the nav_loop routine
sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
sub recurse_limit { shift->{'recurse_limit'} || 15 }
### default die handler - show what happened and die (so its in the error logs)
sub handle_error {
my $self = shift;
my $err = shift;
die $err;
}
###----------------------------------------------------------------###
sub default_step { shift->{'default_step'} || 'main' }
sub js_step { shift->{'js_step'} || 'js' }
sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
sub step_key { shift->{'step_key'} || 'step' }
sub path {
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;
}
}
}
return $self->{'path'};
}
sub set_path {
my $self = shift;
my $path = $self->{'path'} ||= [];
croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
}
### legacy - same as append_path
sub add_to_path {
my $self = shift;
push @{ $self->path }, @_;
}
sub append_path {
my $self = shift;
push @{ $self->path }, @_;
}
sub replace_path {
my $self = shift;
my $ref = $self->path;
my $i = $self->{'path_i'} || 0;
if ($i + 1 > $#$ref) {
push @$ref, @_;
} else {
splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
}
}
sub 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
}
}
### 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 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];
}
sub previous_step {
my $self = shift;
return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
}
sub current_step {
my $self = shift;
return $self->step_by_path_index( ($self->{'path_i'} || 0) );
}
sub next_step { # method and hook
my $self = shift;
return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
}
sub last_step {
my $self = shift;
return $self->step_by_path_index( $#{ $self->path } );
}
sub first_step {
my $self = shift;
return $self->step_by_path_index( 0 );
}
###----------------------------------------------------------------###
### hooks and history
sub find_hook {
my $self = shift;
my $hook = shift || do { require Carp; Carp::confess("Missing hook name") };
my $step = shift || '';
my $code;
if ($step && ($code = $self->can("${step}_${hook}"))) {
return [$code, "${step}_${hook}"],
} elsif ($code = $self->can($hook)) {
return [$code, $hook];
} else {
return [];
}
}
sub run_hook {
my $self = shift;
my $hook = shift;
my $step = shift;
my ($code, $found) = @{ $self->find_hook($hook, $step) };
if (! $code) {
croak "Could not find a method named ${step}_${hook} or ${hook}";
} elsif (! UNIVERSAL::isa($code, 'CODE')) {
croak "Value for $hook ($found) is not a code ref ($code)";
}
### record history
my $hist = {
step => $step,
meth => $hook,
found => $found,
time => time,
};
push @{ $self->history }, $hist;
$hist->{'level'} = $self->{'_level'};
local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
$hist->{'elapsed'} = time - $hist->{'time'};
my $resp = $self->$code($step, @_);
$hist->{'elapsed'} = time - $hist->{'time'};
$hist->{'response'} = $resp;
return $resp;
}
sub history {
return shift->{'history'} ||= [];
}
sub dump_history {
my $self = shift;
my $all = shift || 0;
my $hist = $self->history;
my $dump = [];
push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
### show terse - yet informative info
foreach my $row (@$hist) {
if (! ref($row)
|| ref($row) ne 'HASH'
|| ! exists $row->{'elapsed'}) {
push @$dump, $row;
} else {
my $note = (' ' x ($row->{'level'} || 0))
. join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
my $resp = $row->{'response'};
if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
$note .= ' - {}';
} elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
$note .= ' - []';
} elsif (! ref $resp || ! $all) {
my $max = $self->{'history_max'} || 30;
if (length($resp) > $max) {
$resp = substr($resp, 0, $max);
$resp =~ s/\n.+//s;
$resp = "$resp ...";
}
$note .= " - $resp";
} else {
$note = [$note, $resp];
}
push @$dump, $note;
}
}
return $dump;
}
###----------------------------------------------------------------###
### utility methods to allow for storing separate steps in other modules
sub allow_morph {
my $self = shift;
return $self->{'allow_morph'} ? 1 : 0;
}
sub allow_nested_morph {
my $self = shift;
return $self->{'allow_nested_morph'} ? 1 : 0;
}
sub morph {
my $self = shift;
my $step = shift || return;
my $allow = $self->allow_morph($step) || return;
### place to store the lineage
my $lin = $self->{'__morph_lineage'} ||= [];
my $cur = ref $self; # what are we currently
push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
my $hist = {
step => $step,
meth => 'morph',
found => 'morph',
time => time,
elapsed => 0,
response => 0
};
push @{ $self->history }, $hist;
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 {
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) || croak "unmorph called more times than morph - current ($cur)";
delete $self->{'__morph_lineage'} if ! @$lin;
### if we are not already that package - bless us there
my $hist = {
step => $step,
meth => 'unmorph',
found => 'unmorph',
time => time,
elapsed => 0,
response => 0,
};
push @{ $self->history }, $hist;
if ($cur ne $prev) {
$self->fixup_before_unmorph($step);
bless $self, $prev;
$hist->{'found'} .= " (changed from $cur to $prev)";
} else {
$hist->{'found'} .= " (already isa $cur)";
}
$hist->{'response'} = 1;
return $self;
}
sub fixup_after_morph {}
sub fixup_before_unmorph {}
###----------------------------------------------------------------###
### allow for authentication
sub navigate_authenticated {
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
$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;
$self->{'form'} = shift if @_ == 1;
return $self->{'form'} ||= $self->cgix->get_form;
}
sub cookies {
my $self = shift;
$self->{'cookies'} = shift if @_ == 1;
return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
sub cgix {
my $self = shift;
$self->{'cgix'} = shift if @_ == 1;
return $self->{'cgix'} ||= do {
require CGI::Ex;
CGI::Ex->new; # return of the do
};
}
sub vob {
my $self = shift;
$self->{'vob'} = shift if @_ == 1;
return $self->{'vob'} ||= do {
require CGI::Ex::Validate;
CGI::Ex::Validate->new($self->vob_args); # return of the do
};
}
sub vob_args {
my $self = shift;
return {
cgix => $self->cgix,
};
}
### provide a place for placing variables
sub stash {
my $self = shift;
return $self->{'stash'} ||= {};
}
###----------------------------------------------------------------###
### default hook implementations
sub run_step {
my $self = shift;
my $step = shift;
### if the pre_step exists and returns true, exit the nav_loop
return 1 if $self->run_hook('pre_step', $step);
### allow for skipping this step (but stay in the nav_loop)
return 0 if $self->run_hook('skip', $step);
### see if we have complete valid information for this step
### if so, do the next step
### if not, get necessary info and print it out
if ( ! $self->run_hook('prepare', $step)
|| ! $self->run_hook('info_complete', $step)
|| ! $self->run_hook('finalize', $step)) {
### show the page requesting the information
$self->run_hook('prepared_print', $step);
### a hook after the printing process
$self->run_hook('post_print', $step);
return 1;
}
### a hook before end of loop
### if the post_step exists and returns true, exit the nav_loop
return 1 if $self->run_hook('post_step', $step);
### let the nav_loop continue searching the path
return 0;
}
sub refine_path {
my ($self, $step, $is_at_end) = @_;
return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
my $next_step = $self->run_hook('next_step', $step) || return 0;
$self->run_hook('set_ready_validate', $step, 0);
$self->append_path($next_step);
return 1;
}
sub prepared_print {
my $self = shift;
my $step = shift;
my $hash_base = $self->run_hook('hash_base', $step) || {};
my $hash_comm = $self->run_hook('hash_common', $step) || {};
my $hash_form = $self->run_hook('hash_form', $step) || {};
my $hash_fill = $self->run_hook('hash_fill', $step) || {};
my $hash_swap = $self->run_hook('hash_swap', $step) || {};
my $hash_errs = $self->run_hook('hash_errors', $step) || {};
### fix up errors
$hash_errs->{$_} = $self->format_error($hash_errs->{$_})
foreach keys %$hash_errs;
$hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
### layer hashes together
my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
### run the print hook - passing it the form and fill info
$self->run_hook('print', $step, $swap, $fill);
}
sub print {
my ($self, $step, $swap, $fill) = @_;
my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
my $out = $self->run_hook('swap_template', $step, $file, $swap);
$self->run_hook('fill_template', $step, \$out, $fill);
$self->run_hook('print_out', $step, $out);
}
sub print_out {
my ($self, $step, $out) = @_;
$self->cgix->print_content_type;
print $out;
}
sub swap_template {
my ($self, $step, $file, $swap) = @_;
my $args = $self->run_hook('template_args', $step);
my $copy = $self;
eval {require Scalar::Util; Scalar::Util::weaken($copy)};
$args->{'INCLUDE_PATH'} ||= sub { $copy->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" };
require CGI::Ex::Template;
my $t = CGI::Ex::Template->new($args);
my $out = '';
$t->process($file, $swap, \$out) || die $t->error;
return $out;
}
sub template_args { {} }
sub fill_template {
my ($self, $step, $outref, $fill) = @_;
return if ! $fill;
my $args = $self->run_hook('fill_args', $step);
local $args->{'text'} = $outref;
local $args->{'form'} = $fill;
require CGI::Ex::Fill;
CGI::Ex::Fill::fill($args);
}
sub fill_args { {} }
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 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 name_module {
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
};
}
sub file_print {
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) || die "Missing name_step";
$_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
return $base_dir . $module . $_step;
}
sub file_val {
my $self = shift;
my $step = shift;
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+$/;
foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
return $abs . $base_dir . $module . $_step;
}
sub info_complete {
my ($self, $step) = @_;
return 0 if ! $self->run_hook('ready_validate', $step);
return 0 if ! $self->run_hook('validate', $step, $self->form);
return 1;
}
sub ready_validate {
my ($self, $step) = @_;
return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
}
sub set_ready_validate { # hook and method
my $self = shift;
my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
$ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
return $is_ready;
}
sub validate {
my ($self, $step, $form) = @_;
my $hash = $self->run_hook('hash_validation', $step);
my $what_was_validated = [];
my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) };
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 => "
\n",
as_hash_suffix => '_error',
}));
return 0;
}
### 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);
}
sub form_name { 'theform' }
sub hash_validation {
my ($self, $step) = @_;
return $self->{'hash_validation'}->{$step} ||= do {
my $hash;
my $file = $self->run_hook('file_val', $step);
### allow for returning the validation hash in the filename
### a scalar ref means it is a yaml document to be read by get_validation
if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
$hash = $file;
### read the file - if it is not found, errors will be in the webserver logs (all else dies)
} elsif ($file) {
$hash = $self->vob->get_validation($file) || {};
} else {
$hash = {};
}
$hash; # return of the do
};
}
sub hash_base {
my ($self, $step) = @_;
return $self->{'hash_base'} ||= do {
### create a weak copy of self to use in closures
my $copy = $self;
eval {require Scalar::Util; Scalar::Util::weaken($copy)};
my $hash = {
script_name => $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_form { shift->form }
sub hash_fill { shift->{'hash_fill'} ||= {} }
sub hash_swap { shift->{'hash_swap'} ||= {} }
sub hash_errors { shift->{'hash_errors'} ||= {} }
###----------------------------------------------------------------###
### routines to support the base hooks
sub add_errors {
my $self = shift;
my $hash = $self->hash_errors;
my $args = ref($_[0]) ? shift : {@_};
foreach my $key (keys %$args) {
my $_key = ($key =~ /error$/) ? $key : "${key}_error";
if ($hash->{$_key}) {
$hash->{$_key} .= '
' . $args->{$key};
} else {
$hash->{$_key} = $args->{$key};
}
}
$hash->{'has_errors'} = 1;
}
sub 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_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 add_to_hash {
my $self = shift;
my $old = shift;
my $new = shift;
$new = {$new, @_} if ! ref $new; # non-hashref
$old->{$_} = $new->{$_} foreach keys %$new;
}
sub base_dir_rel {
my $self = shift;
$self->{'base_dir_rel'} = shift if $#_ != -1;
return $self->{'base_dir_rel'} || '';
}
sub base_dir_abs {
my $self = shift;
$self->{'base_dir_abs'} = shift if $#_ != -1;
return $self->{'base_dir_abs'} || '';
}
sub ext_val {
my $self = shift;
$self->{'ext_val'} = shift if $#_ != -1;
return $self->{'ext_val'} || 'val';
}
sub ext_print {
my $self = shift;
$self->{'ext_print'} = shift if $#_ != -1;
return $self->{'ext_print'} || 'html';
}
### 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
}
###----------------------------------------------------------------###
### 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 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);
$self->{'_no_post_navigate'} = 1;
return 1;
}
###----------------------------------------------------------------###
### a step that will be used if a valid_steps is defined
### and the current step of the path is not in valid_steps
### or if the step is a "hidden" step that begins with _
### or if the step name contains \W
sub __forbidden_info_complete { 0 }
sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} }
sub __forbidden_file_print { \ "