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 ###----------------------------------------------------------------###
12 eval { use Time
::HiRes
qw(time) };
13 eval { use Scalar
::Util
};
16 our $VERSION = '2.18';
19 my $class = shift || croak
"Usage: ".__PACKAGE__
."->new";
20 my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
24 $self->init_from_conf;
31 return if ! $self->load_conf;
32 my $conf = $self->conf;
33 @{ $self }{ keys %$conf } = values %$conf;
37 ###---------------------###
40 my ($self, $args) = @_;
41 $self = $self->new($args) if ! ref $self;
43 $self->{'_time'} = time;
45 return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
48 local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
51 croak
$@ if $@ && $@ ne "Long Jump\n";
53 $self->post_navigate if ! $self->{'_no_post_navigate'};
55 $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors
65 ### keep from an infinate nesting
66 local $self->{'_recurse'} = $self->{'_recurse'} || 0;
67 if ($self->{'_recurse'}++ >= $self->recurse_limit) {
68 my $err = "recurse_limit (".$self->recurse_limit.") reached";
69 $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
73 my $path = $self->path;
75 ### allow for an early return
76 return if $self->pre_loop($path); # a true value means to abort the navigate
78 ### iterate on each step of the path
79 foreach ($self->{'path_i'} ||= 0;
80 $self->{'path_i'} <= $#$path;
81 $self->{'path_i'} ++) {
82 my $step = $path->[$self->{'path_i'}];
83 if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
84 $self->stash->{'forbidden_step'} = $step;
85 $self->replace_path($self->forbidden_step);
90 ### allow for per-step authentication
91 if (! $self->is_authed) {
92 my $req = $self->run_hook('require_auth', $step, 1);
93 if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
94 return if ! $self->run_hook('get_valid_auth', $step);
98 ### allow for becoming another package (allows for some steps in external files)
101 ### allow for mapping path_info pieces to form elements
102 if (my $info = $self->path_info) {
103 my $maps = $self->run_hook('path_info_map', $step) || [];
104 croak
'Usage: sub path_info_map { [] }' if ! UNIVERSAL
::isa
($maps, 'ARRAY');
105 foreach my $map (@$maps) {
106 croak
'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL
::isa
($map, 'ARRAY');
107 my @match = $info =~ $map->[0];
109 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
114 ### run the guts of the step
115 my $handled = $self->run_hook('run_step', $step);
117 ### Allow for the run_step to intercept.
118 ### A true status means the run_step took over navigation.
120 $self->unmorph($step);
124 ### if there are no future steps - allow for this step to designate one to follow
125 my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
126 $self->run_hook('refine_path', $step, $is_at_end);
128 $self->unmorph($step);
131 ### allow for one exit point after the loop
132 return if $self->post_loop($path); # a true value means to abort the navigate
134 ### run the default step as a last resort
135 $self->insert_path($self->default_step);
136 $self->nav_loop; # go recursive
143 if (! $self->{'path'}) {
144 my $path = $self->{'path'} = []; # empty path
146 ### add initial items to the form hash from path_info5B
147 if (my $info = $self->path_info) {
148 my $maps = $self->path_info_map_base || [];
149 croak
'Usage: sub path_info_map_base { [] }' if ! UNIVERSAL
::isa
($maps, 'ARRAY');
150 foreach my $map (@$maps) {
151 croak
'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL
::isa
($map, 'ARRAY');
152 my @match = $info =~ $map->[0];
154 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
159 ### make sure the step is valid
160 my $step = $self->form->{$self->step_key};
162 if ($step =~ /^_/) { # can't begin with _
163 $self->stash->{'forbidden_step'} = $step;
164 push @$path, $self->forbidden_step;
165 } elsif ($self->valid_steps # must be in valid_steps if defined
166 && ! $self->valid_steps->{$step}
167 && $step ne $self->default_step
168 && $step ne $self->js_step) {
169 $self->stash->{'forbidden_step'} = $step;
170 push @$path, $self->forbidden_step;
177 return $self->{'path'};
184 my ($code, $found) = @{ $self->find_hook($hook, $step) };
185 croak
"Could not find a method named ${step}_${hook} or ${hook}" if ! $code;
186 croak
"Value for $hook ($found) is not a code ref ($code)" if ! UNIVERSAL
::isa
($code, 'CODE');
189 if (! $self->{'no_history'}) {
196 push @{ $self->history }, $hist;
197 $hist->{'level'} = $self->{'_level'};
198 $hist->{'elapsed'} = time - $hist->{'time'};
200 local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
202 my $resp = $self->$code($step, @_);
204 if (! $self->{'no_history'}) {
205 $hist->{'elapsed'} = time - $hist->{'time'};
206 $hist->{'response'} = $resp;
216 ### if the pre_step exists and returns true, exit the nav_loop
217 return 1 if $self->run_hook('pre_step', $step);
219 ### allow for skipping this step (but stay in the nav_loop)
220 return 0 if $self->run_hook('skip', $step);
222 ### see if we have complete valid information for this step
223 ### if so, do the next step
224 ### if not, get necessary info and print it out
225 if ( ! $self->run_hook('prepare', $step)
226 || ! $self->run_hook('info_complete', $step)
227 || ! $self->run_hook('finalize', $step)) {
229 ### show the page requesting the information
230 $self->run_hook('prepared_print', $step);
232 ### a hook after the printing process
233 $self->run_hook('post_print', $step);
238 ### a hook before end of loop
239 ### if the post_step exists and returns true, exit the nav_loop
240 return 1 if $self->run_hook('post_step', $step);
242 ### let the nav_loop continue searching the path
250 my $hash_base = $self->run_hook('hash_base', $step) || {};
251 my $hash_comm = $self->run_hook('hash_common', $step) || {};
252 my $hash_form = $self->run_hook('hash_form', $step) || {};
253 my $hash_fill = $self->run_hook('hash_fill', $step) || {};
254 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
255 my $hash_errs = $self->run_hook('hash_errors', $step) || {};
257 $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
258 $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
260 my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
261 my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
263 $self->run_hook('print', $step, $swap, $fill);
267 my ($self, $step, $swap, $fill) = @_;
268 my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
269 my $out = $self->run_hook('swap_template', $step, $file, $swap);
270 $self->run_hook('fill_template', $step, \
$out, $fill);
271 $self->run_hook('print_out', $step, \
$out);
275 my ($self, $err) = @_;
277 die $err if $self->{'_handling_error'};
278 local $self->{'_handling_error'} = 1;
279 local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error
281 $self->stash->{'error_step'} = $self->current_step;
282 $self->stash->{'error'} = $err;
283 $self->replace_path($self->error_step);
285 eval { $self->jump };
286 die $@ if $@ && $@ ne "Long Jump\n";
289 ###---------------------###
290 # read only accessors
292 sub allow_morph
{ $_[0]->{'allow_morph'} }
293 sub allow_nested_morph
{ $_[0]->{'allow_nested_morph'} }
294 sub auth_args
{ $_[0]->{'auth_args'} }
295 sub charset
{ $_[0]->{'charset'} || '' }
296 sub conf_args
{ $_[0]->{'conf_args'} }
297 sub conf_die_on_fail
{ $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} }
298 sub conf_path
{ $_[0]->{'conf_path'} || $_[0]->base_dir_abs }
299 sub conf_validation
{ $_[0]->{'conf_validation'} }
300 sub default_step
{ $_[0]->{'default_step'} || 'main' }
301 sub error_step
{ $_[0]->{'error_step'} || '__error' }
302 sub fill_args
{ $_[0]->{'fill_args'} }
303 sub forbidden_step
{ $_[0]->{'forbidden_step'} || '__forbidden' }
304 sub form_name
{ $_[0]->{'form_name'} || 'theform' }
305 sub history
{ $_[0]->{'history'} ||= [] }
306 sub js_step
{ $_[0]->{'js_step'} || 'js' }
307 sub login_step
{ $_[0]->{'login_step'} || '__login' }
308 sub mimetype
{ $_[0]->{'mimetype'} || 'text/html' }
309 sub path_info
{ $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' }
310 sub path_info_map_base
{ $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] }
311 sub recurse_limit
{ $_[0]->{'recurse_limit'} || 15 }
312 sub script_name
{ $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
313 sub stash
{ $_[0]->{'stash'} ||= {} }
314 sub step_key
{ $_[0]->{'step_key'} || 'step' }
315 sub template_args
{ $_[0]->{'template_args'} }
316 sub template_path
{ $_[0]->{'template_path'} || $_[0]->base_dir_abs }
317 sub val_args
{ $_[0]->{'val_args'} }
318 sub val_path
{ $_[0]->{'val_path'} || $_[0]->template_path }
322 return $self->{'conf_obj'} || do {
323 my $args = $self->conf_args || {};
324 $args->{'paths'} ||= $self->conf_path;
325 $args->{'directive'} ||= 'MERGE';
326 require CGI
::Ex
::Conf
;
327 CGI
::Ex
::Conf-
>new($args);
332 my ($self, $args) = @_;
333 return $self->{'template_obj'} || do {
334 require Template
::Alloy
;
335 my $t = Template
::Alloy-
>new($args);
341 return $self->{'val_obj'} || do {
342 my $args = $self->val_args || {};
343 $args->{'cgix'} ||= $self->cgix;
344 require CGI
::Ex
::Validate
;
345 CGI
::Ex
::Validate-
>new($args);
349 ###---------------------###
350 # read/write accessors
352 sub auth_data
{ (@_ == 2) ? $_[0]->{'auth_data'} = pop : $_[0]->{'auth_data'} }
353 sub base_dir_abs
{ (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.'] }
354 sub base_dir_rel
{ (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || '' }
355 sub cgix
{ (@_ == 2) ? $_[0]->{'cgix'} = pop : $_[0]->{'cgix'} ||= do { require CGI
::Ex
; CGI
::Ex-
>new } }
356 sub cookies
{ (@_ == 2) ? $_[0]->{'cookies'} = pop : $_[0]->{'cookies'} ||= $_[0]->cgix->get_cookies }
357 sub ext_conf
{ (@_ == 2) ? $_[0]->{'ext_conf'} = pop : $_[0]->{'ext_conf'} || 'pl' }
358 sub ext_print
{ (@_ == 2) ? $_[0]->{'ext_print'} = pop : $_[0]->{'ext_print'} || 'html' }
359 sub ext_val
{ (@_ == 2) ? $_[0]->{'ext_val'} = pop : $_[0]->{'ext_val'} || 'val' }
360 sub form
{ (@_ == 2) ? $_[0]->{'form'} = pop : $_[0]->{'form'} ||= $_[0]->cgix->get_form }
361 sub load_conf
{ (@_ == 2) ? $_[0]->{'load_conf'} = pop : $_[0]->{'load_conf'} }
365 $self->{'conf'} = pop if @_ == 1;
366 return $self->{'conf'} ||= do {
367 my $conf = $self->conf_file;
368 $conf = ($self->conf_obj->read($conf, {no_warn_on_fail
=> 1}) || $self->conf_die_on_fail ? croak
$@ : {}) if ! $conf;
369 my $hash = $self->conf_validation;
370 if ($hash && scalar keys %$hash) {
371 my $err_obj = $self->val_obj->validate($conf, $hash);
372 die $err_obj if $err_obj;
380 $self->{'conf_file'} = pop if @_ == 1;
381 return $self->{'conf_file'} ||= do {
382 my $module = $self->name_module || croak
'Missing name_module during conf_file call';
383 $module .'.'. $self->ext_conf;
387 ###---------------------###
390 sub add_to_base
{ my $self = shift; $self->add_to_hash($self->hash_base, @_) }
391 sub add_to_common
{ my $self = shift; $self->add_to_hash($self->hash_common, @_) }
392 sub add_to_errors
{ shift-
>add_errors(@_) }
393 sub add_to_fill
{ my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
394 sub add_to_form
{ my $self = shift; $self->add_to_hash($self->hash_form, @_) }
395 sub add_to_path
{ shift-
>append_path(@_) } # legacy
396 sub add_to_swap
{ my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
397 sub cleanup_user
{ my ($self, $user) = @_; $user }
398 sub current_step
{ $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
400 sub first_step
{ $_[0]->step_by_path_index(0) }
401 sub fixup_after_morph
{}
402 sub fixup_before_unmorph
{}
403 sub format_error
{ my ($self, $error) = @_; $error }
404 sub get_pass_by_user
{ croak
"get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
405 sub has_errors
{ scalar keys %{ $_[0]->hash_errors } }
407 sub last_step
{ $_[0]->step_by_path_index($#{ $_[0]->path }) }
409 sub post_loop
{ 0 } # true value means to abort the nav_loop - don't recurse
411 sub pre_loop
{ 0 } # true value means to abort the nav_loop routine
412 sub pre_navigate
{ 0 } # true means to not enter nav_loop
413 sub previous_step
{ $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) }
415 sub verify_user
{ 1 }
419 my $hash = $self->hash_errors;
420 my $args = ref($_[0]) ? shift : {@_};
421 foreach my $key (keys %$args) {
422 my $_key = ($key =~ /error$/) ? $key : "${key}_error";
423 if ($hash->{$_key}) {
424 $hash->{$_key} .= '<br>' . $args->{$key};
426 $hash->{$_key} = $args->{$key};
429 $hash->{'has_errors'} = 1;
436 $new = {$new, @_} if ! ref $new; # non-hashref
437 $old->{$_} = $new->{$_} foreach keys %$new;
440 sub append_path
{ my $self = shift; push @{ $self->path }, @_ }
444 delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
445 _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
450 my ($self, $all) = @_;
452 my $hist = $self->history;
453 my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
455 foreach my $row (@$hist) {
456 if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) {
460 my $note = (' ' x
($row->{'level'} || 0))
461 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
462 my $resp = $row->{'response'};
463 if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
465 } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
467 } elsif (! defined $resp) {
469 } elsif (! ref $resp || ! $all) {
470 my $max = $self->{'history_max'} || 30;
471 if (length($resp) > $max) {
472 $resp = substr($resp, 0, $max);
478 $note = [$note, $resp];
490 if (my $ref = $self->{'_morph_lineage'}) {
491 ### use the saved index - this allows for early "morphers" to only get rolled back so far
492 my $index = $self->{'_morph_lineage_start_index'};
493 $index = -1 if ! defined $index;
494 $self->unmorph while $#$ref != $index;
501 my ($self, $hook, $step) = @_;
502 croak
"Missing hook name" if ! $hook;
503 if ($step && (my $code = $self->can("${step}_${hook}"))) {
504 return [$code, "${step}_${hook}"],
505 } elsif ($code = $self->can($hook)) {
506 return [$code, $hook];
514 my $ref = $self->path;
515 my $i = $self->{'path_i'} || 0;
516 if ($i + 1 > $#$ref) {
519 splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
525 my $i = @_ == 1 ? shift : 1;
526 my $path = $self->path;
527 my $path_i = $self->{'path_i'};
528 croak
"Can't jump if nav_loop not started" if ! defined $path_i;
531 if ( $i eq 'FIRST' ) { $i = - $path_i - 1 }
532 elsif ($i eq 'LAST' ) { $i = $#$path - $path_i }
533 elsif ($i eq 'NEXT' ) { $i = 1 }
534 elsif ($i eq 'CURRENT' ) { $i = 0 }
535 elsif ($i eq 'PREVIOUS') { $i = -1 }
536 else { # look for a step by that name
537 for (my $j = $#$path; $j >= 0; $j --) {
538 if ($path->[$j] eq $i) {
545 croak
"Invalid jump index ($i)" if $i !~ /^-?\d+$/;
547 ### manipulate the path to contain the new jump location
548 my $cut_i = $path_i + $i;
549 my @replace = ($cut_i > $#$path) ? $self->default_step
550 : ($cut_i < 0) ? @$path
551 : @$path[$cut_i .. $#$path];
552 $self->replace_path(@replace);
554 $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
556 $self->{'path_i'}++; # move along now that the path is updated
557 $self->nav_loop; # recurse on the path
558 $self->exit_nav_loop;
563 my $script = $self->script_name;
564 my $js_step = $self->js_step;
565 return ($self->can('path') == \
&CGI
::Ex
::App
::path
)
566 ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
567 : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
573 my $step = shift || return;
574 my $allow = $self->run_hook('allow_morph', $step) || return;
575 my $lin = $self->{'_morph_lineage'} ||= [];
576 my $cur = ref $self; # what are we currently
577 push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
579 my $hist = {step
=> $step, meth
=> 'morph', found
=> 'morph', time => time, elapsed
=> 0, response
=> 0};
580 push @{ $self->history }, $hist if ! $self->{'no_history'};
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") =~ s
|::|/|g
;
600 if (UNIVERSAL
::can
($new, 'can') # check if the package space exists
601 || eval { require $file }) { # check for a file that holds this package
602 bless $self, $new; # become that package
603 $hist->{'found'} .= " (changed $cur to $new)";
604 $self->fixup_after_morph($step);
606 if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
607 $hist->{'found'} .= " (failed from $cur to $new: $1)";
609 $hist->{'found'} .= " (failed from $cur to $new: $@)";
610 my $err = "Trouble while morphing to $file: $@";
616 $hist->{'response'} = 1;
622 my $ref = $self->path;
623 my $i = $self->{'path_i'} || 0;
624 if ($i + 1 > $#$ref) {
627 splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
633 my $path = $self->{'path'} ||= [];
634 croak
"Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
635 splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
638 sub step_by_path_index
{
641 my $ref = $self->path;
643 # return $self->default_step if $i > $#$ref;
649 my $step = shift || '_no_step';
650 my $lin = $self->{'_morph_lineage'} || return;
653 my $prev = pop(@$lin) || croak
"unmorph called more times than morph - current ($cur)";
654 delete $self->{'_morph_lineage'} if ! @$lin;
656 my $hist = {step
=> $step, meth
=> 'unmorph', found
=> 'unmorph', time => time, elapsed
=> 0, response
=> 0};
657 push @{ $self->history }, $hist if ! $self->{'no_history'};
660 $self->fixup_before_unmorph($step);
662 $hist->{'found'} .= " (changed from $cur to $prev)";
664 $hist->{'found'} .= " (already isa $cur)";
667 $hist->{'response'} = 1;
671 ###---------------------###
675 my ($self, $step) = @_;
677 my $base_dir = $self->base_dir_rel;
678 my $module = $self->run_hook('name_module', $step);
679 my $_step = $self->run_hook('name_step', $step) || croak
"Missing name_step";
680 $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
682 foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
684 return $base_dir . $module . $_step;
688 my ($self, $step) = @_;
690 ### determine the path to begin looking for files - allow for an arrayref
691 my $abs = $self->val_path || [];
692 $abs = $abs->() if UNIVERSAL
::isa
($abs, 'CODE');
693 $abs = [$abs] if ! UNIVERSAL
::isa
($abs, 'ARRAY');
694 return {} if @$abs == 0;
696 my $base_dir = $self->base_dir_rel;
697 my $module = $self->run_hook('name_module', $step);
698 my $_step = $self->run_hook('name_step', $step) || croak
"Missing name_step";
699 $_step =~ s/\.\w+$//;
700 $_step .= '.'. $self->ext_val;
702 foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
705 foreach my $_abs (@$abs) {
706 my $path = $_abs . $base_dir . $module . $_step;
707 return $path if -e
$path;
711 return $abs->[0] . $base_dir . $module . $_step;
715 my ($self, $step, $outref, $fill) = @_;
716 return if ! $fill || ! scalar keys %$fill;
718 my $args = $self->run_hook('fill_args', $step) || {};
719 local $args->{'text'} = $outref;
720 local $args->{'form'} = $fill;
722 require CGI
::Ex
::Fill
;
723 CGI
::Ex
::Fill
::fill
($args);
726 sub finalize
{ 1 } # failure means show step
729 my ($self, $step) = @_;
731 return $self->{'hash_base'} ||= do {
732 ### create a weak copy of self to use in closures
734 eval {require Scalar
::Util
; Scalar
::Util
::weaken
($copy)};
736 script_name
=> $self->script_name,
737 path_info
=> $self->path_info,
738 js_validation
=> sub { $copy->run_hook('js_validation', $step, shift) },
739 form_name
=> $self->run_hook('form_name', $step),
740 $self->step_key => $step,
741 }; # return of the do
745 sub hash_common
{ $_[0]->{'hash_common'} ||= {} }
746 sub hash_errors
{ $_[0]->{'hash_errors'} ||= {} }
747 sub hash_fill
{ $_[0]->{'hash_fill'} ||= {} }
748 sub hash_form
{ $_[0]->form }
749 sub hash_swap
{ $_[0]->{'hash_swap'} ||= {} }
751 sub hash_validation
{
752 my ($self, $step) = @_;
753 return $self->{'hash_validation'}->{$step} ||= do {
754 my $file = $self->run_hook('file_val', $step);
755 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)
756 $hash; # return of the do
761 my ($self, $step) = @_;
762 return 0 if ! $self->run_hook('ready_validate', $step);
763 return 0 if ! $self->run_hook('validate', $step, $self->form);
768 my ($self, $step) = @_;
769 return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
771 my $form_name = $_[2] || $self->run_hook('form_name', $step);
772 my $hash_val = $_[3] || $self->run_hook('hash_validation', $step);
773 my $js_uri = $self->js_uri_path;
774 return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
776 return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
780 my ($self, $step) = @_;
781 my $cur = ref $self; # default to using self as the base for morphed modules
782 my $new = $cur .'::'. ($step || croak
"Missing step");
783 $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
788 my ($self, $step) = @_;
789 return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
790 ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
791 : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")";
794 sub name_step
{ my ($self, $step) = @_; $step }
795 sub next_step
{ $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
797 sub post_step
{ 0 } # success indicates we handled step (don't continue step or loop)
798 sub pre_step
{ 0 } # success indicates we handled step (don't continue step or loop)
799 sub prepare
{ 1 } # failure means show step
802 my ($self, $step, $out) = @_;
804 $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
805 print ref($out) eq 'SCALAR' ? $$out : $out;
808 sub ready_validate
{ ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0 }
811 my ($self, $step, $is_at_end) = @_;
812 return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
814 my $next_step = $self->run_hook('next_step', $step) || return 0;
815 $self->run_hook('set_ready_validate', $step, 0);
816 $self->append_path($next_step);
820 sub set_ready_validate
{ # hook and method
822 my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
823 $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
827 sub skip
{ 0 } # success indicates to skip the step (and continue loop)
830 my ($self, $step, $file, $swap) = @_;
832 my $args = $self->run_hook('template_args', $step) || {};
833 $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
835 my $t = $self->template_obj($args);
837 $t->process($file, $swap, \
$out) || die $t->error;
842 my ($self, $step, $form) = @_;
844 my $hash = $self->run_hook('hash_validation', $step);
845 my $what_was_validated = [];
847 return 1 if ! ref($hash) || ! scalar keys %$hash;
848 my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) };
849 die "Step $step: $@" if $@ && ! $err_obj;
851 ### had an error - store the errors and return false
853 $self->add_errors($err_obj->as_hash({
854 as_hash_join
=> "<br>\n",
855 as_hash_suffix
=> '_error',
860 ### allow for the validation to give us some redirection
861 foreach my $ref (@$what_was_validated) {
862 foreach my $method (qw(append_path replace_path insert_path)) {
863 next if ! (my $val = $ref->{$method});
864 $self->$method(ref $val ? @$val : $val);
871 ###---------------------###
874 sub navigate_authenticated
{
875 my ($self, $args) = @_;
876 $self = $self->new($args) if ! ref $self;
878 croak
"The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting"
879 if $self->can('require_auth') != \
&CGI
::Ex
::App
::require_auth
;
881 $self->require_auth(1);
883 return $self->navigate;
888 $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
889 return $self->{'require_auth'} || 0;
893 my $data = shift-
>auth_data;
894 return $data && ! $data->{'error'};
897 sub check_valid_auth
{
898 return shift-
>_do_auth({
899 login_print
=> sub {}, # check only - don't login if not
900 location_bounce
=> sub {}, # call get_valid_auth - but don't bounce to other locations
907 return $self->_do_auth({
908 login_print
=> sub { # use CGI::Ex::Auth - but use our formatting and printing
909 my ($auth, $template, $hash) = @_;
910 my $step = $self->login_step;
911 my $hash_base = $self->run_hook('hash_base', $step) || {};
912 my $hash_comm = $self->run_hook('hash_common', $step) || {};
913 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
914 my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
916 my $out = $self->run_hook('swap_template', $step, $template, $swap);
917 $self->run_hook('fill_template', $step, \
$out, $hash);
918 $self->run_hook('print_out', $step, \
$out);
924 my ($self, $extra) = @_;
925 return $self->auth_data if $self->is_authed;
927 my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
928 $args->{'script_name'} ||= $self->script_name;
929 $args->{'path_info'} ||= $self->path_info;
930 $args->{'cgix'} ||= $self->cgix;
931 $args->{'form'} ||= $self->form;
932 $args->{'cookies'} ||= $self->cookies;
933 $args->{'js_uri_path'} ||= $self->js_uri_path;
934 $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
935 $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
936 $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
938 require CGI
::Ex
::Auth
;
939 my $obj = CGI
::Ex
::Auth-
>new($args);
940 my $resp = $obj->get_valid_auth;
942 my $data = $obj->last_auth_data;
943 delete $data->{'real_pass'} if defined $data; # data may be defined but false
944 $self->auth_data($data); # failed authentication may still have auth_data
946 return ($resp && $data) ? $data : undef;
949 ###---------------------###
952 ### A simple step that allows for printing javascript libraries that are stored in perls @INC.
953 ### Which ever step is in js_step should do something similar for js validation to work.
957 ### make sure path info looks like /js/CGI/Ex/foo.js
958 my $file = $self->form->{'js'} || $self->path_info;
959 $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
961 $self->cgix->print_js($file);
962 $self->{'_no_post_navigate'} = 1;
966 ### A step that will be used the path method determines it is forbidden
967 sub __forbidden_info_complete
{ 0 }
968 sub __forbidden_hash_swap
{ shift-
>stash }
969 sub __forbidden_file_print
{ \
"<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
971 ### A step that is used by the default handle_error
972 sub __error_info_complete
{ 0 }
973 sub __error_hash_swap
{ shift-
>stash }
974 sub __error_file_print
{ \
"<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
978 ### See the perldoc in CGI/Ex/App.pod