###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/App.pod
-# Copyright 2007 - Paul Seamons #
-# Distributed under the Perl Artistic License without warranty #
+# Copyright 2007 - Paul Seamons
+# Distributed under the Perl Artistic License without warranty
###----------------------------------------------------------------###
use strict;
-use vars qw($VERSION);
-
+use Carp qw(croak);
BEGIN {
- $VERSION = '2.17';
-
- 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";
+ eval { use Time::HiRes qw(time) };
+ eval { use Scalar::Util };
}
-###----------------------------------------------------------------###
+our $VERSION = '2.18';
sub new {
- my $class = shift || croak "Usage: Package->new";
- my $self = shift || {};
+ my $class = shift || croak "Usage: ".__PACKAGE__."->new";
+ my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
bless $self, $class;
$self->init;
-
$self->init_from_conf;
return $self;
}
-sub init {}
-
-sub destroy {}
-
-###----------------------------------------------------------------###
-
sub init_from_conf {
my $self = shift;
return if ! $self->load_conf;
return;
}
-sub load_conf { shift->{'load_conf'} ||= @_ ? 1 : 0 }
-
-sub conf {
- my $self = shift;
- return $self->{'conf'} ||= do {
- my $conf = $self->conf_obj->read($self->conf_file, {no_warn_on_fail => 1}) || croak $@;
- my $hash = $self->conf_validation;
- if ($hash && scalar keys %$hash) {
- my $err_obj = $self->vob->validate($conf, $hash);
- die $err_obj if $err_obj;
- }
- $conf;
- }
-}
-
-sub conf_path {
- my $self = shift;
- return $self->{'conf_path'} || $self->base_dir_abs;
-}
-
-sub conf_file {
- my $self = shift;
- return $self->{'conf_file'} ||= do {
- my $module = $self->name_module || croak 'Missing name_module during conf_file call';
- $module .'.'. $self->conf_ext;
- };
-}
-
-sub conf_ext {
- my $self = shift;
- $self->{'conf_ext'} = shift if @_ == 1;
- return $self->{'conf_ext'} || 'pl';
-}
-
-sub conf_args { shift->{'conf_args'} || {} }
-
-sub conf_obj {
- my $self = shift;
- return $self->{'conf_obj'} || do {
- my $args = $self->conf_args;
- $args->{'paths'} ||= $self->conf_path;
- $args->{'directive'} ||= 'MERGE';
- require CGI::Ex::Conf;
- CGI::Ex::Conf->new($args);
- };
-}
-
-sub conf_validation {}
-
-###----------------------------------------------------------------###
+###---------------------###
sub navigate {
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
$self->{'_time'} = time;
-
eval {
- ### 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";
- }
+ 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->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors
$self->destroy;
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;
+ return if ! $self->run_hook('get_valid_auth', $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'));
+ croak 'Usage: sub path_info_map { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
foreach my $map (@$maps) {
+ croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY');
my @match = $info =~ $map->[0];
next if ! @match;
$self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
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 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 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' }
-
sub path {
my $self = shift;
if (! $self->{'path'}) {
### 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'));
+ croak 'Usage: sub path_info_map_base { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
foreach my $map (@$maps) {
+ croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY');
my @match = $info =~ $map->[0];
next if ! @match;
$self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
return $self->{'path'};
}
-sub path_info_map_base {
+sub run_hook {
my $self = shift;
- return [[qr{/(\w+)}, $self->step_key]];
+ my $hook = shift;
+ my $step = shift;
+ my ($code, $found) = @{ $self->find_hook($hook, $step) };
+ croak "Could not find a method named ${step}_${hook} or ${hook}" if ! $code;
+ croak "Value for $hook ($found) is not a code ref ($code)" if ! UNIVERSAL::isa($code, 'CODE');
+
+ my $hist;
+ if (! $self->{'no_history'}) {
+ $hist = {
+ step => $step,
+ meth => $hook,
+ found => $found,
+ time => time,
+ };
+ push @{ $self->history }, $hist;
+ $hist->{'level'} = $self->{'_level'};
+ $hist->{'elapsed'} = time - $hist->{'time'};
+ }
+ local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
+
+ my $resp = $self->$code($step, @_);
+
+ if (! $self->{'no_history'}) {
+ $hist->{'elapsed'} = time - $hist->{'time'};
+ $hist->{'response'} = $resp;
+ }
+
+ return $resp;
}
-sub set_path {
+sub run_step {
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)
+ 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 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) || {};
+
+ $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
+ $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
+
+ my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
+ my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
+
+ $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 template_path
+ 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);
}
-### legacy - same as append_path
-sub add_to_path {
+sub handle_error {
+ my ($self, $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);
+
+ eval { $self->jump };
+ die $@ if $@ && $@ ne "Long Jump\n";
+}
+
+###---------------------###
+# read only accessors
+
+sub allow_morph { $_[0]->{'allow_morph'} }
+sub allow_nested_morph { $_[0]->{'allow_nested_morph'} }
+sub auth_args { $_[0]->{'auth_args'} }
+sub charset { $_[0]->{'charset'} || '' }
+sub conf_args { $_[0]->{'conf_args'} }
+sub conf_die_on_fail { $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} }
+sub conf_path { $_[0]->{'conf_path'} || $_[0]->base_dir_abs }
+sub conf_validation { $_[0]->{'conf_validation'} }
+sub default_step { $_[0]->{'default_step'} || 'main' }
+sub error_step { $_[0]->{'error_step'} || '__error' }
+sub fill_args { $_[0]->{'fill_args'} }
+sub forbidden_step { $_[0]->{'forbidden_step'} || '__forbidden' }
+sub form_name { $_[0]->{'form_name'} || 'theform' }
+sub history { $_[0]->{'history'} ||= [] }
+sub js_step { $_[0]->{'js_step'} || 'js' }
+sub login_step { $_[0]->{'login_step'} || '__login' }
+sub mimetype { $_[0]->{'mimetype'} || 'text/html' }
+sub path_info { $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' }
+sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] }
+sub recurse_limit { $_[0]->{'recurse_limit'} || 15 }
+sub script_name { $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
+sub stash { $_[0]->{'stash'} ||= {} }
+sub step_key { $_[0]->{'step_key'} || 'step' }
+sub template_args { $_[0]->{'template_args'} }
+sub template_path { $_[0]->{'template_path'} || $_[0]->base_dir_abs }
+sub val_args { $_[0]->{'val_args'} }
+sub val_path { $_[0]->{'val_path'} || $_[0]->template_path }
+
+sub conf_obj {
my $self = shift;
- push @{ $self->path }, @_;
+ return $self->{'conf_obj'} || do {
+ my $args = $self->conf_args || {};
+ $args->{'paths'} ||= $self->conf_path;
+ $args->{'directive'} ||= 'MERGE';
+ require CGI::Ex::Conf;
+ CGI::Ex::Conf->new($args);
+ };
+}
+
+sub template_obj {
+ my ($self, $args) = @_;
+ return $self->{'template_obj'} || do {
+ require Template::Alloy;
+ my $t = Template::Alloy->new($args);
+ };
}
-sub append_path {
+sub val_obj {
my $self = shift;
- push @{ $self->path }, @_;
+ return $self->{'val_obj'} || do {
+ my $args = $self->val_args || {};
+ $args->{'cgix'} ||= $self->cgix;
+ require CGI::Ex::Validate;
+ CGI::Ex::Validate->new($args);
+ };
}
-sub replace_path {
+###---------------------###
+# read/write accessors
+
+sub auth_data { (@_ == 2) ? $_[0]->{'auth_data'} = pop : $_[0]->{'auth_data'} }
+sub base_dir_abs { (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.'] }
+sub base_dir_rel { (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || '' }
+sub cgix { (@_ == 2) ? $_[0]->{'cgix'} = pop : $_[0]->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } }
+sub cookies { (@_ == 2) ? $_[0]->{'cookies'} = pop : $_[0]->{'cookies'} ||= $_[0]->cgix->get_cookies }
+sub ext_conf { (@_ == 2) ? $_[0]->{'ext_conf'} = pop : $_[0]->{'ext_conf'} || 'pl' }
+sub ext_print { (@_ == 2) ? $_[0]->{'ext_print'} = pop : $_[0]->{'ext_print'} || 'html' }
+sub ext_val { (@_ == 2) ? $_[0]->{'ext_val'} = pop : $_[0]->{'ext_val'} || 'val' }
+sub form { (@_ == 2) ? $_[0]->{'form'} = pop : $_[0]->{'form'} ||= $_[0]->cgix->get_form }
+sub load_conf { (@_ == 2) ? $_[0]->{'load_conf'} = pop : $_[0]->{'load_conf'} }
+
+sub conf {
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
+ $self->{'conf'} = pop if @_ == 1;
+ return $self->{'conf'} ||= do {
+ my $conf = $self->conf_file;
+ $conf = ($self->conf_obj->read($conf, {no_warn_on_fail => 1}) || $self->conf_die_on_fail ? croak $@ : {}) if ! $conf;
+ my $hash = $self->conf_validation;
+ if ($hash && scalar keys %$hash) {
+ my $err_obj = $self->val_obj->validate($conf, $hash);
+ die $err_obj if $err_obj;
+ }
+ $conf;
}
}
-sub insert_path {
+sub conf_file {
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
+ $self->{'conf_file'} = pop if @_ == 1;
+ return $self->{'conf_file'} ||= do {
+ my $module = $self->name_module || croak 'Missing name_module during conf_file call';
+ $module .'.'. $self->ext_conf;
+ };
+}
+
+###---------------------###
+# general methods
+
+sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) }
+sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
+sub add_to_errors { shift->add_errors(@_) }
+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_path { shift->append_path(@_) } # legacy
+sub add_to_swap { my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
+sub cleanup_user { my ($self, $user) = @_; $user }
+sub current_step { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
+sub destroy {}
+sub first_step { $_[0]->step_by_path_index(0) }
+sub fixup_after_morph {}
+sub fixup_before_unmorph {}
+sub format_error { my ($self, $error) = @_; $error }
+sub get_pass_by_user { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
+sub has_errors { scalar keys %{ $_[0]->hash_errors } }
+sub init {}
+sub last_step { $_[0]->step_by_path_index($#{ $_[0]->path }) }
+sub path_info_map {}
+sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
+sub post_navigate {}
+sub pre_loop { 0 } # true value means to abort the nav_loop routine
+sub pre_navigate { 0 } # true means to not enter nav_loop
+sub previous_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) }
+sub valid_steps {}
+sub verify_user { 1 }
+
+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};
+ }
}
+ $hash->{'has_errors'} = 1;
+}
+
+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;
}
-### a hash of paths that are allowed, default undef is all are allowed
-sub valid_steps {}
+sub append_path { my $self = shift; push @{ $self->path }, @_ }
-###----------------------------------------------------------------###
-### allow for checking where we are in the path and for jumping around
+sub clear_app {
+ my $self = shift;
+ delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
+ _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
+ return $self;
+}
+
+sub dump_history {
+ my ($self, $all) = @_;
+
+ my $hist = $self->history;
+ my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
+
+ foreach my $row (@$hist) {
+ if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) {
+ push @$dump, $row;
+ next;
+ }
+ 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 (! defined $resp) {
+ $note .= ' - undef';
+ } 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;
+}
sub exit_nav_loop {
my $self = shift;
$self->unmorph while $#$ref != $index;
}
- ### long jump back
die "Long Jump\n";
}
+sub find_hook {
+ my ($self, $hook, $step) = @_;
+ croak "Missing hook name" if ! $hook;
+ if ($step && (my $code = $self->can("${step}_${hook}"))) {
+ return [$code, "${step}_${hook}"],
+ } elsif ($code = $self->can($hook)) {
+ return [$code, $hook];
+ } else {
+ return [];
+ }
+}
+
+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
+ }
+}
+
sub jump {
my $self = shift;
my $i = @_ == 1 ? shift : 1;
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
+ 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;
}
}
}
- if ($i !~ /^-?\d+$/) {
- require Carp;
- Carp::croak("Invalid jump index ($i)");
- }
+ croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/;
### 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];
- }
+ my $cut_i = $path_i + $i;
+ my @replace = ($cut_i > $#$path) ? $self->default_step
+ : ($cut_i < 0) ? @$path
+ : @$path[$cut_i .. $#$path];
$self->replace_path(@replace);
- ### record the number of jumps
- $self->{'jumps'} ||= 0;
- $self->{'jumps'} ++;
+ $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
- ### run the newly fixed up path (recursively)
- $self->{'path_i'} ++; # move along now that the path is updated
- $self->nav_loop;
+ $self->{'path_i'}++; # move along now that the path is updated
+ $self->nav_loop; # recurse on the path
$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 (! defined $resp) {
- $note .= ' - undef';
- } 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 js_uri_path {
+ my $self = shift;
+ 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)
+ : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
}
-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;
+ my $allow = $self->run_hook('allow_morph', $step) || return;
+ 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 ! $self->{'no_history'};
if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
$hist->{'found'} .= " (not allowed to morph to that step)";
### 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;
+ (my $file = "$new.pm") =~ 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;
+ bless $self, $new; # become that package
$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;
- }
+ } elsif ($@) {
+ 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;
-
- 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 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
- return $self->{'require_auth'} || 0;
-}
-
-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;
-
- 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->{'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 $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;
- 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 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->{'form'} ||= $self->cgix->get_form;
-}
-
-sub cookies {
- my $self = shift;
- $self->{'cookies'} = shift if @_ == 1;
- return $self->{'cookies'} ||= $self->cgix->get_cookies;
-}
-
-sub vob {
- my $self = shift;
- $self->{'vob'} = shift if @_ == 1;
- return $self->{'vob'} ||= do {
- require CGI::Ex::Validate;
- my $args = $self->vob_args;
- $args->{'cgix'} ||= $self->cgix;
- CGI::Ex::Validate->new($self->vob_args); # return of the do
- };
-}
-
-sub vob_args { shift->{'vob_args'} || {} }
-
-sub vob_path {
- my $self = shift;
- return $self->{'vob_path'} || $self->template_path;
-}
-
-### provide a place for placing variables
-sub stash {
- my $self = shift;
- 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;
-
- ### 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 template_path
- 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($self->mimetype($step), $self->charset($step));
- print ref($out) eq 'SCALAR' ? $$out : $out;
-}
-
-sub mimetype { shift->{'mimetype'} || 'text/html' }
-sub charset { shift->{'charset'} || '' }
-
-sub swap_template {
- my ($self, $step, $file, $swap) = @_;
-
- my $args = $self->run_hook('template_args', $step);
- $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
-
- my $t = $self->template_obj($args);
- my $out = '';
- $t->process($file, $swap, \$out) || die $t->error;
-
- return $out;
-}
-
-sub template_path {
- my $self = shift;
- return $self->{'template_path'} || $self->base_dir_abs;
-}
-
-sub template_args { shift->{'template_args'} || {} }
-
-sub template_obj {
- my ($self, $args) = @_;
-
- require CGI::Ex::Template;
- my $t = CGI::Ex::Template->new($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);
+
+ $hist->{'response'} = 1;
+ return 1;
}
-sub fill_args { shift->{'fill_args'} || {} }
+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 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 }
-sub post_step { 0 } # success indicates we handled step (don't continue step or loop)
+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)
+}
-sub morph_package {
+sub step_by_path_index {
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;
+ my $i = shift || 0;
+ my $ref = $self->path;
+ return '' if $i < 0;
+# return $self->default_step if $i > $#$ref;
+ return $ref->[$i];
}
-sub name_module {
+sub unmorph {
my $self = shift;
- my $step = shift || '';
+ my $step = shift || '_no_step';
+ my $lin = $self->{'_morph_lineage'} || return;
+ my $cur = ref $self;
- return $self->{'name_module'} ||= do {
- # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
- 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
- };
-}
+ my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
+ delete $self->{'_morph_lineage'} if ! @$lin;
-sub name_step {
- my ($self, $step) = @_;
- return $step;
+ my $hist = {step => $step, meth => 'unmorph', found => 'unmorph', time => time, elapsed => 0, response => 0};
+ push @{ $self->history }, $hist if ! $self->{'no_history'};
+
+ 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;
}
+###---------------------###
+# hooks
+
sub file_print {
- my $self = shift;
- my $step = shift;
+ my ($self, $step) = @_;
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";
+ my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step";
$_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
}
sub file_val {
- my $self = shift;
- my $step = shift;
+ my ($self, $step) = @_;
### determine the path to begin looking for files - allow for an arrayref
- my $abs = $self->vob_path || [];
+ my $abs = $self->val_path || [];
$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) || die "Missing name_step";
- $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
+ my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step";
+ $_step =~ s/\.\w+$//;
+ $_step .= '.'. $self->ext_val;
foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
return $abs->[0] . $base_dir . $module . $_step;
}
+sub fill_template {
+ my ($self, $step, $outref, $fill) = @_;
+ return if ! $fill || ! scalar keys %$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 finalize { 1 } # failure means show step
+
+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 => $self->script_name,
+ path_info => $self->path_info,
+ js_validation => sub { $copy->run_hook('js_validation', $step, shift) },
+ form_name => $self->run_hook('form_name', $step),
+ $self->step_key => $step,
+ }; # return of the do
+ };
+}
+
+sub hash_common { $_[0]->{'hash_common'} ||= {} }
+sub hash_errors { $_[0]->{'hash_errors'} ||= {} }
+sub hash_fill { $_[0]->{'hash_fill'} ||= {} }
+sub hash_form { $_[0]->form }
+sub hash_swap { $_[0]->{'hash_swap'} ||= {} }
+
+sub hash_validation {
+ my ($self, $step) = @_;
+ return $self->{'hash_validation'}->{$step} ||= do {
+ my $file = $self->run_hook('file_val', $step);
+ my $hash = $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies)
+ $hash; # return of the do
+ };
+}
+
sub info_complete {
my ($self, $step) = @_;
return 0 if ! $self->run_hook('ready_validate', $step);
return 1;
}
-sub ready_validate {
+sub js_validation {
+ my ($self, $step) = @_;
+ return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
+
+ my $form_name = $_[2] || $self->run_hook('form_name', $step);
+ my $hash_val = $_[3] || $self->run_hook('hash_validation', $step);
+ my $js_uri = $self->js_uri_path;
+ return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
+
+ return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
+}
+
+sub morph_package {
+ my ($self, $step) = @_;
+ my $cur = ref $self; # default to using self as the base for morphed modules
+ my $new = $cur .'::'. ($step || croak "Missing step");
+ $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
+ return $new;
+}
+
+sub name_module {
my ($self, $step) = @_;
- return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
+ return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
+ ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
+ : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")";
+}
+
+sub name_step { my ($self, $step) = @_; $step }
+sub next_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
+sub post_print { 0 }
+sub post_step { 0 } # success indicates we handled step (don't continue step or loop)
+sub pre_step { 0 } # success indicates we handled step (don't continue step or loop)
+sub prepare { 1 } # failure means show step
+
+sub print_out {
+ my ($self, $step, $out) = @_;
+
+ $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
+ print ref($out) eq 'SCALAR' ? $$out : $out;
+}
+
+sub ready_validate { ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 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 set_ready_validate { # hook and method
return $is_ready;
}
+sub skip { 0 } # success indicates to skip the step (and continue loop)
+
+sub swap_template {
+ my ($self, $step, $file, $swap) = @_;
+
+ my $args = $self->run_hook('template_args', $step) || {};
+ $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
+
+ my $t = $self->template_obj($args);
+ my $out = '';
+ $t->process($file, $swap, \$out) || die $t->error;
+ return $out;
+}
+
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) };
+ return 1 if ! ref($hash) || ! scalar keys %$hash;
+ my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) };
die "Step $step: $@" if $@ && ! $err_obj;
### had an error - store the errors and return false
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;
+###---------------------###
+# authentication
- ### 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 = {};
- }
+sub navigate_authenticated {
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
- $hash; # return of the do
- };
-}
+ croak "The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting"
+ if $self->can('require_auth') != \&CGI::Ex::App::require_auth;
-sub hash_base {
- my ($self, $step) = @_;
+ $self->require_auth(1);
- 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 => $self->script_name,
- path_info => $self->path_info,
- js_validation => sub { $copy->run_hook('js_validation', $step, shift) },
- form_name => $self->run_hook('form_name', $step),
- $self->step_key => $step,
- }; # return of the do
- };
+ return $self->navigate;
}
-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 {
+sub require_auth {
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;
+ $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
+ return $self->{'require_auth'} || 0;
}
-sub has_errors { scalar keys %{ shift->hash_errors } }
-
-sub format_error {
- my ($self, $error) = @_;
- return $error;
+sub is_authed {
+ my $data = shift->auth_data;
+ return $data && ! $data->{'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 check_valid_auth {
+ return shift->_do_auth({
+ login_print => sub {}, # check only - don't login if not
+ location_bounce => sub {}, # call get_valid_auth - but don't bounce to other locations
+ });
+}
-sub add_to_hash {
+sub get_valid_auth {
my $self = shift;
- my $old = shift;
- my $new = shift;
- $new = {$new, @_} if ! ref $new; # non-hashref
- $old->{$_} = $new->{$_} foreach keys %$new;
-}
+ return $self->_do_auth({
+ login_print => sub { # use CGI::Ex::Auth - but use our formatting and printing
+ my ($auth, $template, $hash) = @_;
+ 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};
-sub base_dir_rel {
- my $self = shift;
- $self->{'base_dir_rel'} = shift if @_ == 1;
- return $self->{'base_dir_rel'} || '';
+ 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);
+ }
+ });
}
-sub base_dir_abs {
- my $self = shift;
- $self->{'base_dir_abs'} = shift if @_ == 1;
- return $self->{'base_dir_abs'} || ['.']; # default to the current directory
-}
+sub _do_auth {
+ my ($self, $extra) = @_;
+ return $self->auth_data if $self->is_authed;
-sub ext_print {
- my $self = shift;
- $self->{'ext_print'} = shift if @_ == 1;
- return $self->{'ext_print'} || 'html';
-}
+ my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
+ $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->{'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) };
-sub ext_val {
- my $self = shift;
- $self->{'ext_val'} = shift if @_ == 1;
- return $self->{'ext_val'} || 'val';
-}
+ require CGI::Ex::Auth;
+ my $obj = CGI::Ex::Auth->new($args);
+ my $resp = $obj->get_valid_auth;
-### where to find the javascript files
-### default to using this script as a handler
-sub js_uri_path {
- my $self = shift;
- 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)
- : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
+ 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) ? $data : undef;
}
-###----------------------------------------------------------------###
-### 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.
+###---------------------###
+# default steps
+### 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 for js validation to work.
sub js_run_step {
my $self = shift;
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
-
+### A step that will be used the path method determines it is forbidden
sub __forbidden_info_complete { 0 }
-
-sub __forbidden_hash_swap { shift->stash }
-
+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
-
+### A step that is used by the default handle_error
sub __error_info_complete { 0 }
-
-sub __error_hash_swap { shift->stash }
-
+sub __error_hash_swap { shift->stash }
sub __error_file_print { \ "<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
-###----------------------------------------------------------------###
-
1;
### See the perldoc in CGI/Ex/App.pod
=cut
-use Test::More tests => 25;
+use Test::More tests => 214;
use strict;
+use warnings;
{
package Foo;
sub init { $test_stdout = '' }
- sub ready_validate { 1 }
-
sub print_out {
my $self = shift;
my $step = shift;
sub swap_template {
my ($self, $step, $file, $swap) = @_;
- my $out = ref($file) ? $$file : "No filenames allowed during test mode";
- $self->cgix->swap_template(\$out, $swap);
- return $out;
+ die "No filenames allowed during test mode" if ! ref($file);
+ return $self->SUPER::swap_template($step, $file, $swap);
}
- sub auth_args { {login_template => \q{Login Form}} }
+ sub auth_args { {login_template => \q{Login Form}, key_user => 'user', key_pass => 'pass', key_cookie => 'user', set_cookie => sub {}} }
+
+ sub get_pass_by_user { '123qwe' }
###----------------------------------------------------------------###
sub main_file_print { return \ "Main Content" }
+ sub main_path_info_map { shift->{'main_path_info_map'} }
+
sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} }
sub step2_path_info_map { [[qr{^/step2/(\w+)$}x, 'wow']] }
sub step3_info_complete { 0 }
sub step3_file_print { return \ "All good" }
+
+ sub step4_file_val { return {wow => {required => 1, required_error => 'wow is required'}} }
+
+ sub step4_path_info_map { [[qr{^/step4/(\w+)$}x, 'wow']] }
+
+ sub step4_file_print { return \ "Some step4 content ([% foo %], [% one %]) <form><input type=text name=wow>[% wow_error %]</form>[% js_validation %]" }
+
+ sub step4_hash_swap { return {foo => 'bar', one => 'two'} }
+
+ sub step4_hash_fill { return {wow => 'wee'} }
+
+ sub step4_finalize { shift->append_path('step3') }
+
}
###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+print "### Test some basic returns ###\n";
+
+ok(! eval { CGI::Ex::App::new() }, "Invalid new");
+ok(! eval { CGI::Ex::App::new(0) }, "Invalid new");
+
+my $app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar'});
+ok($app->script_name eq '/cgi-bin/foo_bar', "Can pass in script_name");
+ok($app->name_module eq 'foo_bar', "Can pass in script_name");
+
+$app = CGI::Ex::App->new({script_name => '/cgi-bin/foo_bar.pl'});
+ok($app->script_name eq '/cgi-bin/foo_bar.pl', "Can pass in script_name");
+ok($app->name_module eq 'foo_bar', "Can pass in script_name");
+
+ok(Foo->new(name_module => 'foo')->name_module eq 'foo', "Got the name_module");
+ok(! eval { Foo->new(script_name => '%####$')->name_module } && $@, "Bad script_name");
+ok(! eval { Foo->new(script_name => '%####$')->name_module('foo') } && $@, "Bad script_name");
+
+ok(! eval { $app->morph_package } && $@, "Can't get a good morph_package");
+ok($app->morph_package('foo') eq 'CGI::Ex::App::Foo', "Got a good morph_package");
+ok($app->morph_package('foo_bar') eq 'CGI::Ex::App::FooBar', "Got a good morph_package");
+
+ok(ref($app->path), "Got a good path");
+ok(@{ $app->path } == 0, "Got a good path");
+ok($app->default_step eq 'main', "Got a good default_step");
+ok($app->login_step eq '__login', "Got a good login_step");
+ok($app->error_step eq '__error', "Got a good error_step");
+ok($app->forbidden_step eq '__forbidden', "Got a good forbidden_step");
+ok($app->js_step eq 'js', "Got a good js_step");
+
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+print "### Test basic step selection/form input/validation/filling/template swapping methods ###\n";
#$ENV{'REQUEST_METHOD'} = 'GET';
#$ENV{'QUERY_STRING'} = '';
Foo->new({
form => {},
})->navigate;
-ok($Foo::test_stdout eq "Main Content", "Got the right output");
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo");
+
+{
+ package Foo2;
+ our @ISA = qw(Foo);
+ sub form { {} }
+}
+Foo2->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2");
###----------------------------------------------------------------###
-#$ENV{'REQUEST_METHOD'} = 'GET';
+{
+ package Foo2_1;
+ our @ISA = qw(Foo);
+ sub pre_navigate { 1 }
+}
+Foo2_1->navigate;
+ok($Foo::test_stdout eq "", "Got the right output for Foo2_1");
+
+Foo2_1->new({_no_pre_navigate => 1})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_1");
+
+{
+ package Foo2_2;
+ our @ISA = qw(Foo);
+ sub pre_loop { 1 }
+}
+Foo2_2->navigate;
+ok($Foo::test_stdout eq "", "Got the right output for Foo2_2");
+
+{
+ package Foo2_3;
+ our @ISA = qw(Foo);
+ sub post_loop { 1 }
+}
+Foo2_3->navigate;
+ok($Foo::test_stdout eq "", "Got the right output for Foo2_3");
+
+{
+ package Foo2_4;
+ our @ISA = qw(Foo);
+ sub post_navigate { $Foo::test_stdout .= " post"; 1 }
+}
+Foo2_4->navigate;
+ok($Foo::test_stdout eq "Main Content post", "Got the right output for Foo2_4");
+
+Foo2_4->new({_no_post_navigate => 1})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_4");
+
+###----------------------------------------------------------------###
+
+local $ENV{'REQUEST_METHOD'} = 'POST';
#$ENV{'QUERY_STRING'} = 'step=step2';
Foo->new({
form => {step => 'step2'},
})->navigate;
-ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output");
+ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output for Foo");
+
+Foo->new({
+ form => {step => 'step4'},
+})->navigate;
+ok($Foo::test_stdout =~ /Some step4 content.*wow is required.*<script>/s, "Got the right output for Foo (step4)");
+
+{
+ package Foo3;
+ our @ISA = qw(Foo);
+ sub main_info_complete { 1 }
+}
+eval { Foo3->navigate };
+ok($Foo::test_stdout =~ /recurse_limit \(15\)/, "Got the right output for Foo3");
+
+eval { Foo3->new({recurse_limit => 10})->navigate };
+ok($Foo::test_stdout =~ /recurse_limit \(10\)/, "Got the right output for Foo3");
###----------------------------------------------------------------###
Foo->new({
form=> {step => 'step2', wow => 'something'},
})->navigate;
-ok($Foo::test_stdout eq "All good", "Got the right output");
+ok($Foo::test_stdout eq "All good", "Got the right output for Foo");
+
+###----------------------------------------------------------------###
+
+#$ENV{'REQUEST_METHOD'} = 'GET';
+#$ENV{'QUERY_STRING'} = 'step=step2&wow=something';
+
+Foo->new({
+ form=> {step => '_bling'},
+})->navigate;
+ok($Foo::test_stdout =~ /Denied/i, "Got the right output for Foo");
+
+{
+ package Foo4;
+ our @ISA = qw(Foo);
+ sub path { shift->{'path'} ||= ['3foo'] }
+}
+Foo4->new({form => {}})->navigate;
+ok($Foo::test_stdout =~ /Denied/i, "Got the right output for Foo4");
###----------------------------------------------------------------###
})->navigate;
ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required", "Got the right output");
+Foo->new({
+ path_info_map_base => [],
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
+
+Foo->new({
+ path_info_map_base => [[qr{(?!)}, 'foo']],
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
+
+eval { Foo->new({
+ path_info_map_base => {},
+})->navigate };
+ok($Foo::test_stdout eq "", "Got the right output for Foo");
+
+eval { Foo->new({
+ path_info_map_base => [{}],
+})->navigate };
+ok($Foo::test_stdout eq "", "Got the right output for Foo");
+
+{
+ package Foo5;
+ our @ISA = qw(Foo);
+ sub path_info_map_base {}
+}
+Foo5->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo5");
+
+local $ENV{'PATH_INFO'} = '/blah';
+
+eval { Foo->new({
+ path_info_map_base => [],
+ main_path_info_map => {},
+})->navigate };
+ok($Foo::test_stdout =~ /fatal error.+path_info_map/, "Got the right output for Foo");
+
+eval { Foo->new({
+ path_info_map_base => [],
+ main_path_info_map => [{}],
+})->navigate };
+ok($Foo::test_stdout =~ /fatal error.+path_info_map/, "Got the right output for Foo");
+
###----------------------------------------------------------------###
#$ENV{'REQUEST_METHOD'} = 'GET';
###----------------------------------------------------------------###
+local $ENV{'PATH_INFO'} = '';
+
+{
+ package Foo6;
+ our @ISA = qw(Foo);
+ sub valid_steps { {step2 => 1} }
+ sub js_run_step { $Foo::test_stdout = 'JS' }
+}
+Foo6->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo6");
+
+Foo6->new({form => {step => 'main'}})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo6");
+
+Foo6->new({form => {step => 'step3'}})->navigate;
+ok($Foo::test_stdout =~ /denied/i, "Got the right output for Foo6");
+
+Foo6->new({form => {step => 'step2'}})->navigate;
+ok($Foo::test_stdout =~ /step2/i, "Got the right output for Foo6");
+
+Foo6->new({form => {step => Foo6->new->js_step}})->navigate;
+ok($Foo::test_stdout eq 'JS', "Got the right output for Foo6");
+
+
+
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+print "### Test Authorization Methods ###\n";
+
local $ENV{'PATH_INFO'} = '';
-local $ENV{'SCRIPT_NAME'} = '';
+local $ENV{'SCRIPT_NAME'} = '/foo';
Foo->new({
form => {},
})->navigate;
ok($Foo::test_stdout eq "Login Form", "Got the right output");
+Foo->new({
+ form => {},
+ cookies => {user => 'foo/123qwe'},
+ require_auth => 1,
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
+
+ok(Foo->new({
+ form => {},
+ cookies => {user => 'foo/123qwe'},
+})->check_valid_auth, "Ran check_valid_auth");
+
+my $cva = Foo->new({form => {}, cookies => {user => 'foo/123qwe'}});
+ok($cva->check_valid_auth && $cva->check_valid_auth, "Can run twice");
+
+
+
+ok(! Foo->new({
+ form => {},
+})->check_valid_auth, "Ran check_valid_auth");
+
+Foo->new({
+ form => {},
+ auth_data => {user => 'foo'},
+ require_auth => 1,
+})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo ($Foo::test_stdout)");
+
###----------------------------------------------------------------###
Foo->new({
ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar6 ($@)");
###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+print "### Test Configuration methods ###\n";
{
package Conf1;
our @ISA = qw(Foo);
- sub name_module { 'conf_1' }
+ sub name_module { my $self = shift; defined($self->{'name_module'}) ? $self->{'name_module'} : 'conf_1' }
}
my $file = Conf1->new->conf_file;
ok($file && $file eq 'conf_1.pl', "Got a conf_file ($file)");
-$file = Conf1->new({conf_ext => 'ini'})->conf_file;
+ok(! eval { Conf1->new(name_module => '')->conf_file } && $@, "Couldn't get conf_file");
+
+$file = Conf1->new({ext_conf => 'ini'})->conf_file;
ok($file && $file eq 'conf_1.ini', "Got a conf_file ($file)");
eval { Conf1->new({
my $err = $@;
ok($err, "Got an error");
chomp $err;
-ok($Foo::test_stdout eq "", "Got the right output for Conf1 ($err)");
+ok($Foo::test_stdout eq "", "Got the right output for Conf1");
Conf1->new({
load_conf => 1,
})->navigate;
ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
+Conf1->new({
+ load_conf => 1,
+ conf_file => {form => {step => 'step3'}},
+})->navigate;
+ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
+
+Conf1->new({
+ load_conf => 1,
+ conf_file => {form => {step => 'step3'}},
+ conf_validation => {form => {required => 1}},
+})->navigate;
+ok($Foo::test_stdout eq "All good", "Got the right output for Conf1");
+
+eval { Conf1->new({
+ load_conf => 1,
+ conf_file => {},
+ conf_validation => {form => {required => 1}},
+})->navigate };
+ok($Foo::test_stdout eq "" && $@, "Got a conf_validation error");
+
+###----------------------------------------------------------------###
###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+###----------------------------------------------------------------###
+print "### Various other coverage tests\n";
+
+ok(Conf1->new->conf_obj, "Got a conf_obj");
+ok(Conf1->new(conf_args => {paths => './', directive => 'merge'})->conf_obj, "Got a conf_obj");
+ok(Conf1->new->val_obj, "Got a val_obj");
+ok(Conf1->new(val_args => {cgix => Conf1->new->cgix})->val_obj, "Got a val_obj");
+ok(Conf1->new->load_conf(1), "Ran load_conf");
+
+ok(Foo2->navigate->clear_app, "clear_app works");
+
+my $dh = Foo2->navigate;
+push @{ $dh->history }, "A string", ['A non ref'], {key => 'No elapsed key'};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 2, response => {}};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 2, response => {hi => 'there'}};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => []};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => ['hi']};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => 'a'};
+push @{ $dh->history }, {step => 'foo', meth => 'bar', found => 'bar', elapsed => 1, response => 'a'x100};
+ok($dh->dump_history, "Can call dump_history");
+ok($dh->dump_history('all'), "Can call dump_history");
+$dh->{'history_max'} = 10;
+ok($dh->dump_history('all'), "Can call dump_history");
+
+{
+ package Foo7;
+ our @ISA = qw(Foo);
+ sub hash_base {}
+ sub hash_common {}
+ sub hash_form {}
+ sub hash_fill {}
+ sub hash_swap {}
+ sub hash_errors {}
+ sub find_hook { my ($self, $hook, $step) = @_; return $self->SUPER::find_hook($hook, $step) if $step eq 'main'; return ["non_code",1] }
+}
+Foo7->new({no_history => 1})->navigate;
+ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo7 ($Foo::test_stdout)");
+
+ok( eval { Foo->new->run_hook('hash_base', 'main') }, "Can run_hook main hash_base on Foo");
+ok(! eval { Foo->new->run_hook('bogus', 'main') }, "Can't run_hook main bogus on Foo");
+ok(! eval { Foo7->new->run_hook('hash_base', 'bogus') }, "Can't run_hook bogus hash_base on Foo7 for other reasons");
+
+foreach my $meth (qw(auth_args conf_args template_args val_args)) {
+ ok(! CGI::Ex::App->new->$meth, "Got a good $meth");
+ ok(CGI::Ex::App->new($meth => {a=>'A'})->$meth->{'a'} eq 'A', "Got a good $meth");
+}
+
+### test read only
+foreach my $meth (qw(charset
+ conf_die_on_fail
+ conf_obj
+ conf_path
+ conf_validation
+ default_step
+ error_step
+ forbidden_step
+ js_step
+ login_step
+ mimetype
+ path_info
+ path_info_map_base
+ script_name
+ step_key
+ template_obj
+ template_path
+ val_obj
+ val_path
+ )) {
+ ok(CGI::Ex::App->new($meth => 'blah')->$meth eq 'blah', "I can set $meth");
+}
+
+### test read/write
+foreach my $meth (qw(base_dir_abs
+ base_dir_rel
+ cgix
+ conf
+ conf_file
+ cookies
+ ext_conf
+ ext_print
+ ext_val
+ form
+ )) {
+ ok(CGI::Ex::App->new($meth => 'blah')->$meth eq 'blah', "I can set $meth");
+ my $c = CGI::Ex::App->new;
+ $c->$meth('blah');
+ ok($c->$meth eq 'blah', "I can set $meth");
+}
+
+foreach my $type (qw(base
+ common
+ errors
+ fill
+ form
+ swap
+ )) {
+ my $meth = "hash_$type";
+ ok(CGI::Ex::App->new("hash_$type" => {bing => 'bang'})->$meth->{'bing'} eq 'bang', "Can initialize $meth")
+ if $type ne 'form';
+
+ my $meth2 = "add_to_$type";
+ my $c = CGI::Ex::App->new;
+ $c->$meth2({bing => 'bang'});
+ $c->$meth2(bong => 'beng');
+
+ if ($type eq 'errors') {
+ $c->$meth2({bing => "wow"});
+ ok($c->$meth->{"bing_error"} eq "bang<br>wow", "$meth2 works");
+ ok($c->$meth->{"bong_error"} eq 'beng', "$meth2 works");
+
+ ok($c->has_errors, "has_errors works") if $type eq 'errors';
+ } else {
+ ok($c->$meth->{'bing'} eq 'bang', "$meth2 works");
+ ok($c->$meth->{'bong'} eq 'beng', "$meth2 works");
+ }
+}
+
+ok(! eval { CGI::Ex::App->new->get_pass_by_user } && $@, "Got a good error for get_pass_by_user");
+ok(! eval { CGI::Ex::App->new->find_hook } && $@, "Got a good error for find_hook");
+
+###----------------------------------------------------------------###
+print "### Some morph tests ###\n";
+
+{
+ package Foo8;
+ our @ISA = qw(Foo);
+
+ sub blah1_pre_step { $Foo::test_stdout = 'blah1_pre'; 1 }
+ sub blah2_skip { 1 }
+ sub blah3_info_complete { 1 }
+ sub blah3_post_step { $Foo::test_stdout = 'blah3_post'; 1 }
+
+ sub blah4_prepare { 0 }
+ sub blah4_file_print { \ 'blah4_file_print' }
+
+ sub blah5_finalize { 0 }
+ sub blah5_info_complete { 1 }
+ sub blah5_file_print { \ 'blah5_file_print' }
+
+ sub blah8_morph_package { 'Foo8' }
+ sub blah8_info_complete { 0 }
+ sub blah8_file_print { \ 'blah8_file_print' }
+
+ sub blah6_allow_morph { 1 }
+ package Foo8::Blah6;
+ our @ISA = qw(Foo8);
+ sub info_complete { 0 }
+ sub file_print { \ 'blah6_file_print' }
+ sub early_exit_run_step { $Foo::test_stdout = 'early'; shift->exit_nav_loop }
+
+ sub blah7_allow_morph { 1 }
+ package Foo8::Blah6::Blah7;
+ our @ISA = qw(Foo8::Blah6);
+ sub info_complete { 0 }
+ sub file_print { \ 'blah7_file_print' }
+}
+
+Foo8->new({form => {step => 'blah1'}})->navigate;
+ok($Foo::test_stdout eq 'blah1_pre', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah1'}, allow_morph => 1})->navigate;
+ok($Foo::test_stdout eq 'blah1_pre', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah2'}})->navigate;
+ok($Foo::test_stdout eq 'Main Content', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah3'}})->navigate;
+ok($Foo::test_stdout eq 'blah3_post', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah4'}})->navigate;
+ok($Foo::test_stdout eq 'blah4_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah5'}})->navigate;
+ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah5'}, allow_morph => 1})->navigate;
+ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah5'}, allow_morph => 0})->navigate;
+ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah5'}, allow_morph => {}})->navigate;
+ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah5'}, allow_morph => {blah5 => 1}})->navigate;
+ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah6'}})->navigate;
+ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8");
+
+Foo8->new({form => {step => 'blah8'}, allow_morph => 1})->navigate;
+ok($Foo::test_stdout eq 'blah8_file_print', "Got the right output for Foo8 ($Foo::test_stdout)");
+
+my $foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => 1});
+$foo8->morph('blah6');
+$foo8->navigate;
+ok($Foo::test_stdout eq 'blah7_file_print', "Got the right output for Foo8");
+
+$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => {blah7 => 1}});
+$foo8->morph('blah6');
+$foo8->navigate;
+ok($Foo::test_stdout eq 'blah7_file_print', "Got the right output for Foo8");
+
+$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => {blah9 => 1}});
+$foo8->morph('blah6');
+$foo8->navigate;
+ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8");
+
+$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => 0});
+$foo8->morph('blah6');
+$foo8->navigate;
+ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8");
+
+$foo8 = Foo8->new({form => {step => 'early_exit'}, no_history => 1});
+$foo8->morph('blah6');
+$foo8->navigate;
+ok($Foo::test_stdout eq 'early', "Got the right output for Foo8");
+ok(ref($foo8) eq 'Foo8::Blah6', 'Still is unmorphed right');
+
+$foo8 = Foo8->new;
+$foo8->morph;
+ok(ref($foo8) eq 'Foo8', 'Got the right class');
+$foo8->morph('blah6');
+eval { $foo8->exit_nav_loop }; # coverage
+ok($@, "Got the die from exit_nav_loop");
+
+###----------------------------------------------------------------###
+print "### Some path tests tests ###\n";
+
+{
+ package Foo9;
+ our @ISA = qw(Foo);
+ sub file_print {
+ my $self = shift;
+ my $str = "First(".$self->first_step.") Previous(".$self->previous_step.") Current(".$self->current_step.") Next(".$self->next_step.") Last(".$self->last_step.")";
+ return \$str;
+ }
+ sub one_skip { 1 }
+ sub two_skip { 1 }
+ sub info_complete { 0 }
+ sub invalid_run_step { shift->jump('::') }
+}
+ok(Foo9->new->previous_step eq '', 'No previous step if not navigating');
+
+my $c = Foo9->new(form => {step => 'one'});
+$c->add_to_path('three', 'four', 'five');
+$c->insert_path('one', 'two');
+$c->navigate;
+ok($Foo::test_stdout eq 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9");
+ok(! eval { $c->set_path("more") }, "Can't call set_path after nav started");
+
+$c = Foo9->new(form => {step => 'five'});
+$c->set_path('one', 'two', 'three', 'four', 'five');
+$c->navigate;
+ok($Foo::test_stdout eq 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9");
+
+$c = Foo9->new;
+$c->append_path('one');
+eval { $c->jump('FIRST') };
+ok($Foo::test_stdout eq '', "Can't jump without nav_loop");
+
+eval { Foo9->new(form => {step => 'invalid'})->navigate };
+ok($Foo::test_stdout =~ /fatal.*invalid jump index/si, "Can't jump with invalid step");
+
+###----------------------------------------------------------------###
+
+{
+ package Foo10;
+ our @ISA = qw(Foo);
+
+ sub join_path {
+ my $self = shift;
+ my $s = join "", @{ $self->path };
+ substr($s, $self->{'path_i'}, 0, '(');
+ substr($s, $self->{'path_i'} + 2, 0, ')');
+ return $s;
+ }
+
+ #sub run_hook {
+ # my ($self, $hook, $step) = @_;
+ # print "Into $step: ".$self->join_path."\n" if $hook eq 'run_step';
+ # return $self->SUPER::run_hook($hook, $step);
+ #}
+
+ sub a_run_step {
+ my $self = shift;
+ if ($self->join_path eq '(a)') {
+ $self->append_path('b', 'c', 'd', 'e');
+ $self->jump('CURRENT');
+ } elsif ($self->join_path eq 'a(a)bcde') {
+ $self->jump('NEXT');
+ } elsif ($self->join_path eq 'aab(a)bcde') {
+ $self->jump(1);
+ } elsif ($self->join_path eq 'aabab(a)ababcde') {
+ $self->jump('c');
+ } elsif ($self->join_path eq 'aababacd(a)ababacde') {
+ $self->jump('LAST');
+ } else {
+ die "Shouldn't get here";
+ }
+ }
+
+ sub b_run_step {
+ my $self = shift;
+ if ($self->join_path eq 'aa(b)cde') {
+ $self->jump('PREVIOUS');
+ } elsif ($self->join_path eq 'aaba(b)cde') {
+ $self->jump(-10);
+ } else {
+ die "Shouldn't get here";
+ }
+ }
+
+ sub c_run_step { 0 }
+
+ sub d_run_step { shift->jump('FIRST') }
+
+ sub e_run_step {
+ my $self = shift;
+ $self->replace_path(); # truncate
+ $self->jump(1);
+ }
+
+ sub default_step { 'z' }
+
+ sub z_run_step { 1 }
+
+ sub __error_run_step { 1 }
+}
+
+my $Foo10 = Foo10->new(form => {step => 'a'});
+$Foo10->navigate;
+ok($Foo10->join_path eq 'aababacdae(z)', 'Followed good path: '.$Foo10->join_path);
+
+###----------------------------------------------------------------###
+
+{
+ package Foo11;
+ our @ISA = qw(Foo);
+ sub step1_skip { 1 }
+ sub step1_next_step { 'step6' }
+ sub step6_file_print { \ 'step6_file_print' }
+ sub step2_name_step { '' }
+ sub step3_name_step { 'foo.htm' }
+
+ package Foo12;
+ our @ISA = qw(Foo11);
+ sub val_path { '' }
+}
+
+local $ENV{'SCRIPT_NAME'} = '/cgi/ralph.pl';
+ok(Foo11->new->file_print("george") eq 'ralph/george.html', 'file_print: '. Foo11->new->file_print("george"));
+ok(Foo11->new->file_val("george") =~ m|\Q/ralph/george.val\E|, 'file_val: '. Foo11->new->file_val("george"));
+ok(ref(Foo12->new->file_val("george")) eq 'HASH', 'file_val: no such path');
+ok(Foo11->new(val_path => '../' )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => sub {'../'} )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => ['../'] )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => ['../', './'])->file_val("george") eq '../ralph/george.val', 'file_val');
+
+ok(! eval { Foo11->new->file_print("step2") } && $@, 'Bad name_step');
+ok(! eval { Foo11->new->file_val("step2") } && $@, 'Bad name_step');
+
+ok(Foo11->new->file_print("step3") eq 'ralph/foo.htm', 'file_print: '. Foo11->new->file_print("step3"));
+ok(Foo11->new->file_val("step3") =~ m|\Q/ralph/foo.val\E|, 'file_val: '. Foo11->new->file_val("step3"));
+
+
+local $ENV{'REQUEST_METHOD'} = 'POST';
+
+Foo11->new(form => {step => 'step1'})->navigate;
+ok($Foo::test_stdout eq 'step6_file_print', "Refine Path and set_ready_validate work ($Foo::test_stdout)");
+
+Foo11->set_ready_validate(1);
+ok(Foo11->ready_validate, "Is ready to validate");
+Foo11->set_ready_validate(0);
+ok(! Foo11->ready_validate, "Not ready to validate");
+Foo11->set_ready_validate(1);
+ok(Foo11->ready_validate, "Is ready to validate");
+Foo11->set_ready_validate('somestep', 0);
+ok(! Foo11->ready_validate, "Not ready to validate");
+
+###----------------------------------------------------------------###
+
+{
+ package Foo13;
+ our @ISA = qw(Foo);
+ sub step0_ready_validate { 1 }
+ sub step0_hash_validation { {foo => {required => 1}} }
+
+ sub step1_ready_validate { 1 }
+ sub step1_form_name { shift->{'step1_form_name'} }
+ sub step1_hash_validation { shift->{'step1_hash_validation'} }
+ sub step1_file_print { \ 'step1_file_print [% has_errors %]' }
+}
+
+ok(Foo13->new(ext_val => 'html')->navigate->js_validation('step0') eq '', 'Got right validation');
+ok($Foo::test_stdout eq 'Main Content', "Got the right content on Foo13 ($Foo::test_stdout)");
+
+Foo13->new(form => {step => 'step1'})->navigate->js_validation('step1');
+ok($Foo::test_stdout eq 'Main Content', "Got the right content on Foo13");
+
+ok(Foo13->new->js_validation('step1') eq '', "No validation found");
+ok(Foo13->new->js_validation('step1', 'foo') eq '', "No validation found");
+ok(Foo13->new->js_validation('step1', 'foo', {}) eq '', "No validation found");
+ok(Foo13->new->js_validation('step1', 'foo', {foo => {required => 1}}), "Validation found");
+
+###----------------------------------------------------------------###
+
+{
+ package CGIX;
+ sub new { bless {}, __PACKAGE__ }
+ sub get_form { {} }
+ sub print_js {
+ my ($self, $file) = @_;
+ $Foo::test_stdout = "Print JS: $file";
+ }
+ sub print_content_type {
+ my $self = shift;
+ my $mime = shift || 'text/html';
+ my $char = shift || '';
+ $mime .= "; charset=$char" if $char && $char =~ m|^[\w\-\.\:\+]+$|;
+ $Foo::test_stdout = "Print: $mime";
+ }
+}
+
+CGI::Ex::App->new(cgix => CGIX->new)->js_run_step;
+ok($Foo::test_stdout eq 'Print JS: ', "Ran js_run_step: $Foo::test_stdout");
+
+CGI::Ex::App->new(cgix => CGIX->new, form => {js => 'CGI/Ex/validate.js'})->js_run_step;
+ok($Foo::test_stdout eq 'Print JS: CGI/Ex/validate.js', "Ran js_run_step: $Foo::test_stdout");
+
+CGI::Ex::App->new(cgix => CGIX->new, path_info => '/js/CGI/Ex/validate.js')->js_run_step;
+ok($Foo::test_stdout eq 'Print JS: CGI/Ex/validate.js', "Ran js_run_step: $Foo::test_stdout");
+
+CGI::Ex::App->new(cgix => CGIX->new)->print_out('foo', "# the output\n");
+ok($Foo::test_stdout eq 'Print: text/html', "Got right header: $Foo::test_stdout");
+CGI::Ex::App->new(cgix => CGIX->new, mimetype => 'img/gif')->print_out('foo', "# the output\n");
+ok($Foo::test_stdout eq 'Print: img/gif', "Got right header: $Foo::test_stdout");
+CGI::Ex::App->new(cgix => CGIX->new, charset => 'ISO-foo')->print_out('foo', "# the output\n");
+ok($Foo::test_stdout eq 'Print: text/html; charset=ISO-foo', "Got right header: $Foo::test_stdout");
+
+CGI::Ex::App->new(cgix => CGIX->new)->print_out('foo', \ "# the output\n");
+ok($Foo::test_stdout eq 'Print: text/html', "Got right header: $Foo::test_stdout");
+
+###----------------------------------------------------------------###\
projects / chaz / p5-CGI-Ex / commitdiff
