3 ###---------------------###
4 # See the perldoc in CGI/Ex/App.pod
5 # Copyright 2004-2012 - Paul Seamons
6 # Distributed under the Perl Artistic License without warranty
11 eval { use Time
::HiRes
qw(time) };
12 eval { use Scalar
::Util
};
14 our $VERSION = '2.37';
17 my $class = shift || croak
"Usage: ".__PACKAGE__
."->new";
18 my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
22 $self->init_from_conf;
30 return if ! $self->load_conf;
31 my $conf = $self->conf;
32 @{ $self }{ keys %$conf } = values %$conf;
36 sub import
{ # only ever called with explicit use CGI::Ex::App qw() - not with use base
38 if (@_ = grep { /^:?App($|__)/ } @_) {
39 require CGI
::Ex
::App
::Constants
;
40 unshift @_, 'CGI::Ex::App::Constants';
41 goto &CGI
::Ex
::App
::Constants
::import
;
45 ###---------------------###
48 my ($self, $args) = @_;
49 $self = $self->new($args) if ! ref $self;
51 $self->{'_time'} = time;
53 return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
54 local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
58 if ($err && (ref($err) || $err ne "Long Jump\n")) { # catch any errors
59 die $err if ! $self->can('handle_error');
60 if (! eval { $self->handle_error($err); 1 }) {
61 die "$err\nAdditionally, the following happened while calling handle_error: $@";
64 $self->handle_error($@) if ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n";
73 local $self->{'_recurse'} = $self->{'_recurse'} || 0;
74 if ($self->{'_recurse'}++ >= $self->recurse_limit) {
75 my $err = "recurse_limit (".$self->recurse_limit.") reached";
76 $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
80 my $path = $self->path;
81 return if $self->pre_loop($path);
83 foreach ($self->{'path_i'} ||= 0; $self->{'path_i'} <= $#$path; $self->{'path_i'}++) {
84 my $step = $path->[$self->{'path_i'}];
85 if ($step !~ /^([^\W0-9]\w*)$/) {
86 $self->stash->{'forbidden_step'} = $step;
87 $self->goto_step($self->forbidden_step);
91 if (! $self->is_authed) {
92 my $req = $self->run_hook('require_auth', $step, 1);
93 return if (ref($req) ? $req->{$step} : $req) && ! $self->run_hook('get_valid_auth', $step);
96 $self->run_hook('morph', $step); # let steps be in external modules
98 # allow for mapping path_info pieces to form elements
99 $self->parse_path_info('path_info_map', $self->run_hook('path_info_map', $step));
101 if ($self->run_hook('run_step', $step)) {
102 $self->run_hook('unmorph', $step);
106 my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
107 $self->run_hook('refine_path', $step, $is_at_end); # no more steps - allow for this step to designate one to follow
108 $self->run_hook('unmorph', $step);
111 return if $self->post_loop($path);
113 $self->insert_path($self->default_step); # run the default step as a last resort
114 $self->nav_loop; # go recursive
121 return $self->{'path'} ||= do {
124 $self->parse_path_info('path_info_map_base', $self->path_info_map_base); # add initial items to the form hash from path_info
125 my $step = $self->form->{$self->step_key}; # make sure the step is valid
127 $step =~ s
|^/+||; $step =~ s|/|__
|g
;
128 if ($step =~ /^_/) { # can't begin with _
129 $self->stash->{'forbidden_step'} = $step;
130 push @$path, $self->forbidden_step;
131 } elsif ($self->valid_steps # must be in valid_steps if defined
132 && ! $self->valid_steps->{$step}
133 && $step ne $self->default_step
134 && $step ne $self->js_step) {
135 $self->stash->{'forbidden_step'} = $step;
136 push @$path, $self->forbidden_step;
145 sub parse_path_info
{
146 my ($self, $type, $maps, $info, $form) = @_;
147 $info ||= $self->path_info || return;
148 $form ||= $self->form;
150 croak
"Usage: sub $type { [] }" if ! UNIVERSAL
::isa
($maps, 'ARRAY');
151 foreach my $map (@$maps) {
152 croak
"Usage: sub $type { [[qr{/path_info/(\\w+)}, 'keyname']] }" if ! UNIVERSAL
::isa
($map, 'ARRAY');
153 my @match = $info =~ $map->[0];
155 if (UNIVERSAL
::isa
($map->[1], 'CODE')) {
156 $map->[1]->($form, @match);
158 $form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $form->{$map->[$_]}} 1 .. $#$map;
165 my ($self, $hook, $step, @args) = @_;
167 if (ref $hook eq 'CODE') {
169 $hook = $found = 'coderef';
171 ($code, $found) = @{ $self->find_hook($hook, $step) };
173 croak
"Could not find a method named ${step}_${hook} or ${hook}" if ! $code;
174 croak
"Value for $hook ($found) is not a code ref ($code)" if ! UNIVERSAL
::isa
($code, 'CODE');
177 if (! $self->{'no_history'}) {
178 push @{ $self->history }, ($hist = {step
=> $step, meth
=> $hook, found
=> $found, time => time, level
=> $self->{'_level'}});
179 $hist->{'elapsed'} = time - $hist->{'time'};
181 local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
183 my $resp = $self->$code($step, @args);
185 if (! $self->{'no_history'}) {
186 $hist->{'elapsed'} = time - $hist->{'time'};
187 $hist->{'response'} = $resp;
194 my ($self, $hook, $step, $pkg, @args) = @_;
195 croak
"Missing hook" if ! $hook;
196 croak
"Missing step" if ! $step;
197 croak
"Missing package" if ! $pkg;
198 $self->morph($step, 2, $pkg);
199 my $resp = $self->run_hook($hook, $step, @args);
208 return 1 if $self->run_hook('pre_step', $step); # if true exit the nav_loop
209 return 0 if $self->run_hook('skip', $step); # if true skip this step
211 # check for complete valid information for this step
212 if ( ! $self->run_hook('prepare', $step)
213 || ! $self->run_hook('info_complete', $step)
214 || ! $self->run_hook('finalize', $step)) {
216 $self->run_hook('prepared_print', $step); # show the page requesting the information
217 $self->run_hook('post_print', $step); # a hook after the printing process
222 return 1 if $self->run_hook('post_step', $step); # if true exit the nav_loop
223 return 0; # let the nav_loop continue searching the path
229 my $hash_form = $self->run_hook('hash_form', $step) || {};
230 my $hash_base = $self->run_hook('hash_base', $step) || {};
231 my $hash_comm = $self->run_hook('hash_common', $step) || {};
232 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
233 my $hash_fill = $self->run_hook('hash_fill', $step) || {};
234 my $hash_errs = $self->run_hook('hash_errors', $step) || {};
235 $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
236 $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
238 my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
239 my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
240 $self->run_hook('print', $step, $swap, $fill);
244 my ($self, $step, $swap, $fill) = @_;
245 my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
246 my $out = $self->run_hook('swap_template', $step, $file, $swap);
247 $self->run_hook('fill_template', $step, \
$out, $fill);
248 $self->run_hook('print_out', $step, \
$out);
252 my ($self, $err) = @_;
253 die $err if $self->{'_handling_error'};
254 local @{ $self }{'_handling_error', '_recurse' } = (1, 0); # allow for this next step - even if we hit a recurse error
255 $self->stash->{'error_step'} = $self->current_step;
256 $self->stash->{'error'} = $err;
258 my $step = $self->error_step;
259 $self->morph($step); # let steps be in external modules
260 $self->run_hook('run_step', $step) && $self->unmorph($step);
262 die $@ if $@ && $@ ne "Long Jump\n";
265 ###---------------------###
266 # read only accessors
268 sub allow_morph
{ $_[0]->{'allow_morph'} }
269 sub auth_args
{ $_[0]->{'auth_args'} }
270 sub charset
{ $_[0]->{'charset'} || '' }
271 sub conf_args
{ $_[0]->{'conf_args'} }
272 sub conf_die_on_fail
{ $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} }
273 sub conf_path
{ $_[0]->{'conf_path'} || $_[0]->base_dir_abs }
274 sub conf_validation
{ $_[0]->{'conf_validation'} }
275 sub default_step
{ $_[0]->{'default_step'} || 'main' }
276 sub error_step
{ $_[0]->{'error_step'} || '__error' }
277 sub fill_args
{ $_[0]->{'fill_args'} }
278 sub forbidden_step
{ $_[0]->{'forbidden_step'} || '__forbidden' }
279 sub form_name
{ $_[0]->{'form_name'} || 'theform' }
280 sub history
{ $_[0]->{'history'} ||= [] }
281 sub js_step
{ $_[0]->{'js_step'} || 'js' }
282 sub login_step
{ $_[0]->{'login_step'} || '__login' }
283 sub mimetype
{ $_[0]->{'mimetype'} || 'text/html' }
284 sub path_info
{ $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' }
285 sub path_info_map_base
{ $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] }
286 sub recurse_limit
{ $_[0]->{'recurse_limit'} || 15 }
287 sub script_name
{ $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
288 sub stash
{ $_[0]->{'stash'} ||= {} }
289 sub step_key
{ $_[0]->{'step_key'} || 'step' }
290 sub template_args
{ $_[0]->{'template_args'} }
291 sub template_path
{ $_[0]->{'template_path'} || $_[0]->base_dir_abs }
292 sub val_args
{ $_[0]->{'val_args'} }
293 sub val_path
{ $_[0]->{'val_path'} || $_[0]->template_path }
297 return $self->{'conf_obj'} || do {
298 my $args = $self->conf_args || {};
299 $args->{'paths'} ||= $self->conf_path;
300 $args->{'directive'} ||= 'MERGE';
301 require CGI
::Ex
::Conf
;
302 CGI
::Ex
::Conf-
>new($args);
307 my ($self, $args) = @_;
308 return $self->{'template_obj'} || do {
309 require Template
::Alloy
;
310 Template
::Alloy-
>new($args);
315 my ($self, $args) = @_;
316 return $self->{'auth_obj'} || do {
317 require CGI
::Ex
::Auth
;
318 CGI
::Ex
::Auth-
>new($args);
324 return $self->{'val_obj'} || do {
325 my $args = $self->val_args || {};
326 $args->{'cgix'} ||= $self->cgix;
327 require CGI
::Ex
::Validate
;
328 CGI
::Ex
::Validate-
>new($args);
332 ###---------------------###
333 # read/write accessors
335 sub auth_data
{ (@_ == 2) ? $_[0]->{'auth_data'} = pop : $_[0]->{'auth_data'} }
336 sub base_dir_abs
{ (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.'] }
337 sub base_dir_rel
{ (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || '' }
338 sub cgix
{ (@_ == 2) ? $_[0]->{'cgix'} = pop : $_[0]->{'cgix'} ||= do { require CGI
::Ex
; CGI
::Ex-
>new } }
339 sub cookies
{ (@_ == 2) ? $_[0]->{'cookies'} = pop : $_[0]->{'cookies'} ||= $_[0]->cgix->get_cookies }
340 sub ext_conf
{ (@_ == 2) ? $_[0]->{'ext_conf'} = pop : $_[0]->{'ext_conf'} || 'pl' }
341 sub ext_print
{ (@_ == 2) ? $_[0]->{'ext_print'} = pop : $_[0]->{'ext_print'} || 'html' }
342 sub ext_val
{ (@_ == 2) ? $_[0]->{'ext_val'} = pop : $_[0]->{'ext_val'} || 'val' }
343 sub form
{ (@_ == 2) ? $_[0]->{'form'} = pop : $_[0]->{'form'} ||= $_[0]->cgix->get_form }
344 sub load_conf
{ (@_ == 2) ? $_[0]->{'load_conf'} = pop : $_[0]->{'load_conf'} }
348 $self->{'conf'} = pop if @_ == 1;
349 return $self->{'conf'} ||= do {
350 my $conf = $self->conf_file;
352 $conf = $self->conf_obj->read($conf, {no_warn_on_fail
=> 1}) || ($self->conf_die_on_fail ? croak
$@ : {});
354 my $hash = $self->conf_validation;
355 if ($hash && scalar keys %$hash) {
356 my $err_obj = $self->val_obj->validate($conf, $hash);
357 croak
"$err_obj" if $err_obj;
365 $self->{'conf_file'} = pop if @_ == 1;
366 return $self->{'conf_file'} ||= do {
367 my $module = $self->name_module || croak
'Missing name_module during conf_file call';
368 $module .'.'. $self->ext_conf;
372 ###---------------------###
375 sub add_to_base
{ my $self = shift; $self->add_to_hash($self->hash_base, @_) }
376 sub add_to_common
{ my $self = shift; $self->add_to_hash($self->hash_common, @_) }
377 sub add_to_errors
{ shift-
>add_errors(@_) }
378 sub add_to_fill
{ my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
379 sub add_to_form
{ my $self = shift; $self->add_to_hash($self->hash_form, @_) }
380 sub add_to_path
{ shift-
>append_path(@_) } # legacy
381 sub add_to_swap
{ my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
382 sub append_path
{ my $self = shift; push @{ $self->path }, @_ }
383 sub cleanup_user
{ my ($self, $user) = @_; $user }
384 sub current_step
{ $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
386 sub first_step
{ $_[0]->step_by_path_index(0) }
387 sub fixup_after_morph
{}
388 sub fixup_before_unmorph
{}
389 sub format_error
{ my ($self, $error) = @_; $error }
390 sub get_pass_by_user
{ croak
"get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
391 sub has_errors
{ scalar keys %{ $_[0]->hash_errors } }
392 sub last_step
{ $_[0]->step_by_path_index($#{ $_[0]->path }) }
394 sub post_loop
{ 0 } # true value means to abort the nav_loop - don't recurse
396 sub pre_loop
{ 0 } # true value means to abort the nav_loop routine
397 sub pre_navigate
{ 0 } # true means to not enter nav_loop
398 sub previous_step
{ $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) }
400 sub verify_user
{ 1 }
404 my $hash = $self->hash_errors;
405 my $args = ref($_[0]) ? shift : {@_};
406 foreach my $key (keys %$args) {
407 my $_key = ($key =~ /error$/) ? $key : "${key}_error";
408 if ($hash->{$_key}) {
409 $hash->{$_key} .= '<br>' . $args->{$key};
411 $hash->{$_key} = $args->{$key};
414 $hash->{'has_errors'} = 1;
421 $new = {$new, @_} if ! ref $new; # non-hashref
422 $old->{$_} = $new->{$_} foreach keys %$new;
427 delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
428 _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
433 my ($self, $all) = @_;
435 my $hist = $self->history;
436 my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
438 foreach my $row (@$hist) {
439 if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) {
443 my $note = (' ' x
($row->{'level'} || 0))
444 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
445 my $resp = $row->{'response'};
447 $note = [$note, $resp];
450 .(! defined $resp ? 'undef'
451 : ref($resp) eq 'ARRAY' && ! @$resp ? '[]'
452 : ref($resp) eq 'HASH' && ! scalar keys %$resp ? '{}'
454 $resp = $1 if $resp =~ /^(.+)\n/;
455 length($resp) > 30 ? substr($resp, 0, 30)." ..." : $resp;
457 $note .= ' - '.$row->{'info'} if defined $row->{'info'};
467 if (my $ref = $self->{'_morph_lineage'}) { # undo morphs
468 my $index = $self->{'_morph_lineage_start_index'}; # allow for early "morphers" to only get rolled back so far
469 $index = -1 if ! defined $index;
470 $self->unmorph while $#$ref != $index;
476 my ($self, $hook, $step) = @_;
477 croak
"Missing hook name" if ! $hook;
478 if ($step && (my $code = $self->can("${step}_${hook}"))) {
479 return [$code, "${step}_${hook}"],
480 } elsif ($code = $self->can($hook)) {
481 return [$code, $hook];
488 my $ref = $self->path;
489 my $i = $self->{'path_i'} || 0;
490 if ($i + 1 > $#$ref) { push @$ref, @_ }
491 else { splice(@$ref, $i + 1, 0, @_) } # insert a path at the current location
494 sub jump
{ shift-
>goto_step(@_) }
498 my $i = @_ == 1 ? shift : 1;
499 my $path = $self->path;
500 my $path_i = $self->{'path_i'} || 0;
502 if ( $i eq 'FIRST' ) { $i = - $path_i - 1 }
503 elsif ($i eq 'LAST' ) { $i = $#$path - $path_i }
504 elsif ($i eq 'NEXT' ) { $i = 1 }
505 elsif ($i eq 'CURRENT' ) { $i = 0 }
506 elsif ($i eq 'PREVIOUS') { $i = -1 }
507 elsif ($i !~ /^-?\d+/) { # look for a step by that name in the current remaining path
509 for (my $j = $path_i; $j < @$path; $j++) {
510 if ($path->[$j] eq $i) {
517 $self->replace_path($i);
521 croak
"Invalid jump index ($i)" if $i !~ /^-?\d+$/;
523 my $cut_i = $path_i + $i; # manipulate the path to contain the new jump location
524 my @replace = ($cut_i > $#$path) ? $self->default_step
525 : ($cut_i < 0) ? @$path
526 : @$path[$cut_i .. $#$path];
527 $self->replace_path(@replace);
529 $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
530 $self->{'path_i'}++; # move along now that the path is updated
532 my $lin = $self->{'_morph_lineage'} || [];
533 $self->unmorph if @$lin;
534 $self->nav_loop; # recurse on the path
535 $self->exit_nav_loop;
540 my $script = $self->script_name;
541 my $js_step = $self->js_step;
542 return ($self->can('path') == \
&CGI
::Ex
::App
::path
543 && $self->can('path_info_map_base') == \
&CGI
::Ex
::App
::path_info_map_base
)
544 ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
545 : $script .'?'. $self->step_key .'='. $js_step .'&js='; # use one that works with more paths
551 my $ref = $self->history->[-1];
552 if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'morph') {
553 push @{ $self->history }, ($ref = {meth
=> 'morph', found
=> 'morph', elapsed
=> 0, step
=> 'unknown', level
=> $self->{'_level'}});
555 my $step = shift || return;
556 my $allow = shift || $self->run_hook('allow_morph', $step) || return;
557 my $new = shift; # optionally allow passing in the package to morph to
558 my $lin = $self->{'_morph_lineage'} ||= [];
562 push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
564 # hash - but no step - record for unbless
565 if (ref($allow) && ! ($allow = $allow->{$step})) {
566 $ref->{'info'} = "not allowed to morph to that step";
568 } elsif (! ($new ||= $self->run_hook('morph_package', $step))) {
569 $ref->{'info'} = "Missing morph_package for step $step";
571 } elsif ($cur eq $new) {
572 $ref->{'info'} = "already isa $new";
575 ### if we are not already that package - bless us there
577 (my $file = "$new.pm") =~ s
|::|/|g
;
578 if (UNIVERSAL
::can
($new, 'fixup_after_morph') # check if the package space exists
579 || (eval { require $file } # check for a file that holds this package
580 && UNIVERSAL
::can
($new, 'fixup_after_morph'))) {
581 bless $self, $new; # become that package
582 $self->fixup_after_morph($step);
583 $ref->{'info'} = "changed $cur to $new";
585 if ($allow eq '1' && $@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
586 $ref->{'info'} = "failed from $cur to $new: $1";
588 $ref->{'info'} = "failed from $cur to $new: $@";
589 die "Trouble while morphing from $cur to $new: $@";
591 } elsif ($allow ne '1') {
592 $ref->{'info'} = "package $new doesn't support CGI::Ex::App API";
593 die "Found package $new, but $new doesn't support CGI::Ex::App API";
603 my $ref = $self->path;
604 my $i = $self->{'path_i'} || 0;
605 if ($i + 1 > $#$ref) { push @$ref, @_; }
606 else { splice(@$ref, $i + 1, $#$ref - $i, @_); } # replace remaining entries
611 my $path = $self->{'path'} ||= [];
612 croak
"Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
613 splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
616 sub step_by_path_index
{
619 my $ref = $self->path;
626 my $step = shift || '_no_step';
627 my $ref = $self->history->[-1] || {};
628 if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'unmorph') {
629 push @{ $self->history }, ($ref = {meth
=> 'unmorph', found
=> 'unmorph', elapsed
=> 0, step
=> $step, level
=> $self->{'_level'}});
631 my $lin = $self->{'_morph_lineage'} || return;
633 my $prev = pop(@$lin) || croak
"unmorph called more times than morph (current: $cur)";
634 delete $self->{'_morph_lineage'} if ! @$lin;
637 $self->fixup_before_unmorph($step);
639 $ref->{'info'} = "changed from $cur to $prev";
641 $ref->{'info'} = "already isa $cur";
647 ###---------------------###
651 my ($self, $step) = @_;
652 my $base_dir = $self->base_dir_rel;
653 my $module = $self->run_hook('name_module', $step);
654 my $_step = $self->run_hook('name_step', $step) || croak
"Missing name_step";
655 $_step =~ s
|\B__
+|/|g
;
656 $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
657 foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
659 return $base_dir . $module . $_step;
663 my ($self, $step) = @_;
665 my $abs = $self->val_path || [];
666 $abs = $abs->() if UNIVERSAL
::isa
($abs, 'CODE');
667 $abs = [$abs] if ! UNIVERSAL
::isa
($abs, 'ARRAY');
668 return {} if @$abs == 0;
670 my $base_dir = $self->base_dir_rel;
671 my $module = $self->run_hook('name_module', $step);
672 my $_step = $self->run_hook('name_step', $step) || croak
"Missing name_step";
673 $_step =~ s
|\B__
+|/|g
;
674 $_step =~ s/\.\w+$//;
675 $_step .= '.'. $self->ext_val;
677 foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m
|/$| }
680 foreach my $_abs (@$abs) {
681 my $path = $_abs . $base_dir . $module . $_step;
682 return $path if -e
$path;
686 return $abs->[0] . $base_dir . $module . $_step;
690 my ($self, $step, $outref, $fill) = @_;
691 return if ! $fill || ! scalar keys %$fill;
692 my $args = $self->run_hook('fill_args', $step) || {};
693 local @{ $args }{'text', 'form'} = ($outref, $fill);
694 require CGI
::Ex
::Fill
;
695 CGI
::Ex
::Fill
::fill
($args);
698 sub finalize
{ 1 } # false means show step
701 my ($self, $step) = @_;
703 my $hash = $self->{'hash_base'} ||= {
704 script_name
=> $self->script_name,
705 path_info
=> $self->path_info,
708 my $copy = $self; eval { require Scalar
::Util
; Scalar
::Util
::weaken
($copy) };
709 $hash->{'js_validation'} = sub { $copy->run_hook('js_validation', $step, shift) };
710 $hash->{'generate_form'} = sub { $copy->run_hook('generate_form', $step, (ref($_[0]) ? (undef, shift) : shift)) };
711 $hash->{'form_name'} = $self->run_hook('form_name', $step);
712 $hash->{$self->step_key} = $step;
717 sub hash_common
{ $_[0]->{'hash_common'} ||= {} }
718 sub hash_errors
{ $_[0]->{'hash_errors'} ||= {} }
719 sub hash_fill
{ $_[0]->{'hash_fill'} ||= {} }
720 sub hash_form
{ $_[0]->form }
721 sub hash_swap
{ $_[0]->{'hash_swap'} ||= {} }
723 sub hash_validation
{
724 my ($self, $step) = @_;
725 return $self->{'hash_validation'}->{$step} ||= do {
726 my $file = $self->run_hook('file_val', $step);
727 $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies)
732 my ($self, $step) = @_;
733 return 0 if ! $self->run_hook('ready_validate', $step);
734 return 0 if ! $self->run_hook('validate', $step, $self->form);
739 my ($self, $step) = @_;
740 my $form_name = $_[2] || $self->run_hook('form_name', $step);
741 my $hash_val = $_[3] || $self->run_hook('hash_validation', $step);
742 my $js_uri = $self->js_uri_path;
743 return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
744 return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
748 my ($self, $step) = @_;
749 my $form_name = $_[2] || $self->run_hook('form_name', $step);
750 my $args = ref($_[3]) eq 'HASH' ? $_[3] : {};
751 my $hash_val = $self->run_hook('hash_validation', $step);
752 return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
753 local $args->{'js_uri_path'} = $self->js_uri_path;
754 return $self->val_obj->generate_form($hash_val, $form_name, $args);
757 sub morph_base
{ my $self = shift; ref($self) }
759 my ($self, $step) = @_;
760 my $cur = $self->morph_base; # default to using self as the base for morphed modules
761 my $new = ($cur ? $cur .'::' : '') . ($step || croak
"Missing step");
762 $new =~ s/\B__+/::/g; # turn Foo::my_nested__step info Foo::my_nested::step
763 $new =~ s/(?:_+|\b)(\w)/\u$1/g; # turn Foo::my_step_name into Foo::MyStepName
768 my ($self, $step) = @_;
769 return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
770 ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
771 : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")";
774 sub name_step
{ my ($self, $step) = @_; $step }
775 sub next_step
{ $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
777 sub post_step
{ 0 } # true indicates we handled step (exit loop)
778 sub pre_step
{ 0 } # true indicates we handled step (exit loop)
779 sub prepare
{ 1 } # false means show step
782 my ($self, $step, $out) = @_;
783 $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
784 print ref($out) eq 'SCALAR' ? $$out : $out;
788 my ($self, $step) = @_;
789 if ($self->run_hook('validate_when_data', $step)) {
790 if (my @keys = keys %{ $self->run_hook('hash_validation', $step) || {} }) {
791 my $form = $self->form;
792 return (grep { exists $form->{$_} } @keys) ? 1 : 0;
795 return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
799 my ($self, $step, $is_at_end) = @_;
800 return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
802 my $next_step = $self->run_hook('next_step', $step) || return 0;
803 $self->run_hook('set_ready_validate', $step, 0);
804 $self->append_path($next_step);
808 sub set_ready_validate
{ # hook and method
810 my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
811 $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
815 sub skip
{ 0 } # success indicates to skip the step (and continue loop)
818 my ($self, $step, $file, $swap) = @_;
820 my $args = $self->run_hook('template_args', $step) || {};
821 $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
823 my $t = $self->template_obj($args);
825 $t->process($file, $swap, \
$out) || die $t->error;
830 my ($self, $step, $form) = @_;
832 my $hash = $self->run_hook('hash_validation', $step);
833 my $what_was_validated = [];
835 return 1 if ! ref($hash) || ! scalar keys %$hash;
836 my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) };
837 die "Step $step: $@" if $@ && ! $err_obj;
839 ### had an error - store the errors and return false
841 $self->add_errors($err_obj->as_hash({
842 as_hash_join
=> "<br>\n",
843 as_hash_suffix
=> '_error',
848 ### allow for the validation to give us some redirection
849 foreach my $ref (@$what_was_validated) {
850 foreach my $method (qw(append_path replace_path insert_path)) {
851 next if ! (my $val = $ref->{$method});
852 $self->$method(ref $val ? @$val : $val);
859 sub validate_when_data
{ $_[0]->{'validate_when_data'} }
861 ###---------------------###
864 sub navigate_authenticated
{
865 my ($self, $args) = @_;
866 $self = $self->new($args) if ! ref $self;
867 croak
"Can't call navigate_authenticated method if default require_auth method is overwritten"
868 if $self->can('require_auth') != \
&CGI
::Ex
::App
::require_auth
;
869 $self->require_auth(1);
870 return $self->navigate;
875 $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
876 return $self->{'require_auth'} || 0;
879 sub is_authed
{ my $data = shift-
>auth_data; $data && ! $data->{'error'} }
881 sub check_valid_auth
{
882 return shift-
>_do_auth({
883 login_print
=> sub {}, # check only - don't login if not
884 location_bounce
=> sub {}, # call get_valid_auth - but don't bounce to other locations
890 return $self->_do_auth({
891 login_print
=> sub { # use CGI::Ex::Auth - but use our formatting and printing
892 my ($auth, $template, $hash) = @_;
893 local $self->{'__login_file_print'} = $template;
894 local $self->{'__login_hash_common'} = $hash;
895 return $self->goto_step($self->login_step);
902 my ($self, $extra) = @_;
903 return $self->auth_data if $self->is_authed;
905 my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
906 $args->{'script_name'} ||= $self->script_name;
907 $args->{'path_info'} ||= $self->path_info;
908 $args->{'cgix'} ||= $self->cgix;
909 $args->{'form'} ||= $self->form;
910 $args->{'cookies'} ||= $self->cookies;
911 $args->{'js_uri_path'} ||= $self->js_uri_path;
912 $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
913 $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
914 $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
916 my $obj = $self->auth_obj($args);
917 my $resp = $obj->get_valid_auth;
918 my $data = $obj->last_auth_data;
919 delete $data->{'real_pass'} if defined $data; # data may be defined but false
920 $self->auth_data($data); # failed authentication may still have auth_data
922 return ($resp && $data) ? $data : undef;
925 ###---------------------###
928 sub js_run_step
{ # step that allows for printing javascript libraries that are stored in perls @INC.
930 my $file = $self->form->{'js'} || $self->path_info;
931 $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; # make sure path info looks like /js/CGI/Ex/foo.js
933 $self->cgix->print_js($file);
934 $self->{'_no_post_navigate'} = 1;
938 sub __forbidden_require_auth
{ 0 }
939 sub __forbidden_allow_morph
{ shift-
>allow_morph(@_) && 1 }
940 sub __forbidden_info_complete
{ 0 } # step that will be used the path method determines it is forbidden
941 sub __forbidden_hash_common
{ shift-
>stash }
942 sub __forbidden_file_print
{ \
"<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step.html %]\"</b>" }
944 sub __error_allow_morph
{ shift-
>allow_morph(@_) && 1 }
945 sub __error_info_complete
{ 0 } # step that is used by the default handle_error
946 sub __error_hash_common
{ shift-
>stash }
947 sub __error_file_print
{ \
"<h1>A fatal error occurred</h1>Step: <b>\"[% error_step.html %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
949 sub __login_require_auth
{ 0 }
950 sub __login_allow_morph
{ shift-
>allow_morph(@_) && 1 }
951 sub __login_info_complete
{ 0 } # step used by default authentication
952 sub __login_hash_common
{ shift-
>{'__login_hash_common'} || {error
=> "hash_common not set during default __login"} }
953 sub __login_file_print
{ shift-
>{'__login_file_print'} || \
"file_print not set during default __login<br>[% login_error %]" }
957 ### See the perldoc in CGI/Ex/App.pod