3 ###----------------------------------------------------------------###
4 # See the perldoc in CGI/Ex/App.pod
5 # Copyright 2006 - 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
};
20 $msg = 'Something happened' if ! defined $msg;
21 die $msg if ref $msg || $msg =~ /\n\z/;
22 my ($pkg, $file, $line, $sub) = caller(1);
23 die "$msg in ${sub}() at $file line $line\n";
26 ###----------------------------------------------------------------###
29 my $class = shift || croak
"Usage: Package->new";
30 my $self = shift || {};
40 ###----------------------------------------------------------------###
43 my ($self, $args) = @_;
44 $self = $self->new($args) if ! ref $self;
46 $self->{'_time'} = time;
49 ### allow for authentication
50 my $ref = $self->require_auth;
51 if ($ref && ! ref $ref) {
52 return $self if ! $self->get_valid_auth;
55 ### a chance to do things at the very beginning
56 return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
60 local $self->{'__morph_lineage_start_index'} = $#{$self->{'__morph_lineage'} || []};
64 ### rethrow the error unless we long jumped out of recursive nav_loop calls
65 croak
$@ if $@ ne "Long Jump\n";
68 ### one chance to do things at the very end
69 $self->post_navigate if ! $self->{'_no_post_navigate'};
73 $self->handle_error($@) if $@; # catch any errors
75 $self->{'_time'} = time;
83 ### keep from an infinate nesting
84 local $self->{'recurse'} = $self->{'recurse'} || 0;
85 if ($self->{'recurse'} ++ >= $self->recurse_limit) {
86 my $err = "recurse_limit (".$self->recurse_limit.") reached";
87 $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
91 my $path = $self->path;
93 ### allow for an early return
94 return if $self->pre_loop($path); # a true value means to abort the navigate
96 my $req_auth = ref($self->require_auth) ? $self->require_auth : undef;
98 ### iterate on each step of the path
99 foreach ($self->{'path_i'} ||= 0;
100 $self->{'path_i'} <= $#$path;
101 $self->{'path_i'} ++) {
102 my $step = $path->[$self->{'path_i'}];
103 if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
104 $self->stash->{'forbidden_step'} = $step;
105 $self->replace_path($self->forbidden_step);
108 $step = $1; # untaint
110 ### allow for per-step authentication
112 && $req_auth->{$step}
113 && ! $self->get_valid_auth) {
117 ### allow for becoming another package (allows for some steps in external files)
120 ### run the guts of the step
121 my $status = $self->run_hook('run_step', $step);
123 $self->unmorph($step);
125 ### Allow for the run_step to intercept.
126 ### A true status means the run_step took over navigation.
130 ### allow for one exit point after the loop
131 return if $self->post_loop($path); # a true value means to abort the navigate
133 ### run the default step as a last resort
134 $self->insert_path($self->default_step);
135 $self->nav_loop; # go recursive
140 sub pre_navigate
{ 0 } # true means to not enter nav_loop
144 sub pre_loop
{ 0 } # true value means to abort the nav_loop routine
146 sub post_loop
{ 0 } # true value means to abort the nav_loop - don't recurse
148 sub recurse_limit
{ shift-
>{'recurse_limit'} || 15 }
150 ### default die handler - show what happened and die (so its in the error logs)
158 ###----------------------------------------------------------------###
160 sub default_step
{ shift-
>{'default_step'} || 'main' }
162 sub js_step
{ shift-
>{'js_step'} || 'js' }
164 sub forbidden_step
{ shift-
>{'forbidden_step'} || '__forbidden' }
166 sub step_key
{ shift-
>{'step_key'} || 'step' }
170 if (! $self->{'path'}) {
171 my $path = $self->{'path'} = []; # empty path
173 my $step = $self->form->{ $self->step_key };
174 $step = lc($1) if ! $step && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m
|^/(\w
+)|;
176 ### make sure the step is valid
178 if ($step =~ /^_/) { # can't begin with _
179 $self->stash->{'forbidden_step'} = $step;
180 push @$path, $self->forbidden_step;
181 } elsif ($self->valid_steps # must be in valid_steps if defined
182 && ! $self->valid_steps->{$step}
183 && $step ne $self->default_step
184 && $step ne $self->js_step) {
185 $self->stash->{'forbidden_step'} = $step;
186 push @$path, $self->forbidden_step;
193 return $self->{'path'};
198 my $path = $self->{'path'} ||= [];
199 croak
"Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
200 splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
203 ### legacy - same as append_path
206 push @{ $self->path }, @_;
211 push @{ $self->path }, @_;
216 my $ref = $self->path;
217 my $i = $self->{'path_i'} || 0;
218 if ($i + 1 > $#$ref) {
221 splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
227 my $ref = $self->path;
228 my $i = $self->{'path_i'} || 0;
229 if ($i + 1 > $#$ref) {
232 splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
236 ### a hash of paths that are allowed, default undef is all are allowed
239 ###----------------------------------------------------------------###
240 ### allow for checking where we are in the path and for jumping around
246 if (my $ref = $self->{'__morph_lineage'}) {
247 ### use the saved index - this allows for early "morphers" to only get rolled back so far
248 my $index = $self->{'__morph_lineage_start_index'};
249 $index = -1 if ! defined $index;
250 $self->unmorph while $#$ref != $index;
259 my $i = @_ == 1 ? shift : 1;
260 my $path = $self->path;
261 my $path_i = $self->{'path_i'};
262 croak
"Can't jump if nav_loop not started" if ! defined $path_i;
264 ### validate where we are jumping to
268 } elsif ($i eq 'LAST') {
269 $i = $#$path - $path_i;
270 } elsif ($i eq 'NEXT') {
272 } elsif ($i eq 'CURRENT') {
274 } elsif ($i eq 'PREVIOUS') {
276 } else { # look for a step by that name
277 for (my $j = $#$path; $j >= 0; $j --) {
278 if ($path->[$j] eq $i) {
285 if ($i !~ /^-?\d+$/) {
287 Carp
::croak
("Invalid jump index ($i)");
290 ### manipulate the path to contain the new jump location
292 my $cut_i = $path_i + $i;
293 if ($cut_i > $#$path) {
294 push @replace, $self->default_step;
295 } elsif ($cut_i < 0) {
296 push @replace, @$path;
298 push @replace, @$path[$cut_i .. $#$path];
300 $self->replace_path(@replace);
302 ### record the number of jumps
303 $self->{'jumps'} ||= 0;
306 ### run the newly fixed up path (recursively)
307 $self->{'path_i'} ++; # move along now that the path is updated
309 $self->exit_nav_loop;
312 sub step_by_path_index
{
315 my $ref = $self->path;
317 return $self->default_step if $i > $#$ref;
323 croak
"previous_step is readonly" if $#_ != -1;
324 return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
329 croak
"current_step is readonly" if $#_ != -1;
330 return $self->step_by_path_index( ($self->{'path_i'} || 0) );
335 croak
"next_step is readonly" if $#_ != -1;
336 return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
341 croak
"last_step is readonly" if $#_ != -1;
342 return $self->step_by_path_index( $#{ $self->path } );
347 croak
"first_step is readonly" if $#_ != -1;
348 return $self->step_by_path_index( 0 );
351 ###----------------------------------------------------------------###
352 ### hooks and history
356 my $hook = shift || do { require Carp
; Carp
::confess
("Missing hook name") };
357 my $step = shift || '';
359 if ($step && ($code = $self->can("${step}_${hook}"))) {
360 return [$code, "${step}_${hook}"],
362 } elsif ($code = $self->can($hook)) {
363 return [$code, $hook];
376 my ($code, $found) = @{ $self->find_hook($hook, $step) };
378 croak
"Could not find a method named ${step}_${hook} or ${hook}";
390 push @{ $self->history }, $hist;
392 $hist->{'level'} = $self->{'_level'};
393 local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
395 $hist->{'elapsed'} = time - $hist->{'time'};
397 my $resp = $self->$code($step, @_);
399 $hist->{'elapsed'} = time - $hist->{'time'};
400 $hist->{'response'} = $resp;
406 return shift-
>{'history'} ||= [];
411 my $all = shift || 0;
412 my $hist = $self->history;
414 push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
416 ### show terse - yet informative info
417 foreach my $row (@$hist) {
419 || ref($row) ne 'HASH'
420 || ! exists $row->{'elapsed'}) {
423 my $note = (' ' x
($row->{'level'} || 0))
424 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
425 my $resp = $row->{'response'};
426 if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
428 } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
430 } elsif (! ref $resp || ! $all) {
431 my $max = $self->{'history_max'} || 30;
432 if (length($resp) > $max) {
433 $resp = substr($resp, 0, $max);
439 $note = [$note, $resp];
449 ###----------------------------------------------------------------###
450 ### utility methods to allow for storing separate steps in other modules
454 return $self->{'allow_morph'} ? 1 : 0;
457 sub allow_nested_morph
{
459 return $self->{'allow_nested_morph'} ? 1 : 0;
464 my $step = shift || return;
465 return if ! (my $allow = $self->allow_morph($step));
467 ### place to store the lineage
468 my $lin = $self->{'__morph_lineage'} ||= [];
469 my $cur = ref $self; # what are we currently
470 push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
479 push @{ $self->history }, $hist;
481 if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
482 $hist->{'found'} .= " (not allowed to morph to that step)";
486 ### make sure we haven't already been reblessed
487 if ($#$lin != 0 # is this the second morph call
488 && (! ($allow = $self->allow_nested_morph($step)) # not true
489 || (ref($allow) && ! $allow->{$step}) # hash - but no step
491 $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
492 return; # just return - don't die so that we can morph early
495 ### if we are not already that package - bless us there
496 my $new = $self->run_hook('morph_package', $step);
498 my $file = $new .'.pm';
500 if (UNIVERSAL
::can
($new, 'can') # check if the package space exists
501 || eval { require $file }) { # check for a file that holds this package
502 ### become that package
504 $hist->{'found'} .= " (changed $cur to $new)";
505 $self->fixup_after_morph($step);
508 if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
509 $hist->{'found'} .= " (failed from $cur to $new: $1)";
511 $hist->{'found'} .= " (failed from $cur to $new: $@)";
512 my $err = "Trouble while morphing to $file: $@";
523 my $step = shift || '__no_step';
524 my $lin = $self->{'__morph_lineage'} || return;
527 my $prev = pop(@$lin) || croak
"unmorph called more times than morph - current ($cur)";
528 delete $self->{'__morph_lineage'} if ! @$lin;
530 ### if we are not already that package - bless us there
538 push @{ $self->history }, $hist;
541 $self->fixup_before_unmorph($step);
543 $hist->{'found'} .= " (changed from $cur to $prev)";
545 $hist->{'found'} .= " (already isa $cur)";
551 sub fixup_after_morph
{}
553 sub fixup_before_unmorph
{}
555 ###----------------------------------------------------------------###
556 ### allow for authentication
558 sub navigate_authenticated
{
559 my ($self, $args) = @_;
560 $self = $self->new($args) if ! ref $self;
562 $self->require_auth(1);
564 return $self->navigate;
569 $self->{'require_auth'} = shift if @_ == 1;
570 return $self->{'require_auth'};
573 sub is_authed
{ shift-
>auth_data }
577 $self->{'auth_data'} = shift if @_ == 1;
578 return $self->{'auth_data'};
583 return 1 if $self->is_authed;
585 ### augment the args with sensible defaults
586 my $args = $self->auth_args;
587 $args->{'cgix'} ||= $self->cgix;
588 $args->{'form'} ||= $self->form;
589 $args->{'cookies'} ||= $self->cookies;
590 $args->{'js_uri_path'} ||= $self->js_uri_path;
591 $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
592 $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
593 $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
594 $args->{'login_print'} ||= sub {
595 my ($auth, $template, $hash) = @_;
596 my $out = $self->run_hook('swap_template', '__login', $template, $hash);
597 $self->run_hook('fill_template', '__login', \
$out, $hash);
598 $self->run_hook('print_out', '__login', $out);
601 require CGI
::Ex
::Auth
;
602 my $obj = CGI
::Ex
::Auth-
>new($args);
603 my $resp = $obj->get_valid_auth;
605 my $data = $obj->last_auth_data;
606 delete $data->{'real_pass'} if defined $data; # data may be defined but false
607 $self->auth_data($data); # failed authentication may still have auth_data
609 return ($resp && $data) ? 1 : 0;
614 sub get_pass_by_user
{ die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
615 sub cleanup_user
{ my ($self, $user) = @_; $user }
616 sub verify_user
{ 1 }
618 ###----------------------------------------------------------------###
619 ### a few standard base accessors
623 $self->{'form'} = shift if @_ == 1;
624 return $self->{'form'} ||= $self->cgix->get_form;
629 $self->{'cookies'} = shift if @_ == 1;
630 return $self->{'cookies'} ||= $self->cgix->get_cookies;
635 $self->{'cgix'} = shift if @_ == 1;
636 return $self->{'cgix'} ||= do {
638 CGI
::Ex-
>new; # return of the do
644 $self->{'vob'} = shift if @_ == 1;
645 return $self->{'vob'} ||= do {
646 require CGI
::Ex
::Validate
;
647 CGI
::Ex
::Validate-
>new($self->vob_args); # return of the do
658 ### provide a place for placing variables
661 return $self->{'stash'} ||= {};
664 ###----------------------------------------------------------------###
665 ### default hook implementations
671 ### if the pre_step exists and returns true, exit the nav_loop
672 return 1 if $self->run_hook('pre_step', $step);
674 ### allow for skipping this step (but stay in the nav_loop)
675 return 0 if $self->run_hook('skip', $step);
677 ### see if we have complete valid information for this step
678 ### if so, do the next step
679 ### if not, get necessary info and print it out
680 if ( ! $self->run_hook('prepare', $step)
681 || ! $self->run_hook('info_complete', $step)
682 || ! $self->run_hook('finalize', $step)) {
684 ### show the page requesting the information
685 $self->run_hook('prepared_print', $step);
687 ### a hook after the printing process
688 $self->run_hook('post_print', $step);
693 ### a hook before end of loop
694 ### if the post_step exists and returns true, exit the nav_loop
695 return 1 if $self->run_hook('post_step', $step);
697 ### let the nav_loop continue searching the path
705 my $hash_base = $self->run_hook('hash_base', $step) || {};
706 my $hash_comm = $self->run_hook('hash_common', $step) || {};
707 my $hash_form = $self->run_hook('hash_form', $step) || {};
708 my $hash_fill = $self->run_hook('hash_fill', $step) || {};
709 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
710 my $hash_errs = $self->run_hook('hash_errors', $step) || {};
713 $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
714 foreach keys %$hash_errs;
715 $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
717 ### layer hashes together
718 my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
719 my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
721 ### run the print hook - passing it the form and fill info
722 $self->run_hook('print', $step, $swap, $fill);
726 my ($self, $step, $swap, $fill) = @_;
728 my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
730 my $out = $self->run_hook('swap_template', $step, $file, $swap);
732 $self->run_hook('fill_template', $step, \
$out, $fill);
734 $self->run_hook('print_out', $step, $out);
738 my ($self, $step, $out) = @_;
740 $self->cgix->print_content_type();
745 my ($self, $step, $file, $swap) = @_;
747 require CGI
::Ex
::Template
;
748 my $args = $self->run_hook('template_args', $step);
749 my $t = CGI
::Ex
::Template-
>new($args);
752 $t->process($file, $swap, \
$out) || die $t->error;
761 INCLUDE_PATH
=> sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" },
766 my ($self, $step, $outref, $fill) = @_;
770 my $args = $self->run_hook('fill_args', $step);
771 local $args->{'text'} = $outref;
772 local $args->{'form'} = $fill;
774 require CGI
::Ex
::Fill
;
775 CGI
::Ex
::Fill
::fill
($args);
780 sub pre_step
{ 0 } # success indicates we handled step (don't continue step or loop)
781 sub skip
{ 0 } # success indicates to skip the step (and continue loop)
782 sub prepare
{ 1 } # failure means show step
783 sub finalize
{ 1 } # failure means show step
784 sub post_print
{ 0 } # success indicates we handled step (don't continue loop)
785 sub post_step
{ 0 } # success indicates we handled step (don't continue step or loop)
788 my ($self, $step) = @_;
794 my $step = shift || '';
795 my $cur = ref $self; # default to using self as the base for morphed modules
796 my $new = $cur .'::'. $step;
797 $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
803 my $step = shift || '';
805 return $self->{'name_module'} ||= do {
806 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
807 my $script = $ENV{'SCRIPT_NAME'} || $0;
808 $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
809 $1; # return of the do
817 my $base_dir = $self->base_dir_rel;
818 my $module = $self->run_hook('name_module', $step);
819 my $_step = $self->run_hook('name_step', $step) || die "Missing name_step";
820 $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
822 foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
824 return $base_dir . $module . $_step;
831 my $abs = $self->base_dir_abs || return {};
832 my $base_dir = $self->base_dir_rel;
833 my $module = $self->run_hook('name_module', $step);
834 my $_step = $self->run_hook('name_step', $step);
835 $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
837 foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
839 return $abs . $base_dir . $module . $_step;
846 return 0 if ! $self->run_hook('ready_validate', $step);
847 return 0 if ! $self->run_hook('validate', $step);
855 return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
858 sub set_ready_validate
{
859 my ($self, $ready) = @_;
860 $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET';
866 my $form = shift || $self->form;
867 my $hash = $self->run_hook('hash_validation', $step);
868 my $what_was_validated = [];
870 my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) };
871 die "Step $step: $@" if $@ && ! $err_obj;
873 ### had an error - store the errors and return false
875 $self->add_errors($err_obj->as_hash({
876 as_hash_join
=> "<br>\n",
877 as_hash_suffix
=> '_error',
882 ### allow for the validation to give us some redirection
883 foreach my $ref (@$what_was_validated) {
884 foreach my $method (qw(append_path replace_path insert_path)) {
885 next if ! (my $val = $ref->{$method});
886 $self->$method(ref $val ? @$val : $val);
893 ### creates javascript suitable for validating the form
897 return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
899 my $form_name = shift || $self->run_hook('form_name', $step);
900 my $hash_val = shift || $self->run_hook('hash_validation', $step);
901 my $js_uri = $self->js_uri_path;
902 return '' if UNIVERSAL
::isa
($hash_val, 'HASH') && ! scalar keys %$hash_val
903 || UNIVERSAL
::isa
($hash_val, 'ARRAY') && ! @$hash_val;
905 return $self->vob->generate_js($hash_val, $form_name, $js_uri);
908 sub form_name
{ 'theform' }
910 sub hash_validation
{
911 my ($self, $step) = @_;
913 return $self->{'hash_validation'}->{$step} ||= do {
915 my $file = $self->run_hook('file_val', $step);
917 ### allow for returning the validation hash in the filename
918 ### a scalar ref means it is a yaml document to be read by get_validation
919 if (ref($file) && ! UNIVERSAL
::isa
($file, 'SCALAR')) {
922 ### read the file - if it fails - errors should be in the webserver error logs
924 $hash = eval { $self->vob->get_validation($file) } || {};
930 $hash; # return of the do
935 my ($self, $step) = @_;
937 return $self->{'hash_base'} ||= do {
938 ### create a weak copy of self to use in closures
940 if (eval {require Scalar
::Util
} && defined &Scalar
::Util
::weaken
) {
942 Scalar
::Util
::weaken
($copy);
944 $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8)
948 script_name
=> $ENV{'SCRIPT_NAME'} || $0,
949 path_info
=> $ENV{'PATH_INFO'} || '',
950 js_validation
=> sub { $copy->run_hook('js_validation', $step, shift) },
951 form_name
=> sub { $copy->run_hook('form_name', $step) },
952 $self->step_key => $step,
953 }; # return of the do
957 sub hash_common
{ shift-
>{'hash_common'} ||= {} }
958 sub hash_form
{ shift-
>form }
959 sub hash_fill
{ shift-
>{'hash_fill'} ||= {} }
960 sub hash_swap
{ shift-
>{'hash_swap'} ||= {} }
961 sub hash_errors
{ shift-
>{'hash_errors'} ||= {} }
963 ###----------------------------------------------------------------###
964 ### routines to support the base hooks
968 my $hash = $self->hash_errors;
969 my $args = ref($_[0]) ? shift : {@_};
970 foreach my $key (keys %$args) {
971 my $_key = ($key =~ /error$/) ? $key : "${key}_error";
972 if ($hash->{$_key}) {
973 $hash->{$_key} .= '<br>' . $args->{$key};
975 $hash->{$_key} = $args->{$key};
978 $hash->{'has_errors'} = 1;
981 sub has_errors
{ scalar keys %{ shift-
>hash_errors } }
984 my ($self, $error) = @_;
988 sub add_to_errors
{ shift-
>add_errors(@_) }
989 sub add_to_swap
{ my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
990 sub add_to_fill
{ my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
991 sub add_to_form
{ my $self = shift; $self->add_to_hash($self->hash_form, @_) }
992 sub add_to_common
{ my $self = shift; $self->add_to_hash($self->hash_common, @_) }
993 sub add_to_base
{ my $self = shift; $self->add_to_hash($self->hash_base, @_) }
999 $new = {$new, @_} if ! ref $new; # non-hashref
1000 $old->{$_} = $new->{$_} foreach keys %$new;
1006 $self->{'base_dir_rel'} = shift if $#_ != -1;
1007 return $self->{'base_dir_rel'} || '';
1012 $self->{'base_dir_abs'} = shift if $#_ != -1;
1013 return $self->{'base_dir_abs'} || '';
1018 $self->{'ext_val'} = shift if $#_ != -1;
1019 return $self->{'ext_val'} || 'val';
1024 $self->{'ext_print'} = shift if $#_ != -1;
1025 return $self->{'ext_print'} || 'html';
1028 ### where to find the javascript files
1029 ### default to using this script as a handler
1032 my $script = $ENV{'SCRIPT_NAME'} || return '';
1033 my $js_step = $self->js_step;
1034 return ($self->can('path') == \
&CGI
::Ex
::App
::path
)
1035 ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
1036 : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
1039 ###----------------------------------------------------------------###
1040 ### a simple step that allows for printing javascript libraries that
1041 ### are stored in perls @INC. Which ever step is in js_step should do something similar.
1046 ### make sure path info looks like /js/CGI/Ex/foo.js
1047 my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
1048 $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
1050 $self->cgix->print_js($file);
1051 $self->{'_no_post_navigate'} = 1;
1055 ###----------------------------------------------------------------###
1056 ### a step that will be used if a valid_steps is defined
1057 ### and the current step of the path is not in valid_steps
1058 ### or if the step is a "hidden" step that begins with _
1059 ### or if the step name contains \W
1061 sub __forbidden_info_complete
{ 0 }
1063 sub __forbidden_hash_swap
{ {forbidden_step
=> shift-
>stash->{'forbidden_step'}} }
1065 sub __forbidden_file_print
{ \
"<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
1067 ###----------------------------------------------------------------###
1071 ### See the perldoc in CGI/Ex/App.pod