3 ###----------------------------------------------------------------###
4 # See the perldoc in CGI/Ex/App.pod
5 # Copyright 2007 - Paul Seamons #
6 # Distributed under the Perl Artistic License without warranty #
7 ###----------------------------------------------------------------###
10 use vars
qw($VERSION);
15 Time
::HiRes-
>import('time') if eval {require Time
::HiRes
};
16 eval {require Scalar
::Util
};
21 $msg = 'Something happened' if ! defined $msg;
22 die $msg if ref $msg || $msg =~ /\n\z/;
23 my ($pkg, $file, $line, $sub) = caller(1);
24 die "$msg in ${sub}() at $file line $line\n";
27 ###----------------------------------------------------------------###
30 my $class = shift || croak
"Usage: Package->new";
31 my $self = shift || {};
36 $self->init_from_conf;
45 ###----------------------------------------------------------------###
49 return if ! $self->load_conf;
50 my $conf = $self->conf;
51 @{ $self }{ keys %$conf } = values %$conf;
55 sub load_conf
{ shift-
>{'load_conf'} ||= @_ ? 1 : 0 }
59 return $self->{'conf'} ||= do {
60 my $conf = $self->conf_obj->read($self->conf_file, {no_warn_on_fail
=> 1}) || croak
$@;
61 my $hash = $self->conf_validation;
62 if ($hash && scalar keys %$hash) {
63 my $err_obj = $self->vob->validate($conf, $hash);
64 die $err_obj if $err_obj;
72 return $self->{'conf_path'} || $self->base_dir_abs;
77 return $self->{'conf_file'} ||= do {
78 my $module = $self->name_module || croak
'Missing name_module during conf_file call';
79 $module .'.'. $self->conf_ext;
85 $self->{'conf_ext'} = shift if @_ == 1;
86 return $self->{'conf_ext'} || 'pl';
89 sub conf_args
{ shift-
>{'conf_args'} || {} }
93 return $self->{'conf_obj'} || do {
94 my $args = $self->conf_args;
95 $args->{'paths'} ||= $self->conf_path;
96 $args->{'directive'} ||= 'MERGE';
97 require CGI
::Ex
::Conf
;
98 CGI
::Ex
::Conf-
>new($args);
102 sub conf_validation
{}
104 ###----------------------------------------------------------------###
107 my ($self, $args) = @_;
108 $self = $self->new($args) if ! ref $self;
110 $self->{'_time'} = time;
113 ### a chance to do things at the very beginning
114 return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
116 ### run the step loop
118 local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
122 ### rethrow the error unless we long jumped out of recursive nav_loop calls
123 croak
$@ if $@ ne "Long Jump\n";
126 ### one chance to do things at the very end
127 $self->post_navigate if ! $self->{'_no_post_navigate'};
131 $self->handle_error($@) if $@; # catch any errors
133 $self->{'_time'} = time;
143 ### keep from an infinate nesting
144 local $self->{'_recurse'} = $self->{'_recurse'} || 0;
145 if ($self->{'_recurse'}++ >= $self->recurse_limit) {
146 my $err = "recurse_limit (".$self->recurse_limit.") reached";
147 $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
151 my $path = $self->path;
153 ### allow for an early return
154 return if $self->pre_loop($path); # a true value means to abort the navigate
156 ### iterate on each step of the path
157 foreach ($self->{'path_i'} ||= 0;
158 $self->{'path_i'} <= $#$path;
159 $self->{'path_i'} ++) {
160 my $step = $path->[$self->{'path_i'}];
161 if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
162 $self->stash->{'forbidden_step'} = $step;
163 $self->replace_path($self->forbidden_step);
166 $step = $1; # untaint
168 ### allow for per-step authentication
169 if (! $self->is_authed) {
170 my $req = $self->run_hook('require_auth', $step, 1);
171 if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
172 return if ! $self->get_valid_auth;
176 ### allow for becoming another package (allows for some steps in external files)
179 ### allow for mapping path_info pieces to form elements
180 if (my $info = $self->path_info) {
181 my $maps = $self->run_hook('path_info_map', $step) || [];
182 croak
'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }'
183 if ! UNIVERSAL
::isa
($maps, 'ARRAY') || (@$maps && ! UNIVERSAL
::isa
($maps->[0], 'ARRAY'));
184 foreach my $map (@$maps) {
185 my @match = $info =~ $map->[0];
187 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
192 ### run the guts of the step
193 my $handled = $self->run_hook('run_step', $step);
195 ### Allow for the run_step to intercept.
196 ### A true status means the run_step took over navigation.
198 $self->unmorph($step);
202 ### if there are no future steps - allow for this step to designate one to follow
203 my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
204 $self->run_hook('refine_path', $step, $is_at_end);
206 $self->unmorph($step);
209 ### allow for one exit point after the loop
210 return if $self->post_loop($path); # a true value means to abort the navigate
212 ### run the default step as a last resort
213 $self->insert_path($self->default_step);
214 $self->nav_loop; # go recursive
219 sub pre_navigate
{ 0 } # true means to not enter nav_loop
223 sub pre_loop
{ 0 } # true value means to abort the nav_loop routine
225 sub post_loop
{ 0 } # true value means to abort the nav_loop - don't recurse
227 sub recurse_limit
{ shift-
>{'recurse_limit'} || 15 }
229 ### default die handler - show what happened and die (so its in the error logs)
234 die $err if $self->{'_handling_error'};
235 local $self->{'_handling_error'} = 1;
236 local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error
238 $self->stash->{'error_step'} = $self->current_step;
239 $self->stash->{'error'} = $err;
240 $self->replace_path($self->error_step);
241 $self->jump; # exits nav loop when finished
244 ###----------------------------------------------------------------###
246 sub default_step
{ shift-
>{'default_step'} || 'main' }
247 sub js_step
{ shift-
>{'js_step'} || 'js' }
248 sub login_step
{ shift-
>{'login_step'} || '__login' }
249 sub error_step
{ shift-
>{'error_step'} || '__error' }
250 sub forbidden_step
{ shift-
>{'forbidden_step'} || '__forbidden' }
252 sub step_key
{ shift-
>{'step_key'} || 'step' }
256 if (! $self->{'path'}) {
257 my $path = $self->{'path'} = []; # empty path
259 ### add initial items to the form hash from path_info5B
260 if (my $info = $self->path_info) {
261 my $maps = $self->path_info_map_base || [];
262 croak
'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }'
263 if ! UNIVERSAL
::isa
($maps, 'ARRAY') || (@$maps && ! UNIVERSAL
::isa
($maps->[0], 'ARRAY'));
264 foreach my $map (@$maps) {
265 my @match = $info =~ $map->[0];
267 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
272 ### make sure the step is valid
273 my $step = $self->form->{$self->step_key};
275 if ($step =~ /^_/) { # can't begin with _
276 $self->stash->{'forbidden_step'} = $step;
277 push @$path, $self->forbidden_step;
278 } elsif ($self->valid_steps # must be in valid_steps if defined
279 && ! $self->valid_steps->{$step}
280 && $step ne $self->default_step
281 && $step ne $self->js_step) {
282 $self->stash->{'forbidden_step'} = $step;
283 push @$path, $self->forbidden_step;
290 return $self->{'path'};
293 sub path_info_map_base
{
295 return [[qr{/(\w+)}, $self->step_key]];
300 my $path = $self->{'path'} ||= [];
301 croak
"Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
302 splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
305 ### legacy - same as append_path
308 push @{ $self->path }, @_;
313 push @{ $self->path }, @_;
318 my $ref = $self->path;
319 my $i = $self->{'path_i'} || 0;
320 if ($i + 1 > $#$ref) {
323 splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
329 my $ref = $self->path;
330 my $i = $self->{'path_i'} || 0;
331 if ($i + 1 > $#$ref) {
334 splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
338 ### a hash of paths that are allowed, default undef is all are allowed
341 ###----------------------------------------------------------------###
342 ### allow for checking where we are in the path and for jumping around
348 if (my $ref = $self->{'_morph_lineage'}) {
349 ### use the saved index - this allows for early "morphers" to only get rolled back so far
350 my $index = $self->{'_morph_lineage_start_index'};
351 $index = -1 if ! defined $index;
352 $self->unmorph while $#$ref != $index;
361 my $i = @_ == 1 ? shift : 1;
362 my $path = $self->path;
363 my $path_i = $self->{'path_i'};
364 croak
"Can't jump if nav_loop not started" if ! defined $path_i;
366 ### validate where we are jumping to
370 } elsif ($i eq 'LAST') {
371 $i = $#$path - $path_i;
372 } elsif ($i eq 'NEXT') {
374 } elsif ($i eq 'CURRENT') {
376 } elsif ($i eq 'PREVIOUS') {
378 } else { # look for a step by that name
379 for (my $j = $#$path; $j >= 0; $j --) {
380 if ($path->[$j] eq $i) {
387 if ($i !~ /^-?\d+$/) {
389 Carp
::croak
("Invalid jump index ($i)");
392 ### manipulate the path to contain the new jump location
394 my $cut_i = $path_i + $i;
395 if ($cut_i > $#$path) {
396 push @replace, $self->default_step;
397 } elsif ($cut_i < 0) {
398 push @replace, @$path;
400 push @replace, @$path[$cut_i .. $#$path];
402 $self->replace_path(@replace);
404 ### record the number of jumps
405 $self->{'jumps'} ||= 0;
408 ### run the newly fixed up path (recursively)
409 $self->{'path_i'} ++; # move along now that the path is updated
411 $self->exit_nav_loop;
414 sub step_by_path_index
{
417 my $ref = $self->path;
419 return $self->default_step if $i > $#$ref;
425 return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
430 return $self->step_by_path_index( ($self->{'path_i'} || 0) );
433 sub next_step
{ # method and hook
435 return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
440 return $self->step_by_path_index( $#{ $self->path } );
445 return $self->step_by_path_index( 0 );
448 ###----------------------------------------------------------------###
449 ### hooks and history
453 my $hook = shift || do { require Carp
; Carp
::confess
("Missing hook name") };
454 my $step = shift || '';
456 if ($step && ($code = $self->can("${step}_${hook}"))) {
457 return [$code, "${step}_${hook}"],
459 } elsif ($code = $self->can($hook)) {
460 return [$code, $hook];
473 my ($code, $found) = @{ $self->find_hook($hook, $step) };
475 croak
"Could not find a method named ${step}_${hook} or ${hook}";
476 } elsif (! UNIVERSAL
::isa
($code, 'CODE')) {
477 croak
"Value for $hook ($found) is not a code ref ($code)";
488 push @{ $self->history }, $hist;
490 $hist->{'level'} = $self->{'_level'};
491 local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
493 $hist->{'elapsed'} = time - $hist->{'time'};
495 my $resp = $self->$code($step, @_);
497 $hist->{'elapsed'} = time - $hist->{'time'};
498 $hist->{'response'} = $resp;
504 return shift-
>{'history'} ||= [];
509 my $all = shift || 0;
510 my $hist = $self->history;
512 push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
514 ### show terse - yet informative info
515 foreach my $row (@$hist) {
517 || ref($row) ne 'HASH'
518 || ! exists $row->{'elapsed'}) {
521 my $note = (' ' x
($row->{'level'} || 0))
522 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
523 my $resp = $row->{'response'};
524 if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
526 } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
528 } elsif (! defined $resp) {
530 } elsif (! ref $resp || ! $all) {
531 my $max = $self->{'history_max'} || 30;
532 if (length($resp) > $max) {
533 $resp = substr($resp, 0, $max);
539 $note = [$note, $resp];
549 ###----------------------------------------------------------------###
550 ### utility methods to allow for storing separate steps in other modules
554 return $self->{'allow_morph'} ? 1 : 0;
557 sub allow_nested_morph
{
559 return $self->{'allow_nested_morph'} ? 1 : 0;
564 my $step = shift || return;
565 my $allow = $self->allow_morph($step) || return;
567 ### place to store the lineage
568 my $lin = $self->{'_morph_lineage'} ||= [];
569 my $cur = ref $self; # what are we currently
570 push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
580 push @{ $self->history }, $hist;
582 if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
583 $hist->{'found'} .= " (not allowed to morph to that step)";
587 ### make sure we haven't already been reblessed
588 if ($#$lin != 0 # is this the second morph call
589 && (! ($allow = $self->allow_nested_morph($step)) # not true
590 || (ref($allow) && ! $allow->{$step}) # hash - but no step
592 $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
593 return 0; # just return - don't die so that we can morph early
596 ### if we are not already that package - bless us there
597 my $new = $self->run_hook('morph_package', $step);
599 my $file = $new .'.pm';
601 if (UNIVERSAL
::can
($new, 'can') # check if the package space exists
602 || eval { require $file }) { # check for a file that holds this package
603 ### become that package
605 $hist->{'found'} .= " (changed $cur to $new)";
606 $self->fixup_after_morph($step);
609 if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
610 $hist->{'found'} .= " (failed from $cur to $new: $1)";
612 $hist->{'found'} .= " (failed from $cur to $new: $@)";
613 my $err = "Trouble while morphing to $file: $@";
620 $hist->{'response'} = 1;
626 my $step = shift || '_no_step';
627 my $lin = $self->{'_morph_lineage'} || return;
630 my $prev = pop(@$lin) || croak
"unmorph called more times than morph - current ($cur)";
631 delete $self->{'_morph_lineage'} if ! @$lin;
633 ### if we are not already that package - bless us there
642 push @{ $self->history }, $hist;
645 $self->fixup_before_unmorph($step);
647 $hist->{'found'} .= " (changed from $cur to $prev)";
649 $hist->{'found'} .= " (already isa $cur)";
652 $hist->{'response'} = 1;
656 sub fixup_after_morph
{}
658 sub fixup_before_unmorph
{}
660 ###----------------------------------------------------------------###
661 ### allow for authentication
663 sub navigate_authenticated
{
664 my ($self, $args) = @_;
665 $self = $self->new($args) if ! ref $self;
667 if ($self->can('require_auth') != \
&CGI
::Ex
::App
::require_auth
) {
669 Carp
::croak
("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting");
671 $self->require_auth(1);
673 return $self->navigate;
678 $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
679 return $self->{'require_auth'} || 0;
682 sub is_authed
{ shift-
>auth_data }
686 $self->{'auth_data'} = shift if @_ == 1;
687 return $self->{'auth_data'};
692 return 1 if $self->is_authed;
694 my $args = $self->auth_args;
696 ### allow passed in args
697 if (my $extra = shift) {
698 $args = {%$args, %$extra};
701 ### augment the args with sensible defaults
702 $args->{'script_name'} ||= $self->script_name;
703 $args->{'path_info'} ||= $self->path_info;
704 $args->{'cgix'} ||= $self->cgix;
705 $args->{'form'} ||= $self->form;
706 $args->{'cookies'} ||= $self->cookies;
707 $args->{'js_uri_path'} ||= $self->js_uri_path;
708 $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
709 $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
710 $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
711 $args->{'login_print'} ||= sub {
712 my ($auth, $template, $hash) = @_;
713 my $step = $self->login_step;
714 my $hash_base = $self->run_hook('hash_base', $step) || {};
715 my $hash_comm = $self->run_hook('hash_common', $step) || {};
716 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
717 my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
719 my $out = $self->run_hook('swap_template', $step, $template, $swap);
720 $self->run_hook('fill_template', $step, \
$out, $hash);
721 $self->run_hook('print_out', $step, \
$out);
724 require CGI
::Ex
::Auth
;
725 my $obj = CGI
::Ex
::Auth-
>new($args);
726 my $resp = $obj->get_valid_auth;
728 my $data = $obj->last_auth_data;
729 delete $data->{'real_pass'} if defined $data; # data may be defined but false
730 $self->auth_data($data); # failed authentication may still have auth_data
732 return ($resp && $data) ? 1 : 0;
737 sub get_pass_by_user
{ die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
738 sub cleanup_user
{ my ($self, $user) = @_; $user }
739 sub verify_user
{ 1 }
741 ###----------------------------------------------------------------###
742 ### a few standard base accessors
744 sub script_name
{ shift-
>{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
746 sub path_info
{ shift-
>{'path_info'} || $ENV{'PATH_INFO'} || '' }
750 $self->{'cgix'} = shift if @_ == 1;
751 return $self->{'cgix'} ||= do {
753 CGI
::Ex-
>new; # return of the do
759 $self->{'form'} = shift if @_ == 1;
760 return $self->{'form'} ||= $self->cgix->get_form;
765 $self->{'cookies'} = shift if @_ == 1;
766 return $self->{'cookies'} ||= $self->cgix->get_cookies;
771 $self->{'vob'} = shift if @_ == 1;
772 return $self->{'vob'} ||= do {
773 require CGI
::Ex
::Validate
;
774 my $args = $self->vob_args;
775 $args->{'cgix'} ||= $self->cgix;
776 CGI
::Ex
::Validate-
>new($self->vob_args); # return of the do
780 sub vob_args
{ shift-
>{'vob_args'} || {} }
784 return $self->{'vob_path'} || $self->template_path;
787 ### provide a place for placing variables
790 return $self->{'stash'} ||= {};
796 delete @{ $self }{qw(
805 _morph_lineage_start_index
816 ###----------------------------------------------------------------###
817 ### default hook implementations
819 sub path_info_map
{ }
825 ### if the pre_step exists and returns true, exit the nav_loop
826 return 1 if $self->run_hook('pre_step', $step);
828 ### allow for skipping this step (but stay in the nav_loop)
829 return 0 if $self->run_hook('skip', $step);
831 ### see if we have complete valid information for this step
832 ### if so, do the next step
833 ### if not, get necessary info and print it out
834 if ( ! $self->run_hook('prepare', $step)
835 || ! $self->run_hook('info_complete', $step)
836 || ! $self->run_hook('finalize', $step)) {
838 ### show the page requesting the information
839 $self->run_hook('prepared_print', $step);
841 ### a hook after the printing process
842 $self->run_hook('post_print', $step);
847 ### a hook before end of loop
848 ### if the post_step exists and returns true, exit the nav_loop
849 return 1 if $self->run_hook('post_step', $step);
851 ### let the nav_loop continue searching the path
856 my ($self, $step, $is_at_end) = @_;
857 return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
859 my $next_step = $self->run_hook('next_step', $step) || return 0;
860 $self->run_hook('set_ready_validate', $step, 0);
861 $self->append_path($next_step);
869 my $hash_base = $self->run_hook('hash_base', $step) || {};
870 my $hash_comm = $self->run_hook('hash_common', $step) || {};
871 my $hash_form = $self->run_hook('hash_form', $step) || {};
872 my $hash_fill = $self->run_hook('hash_fill', $step) || {};
873 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
874 my $hash_errs = $self->run_hook('hash_errors', $step) || {};
877 $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
878 foreach keys %$hash_errs;
879 $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
881 ### layer hashes together
882 my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
883 my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
885 ### run the print hook - passing it the form and fill info
886 $self->run_hook('print', $step, $swap, $fill);
890 my ($self, $step, $swap, $fill) = @_;
891 my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
892 my $out = $self->run_hook('swap_template', $step, $file, $swap);
893 $self->run_hook('fill_template', $step, \
$out, $fill);
894 $self->run_hook('print_out', $step, \
$out);
898 my ($self, $step, $out) = @_;
900 $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
901 print ref($out) eq 'SCALAR' ? $$out : $out;
904 sub mimetype
{ shift-
>{'mimetype'} || 'text/html' }
905 sub charset
{ shift-
>{'charset'} || '' }
908 my ($self, $step, $file, $swap) = @_;
910 my $args = $self->run_hook('template_args', $step);
911 $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
913 my $t = $self->template_obj($args);
915 $t->process($file, $swap, \
$out) || die $t->error;
922 return $self->{'template_path'} || $self->base_dir_abs;
925 sub template_args
{ shift-
>{'template_args'} || {} }
928 my ($self, $args) = @_;
930 require CGI
::Ex
::Template
;
931 my $t = CGI
::Ex
::Template-
>new($args);
935 my ($self, $step, $outref, $fill) = @_;
939 my $args = $self->run_hook('fill_args', $step);
940 local $args->{'text'} = $outref;
941 local $args->{'form'} = $fill;
943 require CGI
::Ex
::Fill
;
944 CGI
::Ex
::Fill
::fill
($args);
947 sub fill_args
{ shift-
>{'fill_args'} || {} }
949 sub pre_step
{ 0 } # success indicates we handled step (don't continue step or loop)
950 sub skip
{ 0 } # success indicates to skip the step (and continue loop)
951 sub prepare
{ 1 } # failure means show step
952 sub finalize
{ 1 } # failure means show step
954 sub post_step
{ 0 } # success indicates we handled step (don't continue step or loop)
958 my $step = shift || '';
959 my $cur = ref $self; # default to using self as the base for morphed modules
960 my $new = $cur .'::'. $step;
961 $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
967 my $step = shift || '';
969 return $self->{'name_module'} ||= do {
970 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
971 my $script = $self->script_name;
972 $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
973 $1; # return of the do
978 my ($self, $step) = @_;
986 my $base_dir = $self->base_dir_rel;
987 my $module = $self->run_hook('name_module', $step);
988 my $_step = $self->run_hook('name_step', $step) || die "Missing name_step";
989 $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
991 foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
993 return $base_dir . $module . $_step;
1000 ### determine the path to begin looking for files - allow for an arrayref
1001 my $abs = $self->vob_path || [];
1002 $abs = $abs->() if UNIVERSAL
::isa
($abs, 'CODE');
1003 $abs = [$abs] if ! UNIVERSAL
::isa
($abs, 'ARRAY');
1004 return {} if @$abs == 0;
1006 my $base_dir = $self->base_dir_rel;
1007 my $module = $self->run_hook('name_module', $step);
1008 my $_step = $self->run_hook('name_step', $step) || die "Missing name_step";
1009 $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
1011 foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
1014 foreach my $_abs (@$abs) {
1015 my $path = $_abs . $base_dir . $module . $_step;
1016 return $path if -e
$path;
1020 return $abs->[0] . $base_dir . $module . $_step;
1024 my ($self, $step) = @_;
1025 return 0 if ! $self->run_hook('ready_validate', $step);
1026 return 0 if ! $self->run_hook('validate', $step, $self->form);
1030 sub ready_validate
{
1031 my ($self, $step) = @_;
1032 return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
1035 sub set_ready_validate
{ # hook and method
1037 my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
1038 $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
1043 my ($self, $step, $form) = @_;
1045 my $hash = $self->run_hook('hash_validation', $step);
1046 my $what_was_validated = [];
1048 my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) };
1049 die "Step $step: $@" if $@ && ! $err_obj;
1051 ### had an error - store the errors and return false
1053 $self->add_errors($err_obj->as_hash({
1054 as_hash_join
=> "<br>\n",
1055 as_hash_suffix
=> '_error',
1060 ### allow for the validation to give us some redirection
1061 foreach my $ref (@$what_was_validated) {
1062 foreach my $method (qw(append_path replace_path insert_path)) {
1063 next if ! (my $val = $ref->{$method});
1064 $self->$method(ref $val ? @$val : $val);
1071 ### creates javascript suitable for validating the form
1075 return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
1077 my $form_name = shift || $self->run_hook('form_name', $step);
1078 my $hash_val = shift || $self->run_hook('hash_validation', $step);
1079 my $js_uri = $self->js_uri_path;
1080 return '' if UNIVERSAL
::isa
($hash_val, 'HASH') && ! scalar keys %$hash_val
1081 || UNIVERSAL
::isa
($hash_val, 'ARRAY') && ! @$hash_val;
1083 return $self->vob->generate_js($hash_val, $form_name, $js_uri);
1086 sub form_name
{ 'theform' }
1088 sub hash_validation
{
1089 my ($self, $step) = @_;
1091 return $self->{'hash_validation'}->{$step} ||= do {
1093 my $file = $self->run_hook('file_val', $step);
1095 ### allow for returning the validation hash in the filename
1096 ### a scalar ref means it is a yaml document to be read by get_validation
1097 if (ref($file) && ! UNIVERSAL
::isa
($file, 'SCALAR')) {
1100 ### read the file - if it is not found, errors will be in the webserver logs (all else dies)
1102 $hash = $self->vob->get_validation($file) || {};
1108 $hash; # return of the do
1113 my ($self, $step) = @_;
1115 return $self->{'hash_base'} ||= do {
1116 ### create a weak copy of self to use in closures
1118 eval {require Scalar
::Util
; Scalar
::Util
::weaken
($copy)};
1120 script_name
=> $self->script_name,
1121 path_info
=> $self->path_info,
1122 js_validation
=> sub { $copy->run_hook('js_validation', $step, shift) },
1123 form_name
=> $self->run_hook('form_name', $step),
1124 $self->step_key => $step,
1125 }; # return of the do
1129 sub hash_common
{ shift-
>{'hash_common'} ||= {} }
1130 sub hash_form
{ shift-
>form }
1131 sub hash_fill
{ shift-
>{'hash_fill'} ||= {} }
1132 sub hash_swap
{ shift-
>{'hash_swap'} ||= {} }
1133 sub hash_errors
{ shift-
>{'hash_errors'} ||= {} }
1135 ###----------------------------------------------------------------###
1136 ### routines to support the base hooks
1140 my $hash = $self->hash_errors;
1141 my $args = ref($_[0]) ? shift : {@_};
1142 foreach my $key (keys %$args) {
1143 my $_key = ($key =~ /error$/) ? $key : "${key}_error";
1144 if ($hash->{$_key}) {
1145 $hash->{$_key} .= '<br>' . $args->{$key};
1147 $hash->{$_key} = $args->{$key};
1150 $hash->{'has_errors'} = 1;
1153 sub has_errors
{ scalar keys %{ shift-
>hash_errors } }
1156 my ($self, $error) = @_;
1160 sub add_to_errors
{ shift-
>add_errors(@_) }
1161 sub add_to_swap
{ my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
1162 sub add_to_fill
{ my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
1163 sub add_to_form
{ my $self = shift; $self->add_to_hash($self->hash_form, @_) }
1164 sub add_to_common
{ my $self = shift; $self->add_to_hash($self->hash_common, @_) }
1165 sub add_to_base
{ my $self = shift; $self->add_to_hash($self->hash_base, @_) }
1171 $new = {$new, @_} if ! ref $new; # non-hashref
1172 $old->{$_} = $new->{$_} foreach keys %$new;
1178 $self->{'base_dir_rel'} = shift if @_ == 1;
1179 return $self->{'base_dir_rel'} || '';
1184 $self->{'base_dir_abs'} = shift if @_ == 1;
1185 return $self->{'base_dir_abs'} || ['.']; # default to the current directory
1190 $self->{'ext_print'} = shift if @_ == 1;
1191 return $self->{'ext_print'} || 'html';
1196 $self->{'ext_val'} = shift if @_ == 1;
1197 return $self->{'ext_val'} || 'val';
1200 ### where to find the javascript files
1201 ### default to using this script as a handler
1204 my $script = $self->script_name;
1205 my $js_step = $self->js_step;
1206 return ($self->can('path') == \
&CGI
::Ex
::App
::path
)
1207 ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
1208 : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
1211 ###----------------------------------------------------------------###
1212 ### a simple step that allows for printing javascript libraries that
1213 ### are stored in perls @INC. Which ever step is in js_step should do something similar.
1218 ### make sure path info looks like /js/CGI/Ex/foo.js
1219 my $file = $self->form->{'js'} || $self->path_info;
1220 $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
1222 $self->cgix->print_js($file);
1223 $self->{'_no_post_navigate'} = 1;
1227 ###----------------------------------------------------------------###
1228 ### a step that will be used if a valid_steps is defined
1229 ### and the current step of the path is not in valid_steps
1230 ### or if the step is a "hidden" step that begins with _
1231 ### or if the step name contains \W
1233 sub __forbidden_info_complete
{ 0 }
1235 sub __forbidden_hash_swap
{ shift-
>stash }
1237 sub __forbidden_file_print
{ \
"<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
1239 ###----------------------------------------------------------------###
1240 ### a step that is used by the default handle_error
1242 sub __error_info_complete
{ 0 }
1244 sub __error_hash_swap
{ shift-
>stash }
1246 sub __error_file_print
{ \
"<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
1248 ###----------------------------------------------------------------###
1252 ### See the perldoc in CGI/Ex/App.pod