###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/App.pod
-# Copyright 2006 - Paul Seamons #
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.00';
+ $VERSION = '2.16';
Time::HiRes->import('time') if eval {require Time::HiRes};
+ eval {require Scalar::Util};
}
sub croak {
sub init {}
+sub destroy {}
+
###----------------------------------------------------------------###
sub navigate {
$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'} || []};
+ local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
$self->nav_loop;
};
if ($@) {
$self->{'_time'} = time;
+ $self->destroy;
+
return $self;
}
my $self = shift;
### keep from an infinate nesting
- local $self->{'recurse'} = $self->{'recurse'} || 0;
- if ($self->{'recurse'} ++ >= $self->recurse_limit) {
+ 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 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;
$step = $1; # untaint
### allow for per-step authentication
- if ($req_auth
- && $req_auth->{$step}
- && ! $self->get_valid_auth) {
- return;
+ if (! $self->is_authed) {
+ my $req = $self->run_hook('require_auth', $step, 1);
+ if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
+ return if ! $self->get_valid_auth;
+ }
}
### allow for becoming another package (allows for some steps in external files)
$self->morph($step);
- ### run the guts of the step
- my $status = $self->run_hook('run_step', $step);
+ ### allow for mapping path_info pieces to form elements
+ if (my $info = $self->path_info) {
+ my $maps = $self->run_hook('path_info_map', $step) || [];
+ croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }'
+ if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
+ foreach my $map (@$maps) {
+ my @match = $info =~ $map->[0];
+ next if ! @match;
+ $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
+ last;
+ }
+ }
- $self->unmorph($step);
+ ### run the guts of the step
+ my $handled = $self->run_hook('run_step', $step);
### Allow for the run_step to intercept.
### A true status means the run_step took over navigation.
- return if $status;
+ if ($handled) {
+ $self->unmorph($step);
+ return;
+ }
+
+ ### if there are no future steps - allow for this step to designate one to follow
+ my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
+ $self->run_hook('refine_path', $step, $is_at_end);
+
+ $self->unmorph($step);
}
### allow for one exit point after the loop
my $self = shift;
my $err = shift;
- die $err;
+ die $err if $self->{'_handling_error'};
+ local $self->{'_handling_error'} = 1;
+ local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error
+
+ $self->stash->{'error_step'} = $self->current_step;
+ $self->stash->{'error'} = $err;
+ $self->replace_path($self->error_step);
+ $self->jump; # exits nav loop when finished
}
###----------------------------------------------------------------###
-sub default_step { shift->{'default_step'} || 'main' }
-
-sub js_step { shift->{'js_step'} || 'js' }
-
+sub default_step { shift->{'default_step'} || 'main' }
+sub js_step { shift->{'js_step'} || 'js' }
+sub login_step { shift->{'login_step'} || '__login' }
+sub error_step { shift->{'error_step'} || '__error' }
sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
sub step_key { shift->{'step_key'} || 'step' }
if (! $self->{'path'}) {
my $path = $self->{'path'} = []; # empty path
- my $step = $self->form->{ $self->step_key };
- $step = lc($1) if ! $step && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|;
+ ### add initial items to the form hash from path_info5B
+ if (my $info = $self->path_info) {
+ my $maps = $self->path_info_map_base || [];
+ croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }'
+ if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
+ foreach my $map (@$maps) {
+ my @match = $info =~ $map->[0];
+ next if ! @match;
+ $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
+ last;
+ }
+ }
### make sure the step is valid
+ my $step = $self->form->{$self->step_key};
if (defined $step) {
if ($step =~ /^_/) { # can't begin with _
$self->stash->{'forbidden_step'} = $step;
return $self->{'path'};
}
+sub path_info_map_base {
+ my $self = shift;
+ return [[qr{/(\w+)}, $self->step_key]];
+}
+
sub set_path {
my $self = shift;
my $path = $self->{'path'} ||= [];
my $self = shift;
### undo morphs
- if (my $ref = $self->{'__morph_lineage'}) {
+ 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'};
+ my $index = $self->{'_morph_lineage_start_index'};
$index = -1 if ! defined $index;
$self->unmorph while $#$ref != $index;
}
sub previous_step {
my $self = shift;
- croak "previous_step is readonly" if $#_ != -1;
return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
}
sub current_step {
my $self = shift;
- croak "current_step is readonly" if $#_ != -1;
return $self->step_by_path_index( ($self->{'path_i'} || 0) );
}
-sub next_step {
+sub next_step { # method and hook
my $self = shift;
- croak "next_step is readonly" if $#_ != -1;
return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
}
sub last_step {
my $self = shift;
- croak "last_step is readonly" if $#_ != -1;
return $self->step_by_path_index( $#{ $self->path } );
}
sub first_step {
my $self = shift;
- croak "first_step is readonly" if $#_ != -1;
return $self->step_by_path_index( 0 );
}
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,
$note .= ' - {}';
} elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
$note .= ' - []';
+ } elsif (! defined $resp) {
+ $note .= ' - undef';
} elsif (! ref $resp || ! $all) {
my $max = $self->{'history_max'} || 30;
if (length($resp) > $max) {
}
sub morph {
- my $self = shift;
- my $step = shift || return;
- return if ! (my $allow = $self->allow_morph($step));
+ my $self = shift;
+ my $step = shift || return;
+ my $allow = $self->allow_morph($step) || return;
### place to store the lineage
- my $lin = $self->{'__morph_lineage'} ||= [];
+ 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
meth => 'morph',
found => 'morph',
time => time,
- elapsed => 0,
+ elapsed => 0,
+ response => 0
};
push @{ $self->history }, $hist;
if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
$hist->{'found'} .= " (not allowed to morph to that step)";
- return;
+ return 0;
}
### make sure we haven't already been reblessed
|| (ref($allow) && ! $allow->{$step}) # hash - but no step
)) {
$hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
- return; # just return - don't die so that we can morph early
+ return 0; # just return - don't die so that we can morph early
}
### if we are not already that package - bless us there
}
}
+ $hist->{'response'} = 1;
+ return 1;
}
sub unmorph {
my $self = shift;
- my $step = shift || '__no_step';
- my $lin = $self->{'__morph_lineage'} || return;
+ 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;
+ delete $self->{'_morph_lineage'} if ! @$lin;
### if we are not already that package - bless us there
my $hist = {
meth => 'unmorph',
found => 'unmorph',
time => time,
- elapsed => 0,
+ elapsed => 0,
+ response => 0,
};
push @{ $self->history }, $hist;
$hist->{'found'} .= " (already isa $cur)";
}
+ $hist->{'response'} = 1;
return $self;
}
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
+ if ($self->can('require_auth') != \&CGI::Ex::App::require_auth) {
+ require Carp;
+ Carp::croak("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting");
+ }
$self->require_auth(1);
return $self->navigate;
sub require_auth {
my $self = shift;
- $self->{'require_auth'} = shift if @_ == 1;
- return $self->{'require_auth'};
+ $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
+ return $self->{'require_auth'} || 0;
}
sub is_authed { shift->auth_data }
my $self = shift;
return 1 if $self->is_authed;
- ### augment the args with sensible defaults
my $args = $self->auth_args;
+
+ ### allow passed in args
+ if (my $extra = shift) {
+ $args = {%$args, %$extra};
+ }
+
+ ### augment the args with sensible defaults
+ $args->{'script_name'} ||= $self->script_name;
+ $args->{'path_info'} ||= $self->path_info;
$args->{'cgix'} ||= $self->cgix;
$args->{'form'} ||= $self->form;
$args->{'cookies'} ||= $self->cookies;
$args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
$args->{'login_print'} ||= sub {
my ($auth, $template, $hash) = @_;
- my $out = $self->run_hook('swap_template', '__login', $template, $hash);
- $self->run_hook('fill_template', '__login', \$out, $hash);
- $self->run_hook('print_out', '__login', $out);
+ my $step = $self->login_step;
+ my $hash_base = $self->run_hook('hash_base', $step) || {};
+ my $hash_comm = $self->run_hook('hash_common', $step) || {};
+ my $hash_swap = $self->run_hook('hash_swap', $step) || {};
+ my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
+
+ my $out = $self->run_hook('swap_template', $step, $template, $swap);
+ $self->run_hook('fill_template', $step, \$out, $hash);
+ $self->run_hook('print_out', $step, \$out);
};
require CGI::Ex::Auth;
###----------------------------------------------------------------###
### a few standard base accessors
+sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
+
+sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
+
+sub cgix {
+ my $self = shift;
+ $self->{'cgix'} = shift if @_ == 1;
+ return $self->{'cgix'} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new; # return of the do
+ };
+}
+
sub form {
my $self = shift;
$self->{'form'} = shift if @_ == 1;
return $self->{'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->{'stash'} ||= {};
}
+sub clear_app {
+ my $self = shift;
+
+ delete @{ $self }{qw(
+ cgix
+ vob
+ form
+ cookies
+ stash
+ path
+ path_i
+ history
+ _morph_lineage_start_index
+ _morph_lineage
+ hash_errors
+ hash_fill
+ hash_swap
+ hash_common
+ )};
+
+ return $self;
+}
+
###----------------------------------------------------------------###
### default hook implementations
+sub path_info_map { }
+
sub run_step {
my $self = shift;
my $step = shift;
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;
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);
+ $self->run_hook('print_out', $step, \$out);
}
sub print_out {
my ($self, $step, $out) = @_;
- $self->cgix->print_content_type();
- print $out;
+ $self->cgix->print_content_type;
+ print ref($out) eq 'SCALAR' ? $$out : $out;
}
sub swap_template {
my ($self, $step, $file, $swap) = @_;
- require CGI::Ex::Template;
my $args = $self->run_hook('template_args', $step);
- my $t = CGI::Ex::Template->new($args);
+ $args->{'INCLUDE_PATH'} ||= $self->base_dir_abs;
+ my $t = $self->template_obj($args);
my $out = '';
$t->process($file, $swap, \$out) || die $t->error;
return $out;
}
-sub template_args {
- my $self = shift;
- my $step = shift;
- return {
- INCLUDE_PATH => sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" },
- };
+sub template_args { {} }
+
+sub template_obj {
+ my ($self, $args) = @_;
+
+ require CGI::Ex::Template;
+ my $t = CGI::Ex::Template->new($args);
}
sub fill_template {
sub skip { 0 } # success indicates to skip the step (and continue loop)
sub prepare { 1 } # failure means show step
sub finalize { 1 } # failure means show step
-sub post_print { 0 } # success indicates we handled step (don't continue loop)
+sub post_print { 0 }
sub post_step { 0 } # success indicates we handled step (don't continue step or loop)
-sub name_step {
- my ($self, $step) = @_;
- return $step;
-}
-
sub morph_package {
my $self = shift;
my $step = shift || '';
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;
+ my $script = $self->script_name;
$script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
$1; # return of the do
};
}
+sub name_step {
+ my ($self, $step) = @_;
+ return $step;
+}
+
sub file_print {
my $self = shift;
my $step = shift;
my $self = shift;
my $step = shift;
- my $abs = $self->base_dir_abs || return {};
+ ### determine the path to begin looking for files - allow for an arrayref
+ my $abs = $self->base_dir_abs || [];
+ $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
+ $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');
+ return {} if @$abs == 0;
+
my $base_dir = $self->base_dir_rel;
my $module = $self->run_hook('name_module', $step);
- my $_step = $self->run_hook('name_step', $step);
+ my $_step = $self->run_hook('name_step', $step) || die "Missing name_step";
$_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
- foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+ foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
- return $abs . $base_dir . $module . $_step;
+ if (@$abs > 1) {
+ foreach my $_abs (@$abs) {
+ my $path = $_abs . $base_dir . $module . $_step;
+ return $path if -e $path;
+ }
+ }
+
+ return $abs->[0] . $base_dir . $module . $_step;
}
sub info_complete {
- my $self = shift;
- my $step = shift;
-
+ my ($self, $step) = @_;
return 0 if ! $self->run_hook('ready_validate', $step);
- return 0 if ! $self->run_hook('validate', $step);
+ return 0 if ! $self->run_hook('validate', $step, $self->form);
return 1;
}
sub ready_validate {
- my $self = shift;
- my $step = shift;
-
+ my ($self, $step) = @_;
return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
}
-sub set_ready_validate {
- my ($self, $ready) = @_;
- $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET';
+sub set_ready_validate { # hook and method
+ my $self = shift;
+ my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
+ $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
+ return $is_ready;
}
sub validate {
- my $self = shift;
- my $step = shift;
- my $form = shift || $self->form;
+ my ($self, $step, $form) = @_;
+
my $hash = $self->run_hook('hash_validation', $step);
my $what_was_validated = [];
if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
$hash = $file;
- ### read the file - if it fails - errors should be in the webserver error logs
+ ### read the file - if it is not found, errors will be in the webserver logs (all else dies)
} elsif ($file) {
- $hash = eval { $self->vob->get_validation($file) } || {};
+ $hash = $self->vob->get_validation($file) || {};
} else {
$hash = {};
return $self->{'hash_base'} ||= do {
### create a weak copy of self to use in closures
- my $copy;
- if (eval {require Scalar::Util} && defined &Scalar::Util::weaken) {
- $copy = $self;
- Scalar::Util::weaken($copy);
- } else {
- $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8)
- }
-
+ my $copy = $self;
+ eval {require Scalar::Util; Scalar::Util::weaken($copy)};
my $hash = {
- script_name => $ENV{'SCRIPT_NAME'} || $0,
- path_info => $ENV{'PATH_INFO'} || '',
+ script_name => $copy->script_name,
+ path_info => $copy->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,
sub base_dir_rel {
my $self = shift;
- $self->{'base_dir_rel'} = shift if $#_ != -1;
+ $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'} || '';
+ $self->{'base_dir_abs'} = shift if @_ == 1;
+ return $self->{'base_dir_abs'} || ['.']; # default to the current directory
}
-sub ext_val {
+sub ext_print {
my $self = shift;
- $self->{'ext_val'} = shift if $#_ != -1;
- return $self->{'ext_val'} || 'val';
+ $self->{'ext_print'} = shift if @_ == 1;
+ return $self->{'ext_print'} || 'html';
}
-sub ext_print {
+sub ext_val {
my $self = shift;
- $self->{'ext_print'} = shift if $#_ != -1;
- return $self->{'ext_print'} || 'html';
+ $self->{'ext_val'} = shift if @_ == 1;
+ return $self->{'ext_val'} || 'val';
}
### where to find the javascript files
### default to using this script as a handler
sub js_uri_path {
my $self = shift;
- my $script = $ENV{'SCRIPT_NAME'} || return '';
+ my $script = $self->script_name;
my $js_step = $self->js_step;
return ($self->can('path') == \&CGI::Ex::App::path)
? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
my $self = shift;
### make sure path info looks like /js/CGI/Ex/foo.js
- my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
+ my $file = $self->form->{'js'} || $self->path_info;
$file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
$self->cgix->print_js($file);
sub __forbidden_info_complete { 0 }
-sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} }
+sub __forbidden_hash_swap { shift->stash }
sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
+###----------------------------------------------------------------###
+### a step that is used by the default handle_error
+
+sub __error_info_complete { 0 }
+
+sub __error_hash_swap { shift->stash }
+
+sub __error_file_print { \ "<h1>An a fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
+
###----------------------------------------------------------------###
1;
projects / chaz / p5-CGI-Ex / blobdiff