File Coverage

blib/lib/CGI/Ex/App.pm
Criterion Covered Total %
statement 577 592 97.4
branch 288 344 83.7
condition 241 325 74.1
subroutine 162 165 98.1
pod 103 135 76.3
total 1371 1561 87.8


line stmt bran cond sub pod time code
1             package CGI::Ex::App;
2              
3             ###---------------------###
4             # Copyright - Paul Seamons
5             # Distributed under the Perl Artistic License without warranty
6              
7 1     1   712 use 5.006; #our
  1         3  
8 1     1   4 use strict;
  1         2  
  1         25  
9             BEGIN {
10 1     1   440 eval { use Time::HiRes qw(time) };
  1     1   1211  
  1         3  
  1         2  
  0         0  
11 1     1   173 eval { use Scalar::Util };
  1         2  
  1         26  
  1         8037  
  0         0  
12             }
13             our $VERSION = '2.54'; # VERSION
14              
15 21     21 0 245 sub croak { die sprintf "%s at %3\$s line %4\$s\n", $_[0], caller 1 }
16              
17             sub new {
18 196   66 196 1 23032 my $class = shift || croak "Missing class name";
19 194 100       609 my $self = bless ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_}, $class;
    100          
20 194         488 $self->init;
21 194         527 $self->init_from_conf;
22 192         653 return $self;
23             }
24              
25       69 1   sub init {}
26             sub init_from_conf {
27 194     194 1 233 my $self = shift;
28 194 100 100     349 @$self{keys %$_} = values %$_ if $self->load_conf and $_ = $self->conf;
29             }
30              
31             sub import { # only ever called with explicit use CGI::Ex::App qw() - not with use base
32 3     3   1335 my $class = shift;
33 3 50       17 return if not @_ = grep { /^:?App($|__)/ } @_;
  3         24  
34 3         445 require CGI::Ex::App::Constants;
35 3         7 unshift @_, 'CGI::Ex::App::Constants';
36 3         8110 goto &CGI::Ex::App::Constants::import;
37             }
38              
39             ###---------------------###
40              
41             sub navigate {
42 78     78 1 2039 my ($self, $args) = @_;
43 78 100       170 $self = $self->new($args) if ! ref $self;
44              
45 78         183 $self->{'_time'} = time;
46 78         92 eval {
47 78 100 100     243 return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
48 77 100       117 local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
  77         259  
49 77         181 $self->nav_loop;
50             };
51 78         147 my $err = $@;
52 78 100 66     180 if ($err && (ref($err) || $err ne "Long Jump\n")) { # catch any errors
      100        
53 8 50       32 die $err if ! $self->can('handle_error');
54 8 100       14 if (! eval { $self->handle_error($err); 1 }) {
  8         26  
  6         15  
55 2         19 die "$err\nAdditionally, the following happened while calling handle_error: $@";
56             }
57             }
58 76 0 66     147 $self->handle_error($@) if ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n";
      33        
      0        
59 76         175 $self->destroy;
60 76         215 return $self;
61             }
62              
63             sub nav_loop {
64 153     153 1 182 my $self = shift;
65 153   100     383 local $self->{'_recurse'} = $self->{'_recurse'} || 0;
66 153 100       318 if ($self->{'_recurse'}++ >= $self->recurse_limit) {
67 2         3 my $err = "recurse_limit (".$self->recurse_limit.") reached";
68 2 50 50     13 croak(($self->{'jumps'} || 0) <= 1 ? $err : "$err number of jumps (".$self->{'jumps'}.")");
69             }
70              
71 151         265 my $path = $self->path;
72 149 100       305 return if $self->pre_loop($path);
73              
74 148   100     458 foreach ($self->{'path_i'} ||= 0; $self->{'path_i'} <= $#$path; $self->{'path_i'}++) {
75 127         195 my $step = $path->[$self->{'path_i'}];
76 127 100       555 if ($step !~ /^([^\W0-9]\w*)$/) {
77 1         4 $self->stash->{'forbidden_step'} = $step;
78 1         4 $self->goto_step($self->forbidden_step);
79             }
80 126         295 $step = $1; # untaint
81              
82 126 100       247 if (! $self->is_authed) {
83 125         237 my $req = $self->run_hook('require_auth', $step, 1);
84 125 100 66     299 return if (ref($req) ? $req->{$step} : $req) && ! $self->run_hook('get_valid_auth', $step);
    50          
85             }
86              
87 119         222 $self->run_hook('morph', $step); # let steps be in external modules
88 117         211 $self->parse_path_info('path_info_map', $self->run_hook('path_info_map', $step));
89 115 100       190 if ($self->run_hook('run_step', $step)) {
90 68         156 $self->run_hook('unmorph', $step);
91 68         158 return;
92             }
93              
94 36         104 $self->run_hook('refine_path', $step, $self->{'path_i'} >= $#$path);
95 36         55 $self->run_hook('unmorph', $step);
96             }
97              
98 57 100       130 return if $self->post_loop($path);
99 56         123 $self->insert_path($self->default_step); # run the default step as a last resort
100 56         238 $self->nav_loop; # go recursive
101 22         45 return;
102             }
103              
104             sub path {
105 329     329 1 470 my $self = shift;
106 329   66     626 return $self->{'path'} ||= do {
107 80         99 my @path;
108 80         157 $self->parse_path_info('path_info_map_base', $self->path_info_map_base); # add initial items to the form hash from path_info
109 76         282 my $step = $self->form->{$self->step_key}; # make sure the step is valid
110 76 100       165 if (defined $step) {
111 41         71 $step =~ s|^/+||; $step =~ s|/|__|g;
  41         60  
112 41 100 100     127 if ($step =~ /^_/) { # can't begin with _
    100 100        
      100        
113 1         5 $self->stash->{'forbidden_step'} = $step;
114 1         4 push @path, $self->forbidden_step;
115             } elsif ($self->valid_steps # must be in valid_steps if defined
116             && ! $self->valid_steps->{$step}
117             && $step ne $self->default_step
118             && $step ne $self->js_step) {
119 1         4 $self->stash->{'forbidden_step'} = $step;
120 1         4 push @path, $self->forbidden_step;
121             } else {
122 39         74 push @path, $step;
123             }
124             }
125 76         217 \@path;
126             };
127             }
128              
129             sub parse_path_info {
130 197     197 0 471 my ($self, $type, $maps, $info, $form) = @_;
131 197 100       319 return if !$maps;
132 88   100     269 $info ||= $self->path_info || return;
      66        
133 18 100       51 croak "Usage: sub $type { [] }" if ! UNIVERSAL::isa($maps, 'ARRAY');
134 15         26 foreach my $map (@$maps) {
135 12 100       26 croak "Usage: sub $type { [[qr{/path_info/(\\w+)}, 'keyname']] }" if ! UNIVERSAL::isa($map, 'ARRAY');
136 9 100       59 my @match = $info =~ $map->[0] or next;
137 6   33     19 $form ||= $self->form;
138 6 100       52 if (UNIVERSAL::isa($map->[1], 'CODE')) {
139 1         3 $map->[1]->($form, @match);
140             } else {
141 5         11 $form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $form->{$map->[$_]}} 1 .. $#$map;
  5         25  
142             }
143 6         17 last;
144             }
145             }
146              
147             sub run_hook {
148 2545     2545 1 4254 my ($self, $hook, $step, @args) = @_;
149 2545 50       4165 my ($code, $found) = (ref $hook eq 'CODE') ? ($_[1], $hook = 'coderef') : ($self->find_hook($hook, $step));
150 2545 100       3756 croak "Could not find a method named ${step}_${hook} or ${hook}" if ! $code;
151              
152 2544 100       5028 return scalar $self->$code($step, @args) if !$self->{'no_history'};
153              
154 31         29 push @{ $self->history }, my $hist = {step => $step, meth => $hook, found => $found, time => time, level => $self->{'_level'}, elapsed => 0};
  31         71  
155 31   100     84 local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
156 31         52 $hist->{'elapsed'} = time - $hist->{'time'};
157 31         57 return $hist->{'response'} = $self->$code($step, @args);
158             }
159              
160             sub find_hook {
161 2545     2545 1 3338 my ($self, $hook, $step) = @_;
162 2545 100       3288 croak "Missing hook name" if ! $hook;
163 2544 100 100     14924 if ($step and my $code = $self->can("${step}_${hook}")) {
    100          
164 311         804 return ($code, "${step}_${hook}");
165             } elsif ($code = $self->can($hook)) {
166 2232         4689 return ($code, $hook);
167             }
168 1         2 return;
169             }
170              
171             sub run_hook_as {
172 3     3 1 2282 my ($self, $hook, $step, $pkg, @args) = @_;
173 3 50       9 croak "Missing hook" if ! $hook;
174 3 50       6 croak "Missing step" if ! $step;
175 3 50       5 croak "Missing package" if ! $pkg;
176 3         10 $self->morph($step, 2, $pkg);
177 3         9 my $resp = $self->run_hook($hook, $step, @args);
178 3         8 $self->unmorph;
179 3         6 return $resp;
180             }
181              
182             sub run_step {
183 111     111 1 172 my ($self, $step) = @_;
184 111 100       172 return 1 if $self->run_hook('pre_step', $step); # if true exit the nav_loop
185 109 100       163 return 0 if $self->run_hook('skip', $step); # if true skip this step
186              
187             # check for complete valid information for this step
188 101 100 100     157 if ( ! $self->run_hook('prepare', $step)
      100        
189             || ! $self->run_hook('info_complete', $step)
190             || ! $self->run_hook('finalize', $step)) {
191              
192 73         285 $self->run_hook('prepared_print', $step); # show the page requesting the information
193 72         742 $self->run_hook('post_print', $step); # a hook after the printing process
194              
195 72         184 return 1;
196             }
197              
198 28 100       49 return 1 if $self->run_hook('post_step', $step); # if true exit the nav_loop
199 27         55 return 0; # let the nav_loop continue searching the path
200             }
201              
202             sub prepared_print {
203 73     73 1 100 my $self = shift;
204 73         74 my $step = shift;
205 73   100     102 my $hash_form = $self->run_hook('hash_form', $step) || {};
206 73   100     304 my $hash_base = $self->run_hook('hash_base', $step) || {};
207 73   100     122 my $hash_comm = $self->run_hook('hash_common', $step) || {};
208 73   100     144 my $hash_swap = $self->run_hook('hash_swap', $step) || {};
209 72   100     141 my $hash_fill = $self->run_hook('hash_fill', $step) || {};
210 72   100     130 my $hash_errs = $self->run_hook('hash_errors', $step) || {};
211 72         214 $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
212 72 100       131 $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
213              
214 72         488 my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
215 72         368 my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
216 72         231 $self->run_hook('print', $step, $swap, $fill);
217             }
218              
219             sub print {
220 72     72 1 111 my ($self, $step, $swap, $fill) = @_;
221 72         102 my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
222 72         213 my $out = $self->run_hook('swap_template', $step, $file, $swap);
223 72         209 $self->run_hook('fill_template', $step, \$out, $fill);
224 72         178 $self->run_hook('print_out', $step, \$out);
225             }
226              
227             sub handle_error {
228 8     8 1 17 my ($self, $err) = @_;
229 8 50       15 die $err if $self->{'_handling_error'};
230 8         19 local @$self{'_handling_error', '_recurse' } = (1, 0); # allow for this next step - even if we hit a recurse error
231 8         23 $self->stash->{'error_step'} = $self->current_step;
232 6         11 $self->stash->{'error'} = $err;
233 6         6 eval {
234 6         17 my $step = $self->error_step;
235 6         13 $self->morph($step); # let steps be in external modules
236 6 50       18 $self->run_hook('run_step', $step) && $self->unmorph($step);
237             };
238 6 50 33     21 die $@ if $@ && $@ ne "Long Jump\n";
239             }
240              
241             ###---------------------###
242             # read only accessors
243              
244 117     117 1 378 sub allow_morph { $_[0]->{'allow_morph'} }
245 2     2 1 11 sub auth_args { $_[0]->{'auth_args'} }
246 11 50   11 1 25 sub auth_obj { shift->{'auth_obj'} || do { require CGI::Ex::Auth; CGI::Ex::Auth->new(@_) } }
  11         888  
  11         37  
247 5 100   5 0 28 sub charset { $_[0]->{'charset'} || '' }
248 5     5 1 15 sub conf_args { $_[0]->{'conf_args'} }
249 2 100   2 0 11 sub conf_die_on_fail { $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} }
250 3 100   3 1 12 sub conf_path { $_[0]->{'conf_path'} || $_[0]->base_dir_abs }
251 4     4 1 8 sub conf_validation { $_[0]->{'conf_validation'} }
252 60 100   60 1 274 sub default_step { $_[0]->{'default_step'} || 'main' }
253 8 100   8 1 37 sub error_step { $_[0]->{'error_step'} || '__error' }
254 71     71 1 224 sub fill_args { $_[0]->{'fill_args'} }
255 5 100   5 1 25 sub forbidden_step { $_[0]->{'forbidden_step'} || '__forbidden' }
256 79 50   79 1 259 sub form_name { $_[0]->{'form_name'} || 'theform' }
257 519   100 519 1 1877 sub history { $_[0]->{'history'} ||= [] }
258 18 100   18 0 55 sub js_step { $_[0]->{'js_step'} || 'js' }
259 9 100   9 0 49 sub login_step { $_[0]->{'login_step'} || '__login' }
260 5 100   5 0 24 sub mimetype { $_[0]->{'mimetype'} || 'text/html' }
261 173 100 100 173 0 843 sub path_info { $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' }
262 80 100   80 1 388 sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] }
263 155 100   155 1 430 sub recurse_limit { $_[0]->{'recurse_limit'} || 15 }
264 116 100 100 116 0 620 sub script_name { $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
265 24   100 24 1 71 sub stash { $_[0]->{'stash'} ||= {} }
266 224 100   224 1 1023 sub step_key { $_[0]->{'step_key'} || 'step' }
267 74     74 1 228 sub template_args { $_[0]->{'template_args'} }
268 73 100   73 1 171 sub template_obj { shift->{'template_obj'} || do { require Template::Alloy; Template::Alloy->new(@_) } }
  72         905  
  72         21206  
269 78 100   78 1 225 sub template_path { $_[0]->{'template_path'} || $_[0]->base_dir_abs }
270 16     16 0 54 sub val_args { $_[0]->{'val_args'} }
271 10 100   10 0 36 sub val_path { $_[0]->{'val_path'} || $_[0]->template_path }
272              
273             sub conf_obj {
274 4     4 1 6 my $self = shift;
275 4   66     20 return $self->{'conf_obj'} || do {
276             my $args = $self->conf_args || {};
277             $args->{'paths'} ||= $self->conf_path;
278             $args->{'directive'} ||= 'MERGE';
279             require CGI::Ex::Conf;
280             CGI::Ex::Conf->new($args);
281             };
282             }
283              
284             sub val_obj {
285 15     15 0 23 my $self = shift;
286 15   66     34 return $self->{'val_obj'} || do {
287             my $args = $self->val_args || {};
288             $args->{'cgix'} ||= $self->cgix;
289             require CGI::Ex::Validate;
290             CGI::Ex::Validate->new($args);
291             };
292             }
293              
294             ###---------------------###
295             # read/write accessors
296              
297 143 100   143 1 286 sub auth_data { (@_ == 2) ? $_[0]->{'auth_data'} = pop : $_[0]->{'auth_data'} }
298 82 100 100 82 1 465 sub base_dir_abs { (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.'] }
299 19 100 100 19 1 74 sub base_dir_rel { (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || '' }
300 14 100 66 14 0 77 sub cgix { (@_ == 2) ? $_[0]->{'cgix'} = pop : $_[0]->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } }
  1         767  
  1         7  
301 3 100 33 3 1 19 sub cookies { (@_ == 2) ? $_[0]->{'cookies'} = pop : $_[0]->{'cookies'} ||= $_[0]->cgix->get_cookies }
302 6 100 100 6 1 35 sub ext_conf { (@_ == 2) ? $_[0]->{'ext_conf'} = pop : $_[0]->{'ext_conf'} || 'pl' }
303 7 100 100 7 1 38 sub ext_print { (@_ == 2) ? $_[0]->{'ext_print'} = pop : $_[0]->{'ext_print'} || 'html' }
304 11 100 100 11 1 52 sub ext_val { (@_ == 2) ? $_[0]->{'ext_val'} = pop : $_[0]->{'ext_val'} || 'val' }
305 11 100 66 11 1 52 sub form { (@_ == 2) ? $_[0]->{'form'} = pop : $_[0]->{'form'} ||= $_[0]->cgix->get_form }
306 195 100   195 1 595 sub load_conf { (@_ == 2) ? $_[0]->{'load_conf'} = pop : $_[0]->{'load_conf'} }
307              
308             sub conf {
309 8     8 1 13 my $self = shift;
310 8 100       20 $self->{'conf'} = pop if @_ == 1;
311 8   66     30 return $self->{'conf'} ||= do {
312 4         5 my $conf = $self->conf_file;
313 4 100 33     12 $conf = $self->conf_obj->read($conf, {no_warn_on_fail => 1}) || ($self->conf_die_on_fail ? croak $@ : {})
314             if ! ref $conf;
315 3         10 my $hash = $self->conf_validation;
316 3 50 100     12 if ($hash && scalar keys %$hash) {
317 2         8 my $err_obj = $self->val_obj->validate($conf, $hash);
318 2 100       9 croak "$err_obj" if $err_obj;
319             }
320 2         13 $conf;
321             }
322             }
323              
324             sub conf_file {
325 10     10 1 18 my $self = shift;
326 10 100       18 $self->{'conf_file'} = pop if @_ == 1;
327 10   66     24 return $self->{'conf_file'} ||= do {
328 4   66     18 my $module = $self->name_module || croak 'Missing name_module during conf_file call';
329 3         27 $module .'.'. $self->ext_conf;
330             };
331             }
332              
333             ###---------------------###
334             # general methods
335              
336 2     2 0 12 sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) }
  2         3  
337 2     2 0 9 sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
  2         4  
338 3     3 0 16 sub add_to_errors { shift->add_errors(@_) }
339 2     2 0 9 sub add_to_fill { my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
  2         3  
340 2     2 0 8 sub add_to_form { my $self = shift; $self->add_to_hash($self->hash_form, @_) }
  2         5  
341 1     1 0 11 sub add_to_path { shift->append_path(@_) } # legacy
342 2     2 0 10 sub add_to_swap { my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
  2         4  
343 7     7 1 34 sub append_path { my $self = shift; push @{ $self->path }, @_ }
  7         65  
  7         19  
344 3     3 1 4 sub cleanup_user { my ($self, $user) = @_; $user }
  3         31  
345 10   100 10 1 33 sub current_step { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
346       76 1   sub destroy {}
347 2     2 1 14 sub first_step { $_[0]->step_by_path_index(0) }
348       12 0   sub fixup_after_morph {}
349       10 0   sub fixup_before_unmorph {}
350 8     8 0 13 sub format_error { my ($self, $error) = @_; $error }
  8         16  
351 1     1 1 3 sub get_pass_by_user { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
352 1     1 0 2 sub has_errors { scalar keys %{ $_[0]->hash_errors } }
  1         3  
353 2     2 1 3 sub last_step { $_[0]->step_by_path_index($#{ $_[0]->path }) }
  2         5  
354       62 1   sub path_info_map {}
355 56     56 1 87 sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
356       74 1   sub post_navigate {}
357 148     148 1 242 sub pre_loop { 0 } # true value means to abort the nav_loop routine
358 73     73 1 200 sub pre_navigate { 0 } # true means to not enter nav_loop
359 3   100 3 1 13 sub previous_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) }
360       36 1   sub valid_steps {}
361 3     3 1 14 sub verify_user { 1 }
362              
363             sub add_errors {
364 7     7 0 9 my $self = shift;
365 7         11 my $hash = $self->hash_errors;
366 7 100       15 my $args = ref($_[0]) ? shift : {@_};
367 7         16 foreach my $key (keys %$args) {
368 7 100       19 my $_key = ($key =~ /error$/) ? $key : "${key}_error";
369 7 100       12 if ($hash->{$_key}) {
370 1         3 $hash->{$_key} .= '
' . $args->{$key};
371             } else {
372 6         12 $hash->{$_key} = $args->{$key};
373             }
374             }
375 7         16 $hash->{'has_errors'} = 1;
376             }
377              
378             sub add_to_hash {
379 10     10 0 14 my $self = shift;
380 10         11 my $old = shift;
381 10 100       19 my $new = ref($_[0]) ? shift : {@_};
382 10         35 @$old{keys %$new} = values %$new;
383             }
384              
385             sub clear_app {
386 1     1 1 3 my $self = shift;
387 1         8 delete @$self{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
388             _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
389 1         4 return $self;
390             }
391              
392             sub dump_history {
393 3     3 1 13 my ($self, $all) = @_;
394 3         7 my $hist = $self->history;
395 3         31 my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
396              
397 3         7 foreach my $row (@$hist) {
398 33 100 100     114 if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) {
      100        
399 9         12 push @$dump, $row;
400 9         11 next;
401             }
402             my $note = (' ' x ($row->{'level'} || 0))
403 24   50     108 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf '%.5f', $row->{'elapsed'});
404 24         31 my $resp = $row->{'response'};
405 24 100       30 if ($all) {
406 16         26 $note = [$note, $resp];
407             } else {
408 8 100 100     55 $note .= ' - '
    100 100        
    100          
    100          
409             .(! defined $resp ? 'undef'
410             : ref($resp) eq 'ARRAY' && !@$resp ? '[]'
411             : ref($resp) eq 'HASH' && !scalar keys %$resp ? '{}'
412             : $resp =~ /^(.{30}|.{0,30}(?=\n))(?s:.)/ ? "$1..." : $resp);
413 8 50       27 $note .= ' - '.$row->{'info'} if defined $row->{'info'};
414             }
415 24         41 push @$dump, $note;
416             }
417              
418 3         12 return $dump;
419             }
420              
421             sub exit_nav_loop {
422 14     14 1 29 my $self = shift;
423 14 100       25 if (my $ref = $self->{'_morph_lineage'}) { # undo morphs
424 2         3 my $index = $self->{'_morph_lineage_start_index'}; # allow for early "morphers" to only get rolled back so far
425 2 100       6 $index = -1 if ! defined $index;
426 2         8 $self->unmorph while $#$ref != $index;
427             }
428 14         191 die "Long Jump\n";
429             }
430              
431             sub insert_path {
432 57     57 1 78 my $self = shift;
433 57         78 my $ref = $self->path;
434 57   100     119 my $i = $self->{'path_i'} || 0;
435 57 100       100 if ($i + 1 > $#$ref) { push @$ref, @_ }
  56         120  
436 1         4 else { splice(@$ref, $i + 1, 0, @_) } # insert a path at the current location
437             }
438              
439 9     9 1 111 sub jump { shift->goto_step(@_) }
440              
441             sub goto_step {
442 20     20 1 42 my $self = shift;
443 20 50       41 my $i = @_ == 1 ? shift : 1;
444 20         38 my $path = $self->path;
445 20   100     52 my $path_i = $self->{'path_i'} || 0;
446              
447 20 100       98 if ( $i eq 'FIRST' ) { $i = - $path_i - 1 }
  2 100       4  
    100          
    100          
    100          
    100          
448 1         3 elsif ($i eq 'LAST' ) { $i = $#$path - $path_i }
449 1         2 elsif ($i eq 'NEXT' ) { $i = 1 }
450 1         2 elsif ($i eq 'CURRENT' ) { $i = 0 }
451 1         2 elsif ($i eq 'PREVIOUS') { $i = -1 }
452             elsif ($i !~ /^-?\d+/) { # look for a step by that name in the current remaining path
453 11         15 my $found;
454 11         25 for (my $j = $path_i; $j < @$path; $j++) {
455 16 100       40 if ($path->[$j] eq $i) {
456 1         2 $i = $j - $path_i;
457 1         2 $found = 1;
458 1         2 last;
459             }
460             }
461 11 100       30 if (! $found) {
462 10         38 $self->replace_path($i);
463 10         13 $i = $#$path;
464             }
465             }
466 20 50       84 croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/;
467              
468 20         28 my $cut_i = $path_i + $i; # manipulate the path to contain the new jump location
469 20 100       75 my @replace = ($cut_i > $#$path) ? $self->default_step
    100          
470             : ($cut_i < 0) ? @$path
471             : @$path[$cut_i .. $#$path];
472 20         50 $self->replace_path(@replace);
473              
474 20   100     53 $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
475 20         24 $self->{'path_i'}++; # move along now that the path is updated
476              
477 20   100     62 my $lin = $self->{'_morph_lineage'} || [];
478 20 100       41 $self->unmorph if @$lin;
479 20         44 $self->nav_loop; # recurse on the path
480 12         39 $self->exit_nav_loop;
481             }
482              
483             sub js_uri_path {
484 13     13 1 18 my $self = shift;
485 13         19 my $script = $self->script_name;
486 13         34 my $js_step = $self->js_step;
487 13 50 33     113 return ($self->can('path') == \&CGI::Ex::App::path
488             && $self->can('path_info_map_base') == \&CGI::Ex::App::path_info_map_base)
489             ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
490             : $script .'?'. $self->step_key .'='. $js_step .'&js='; # use one that works with more paths
491             }
492              
493              
494             sub morph {
495 133     133 1 400 my $self = shift;
496 133         235 my $ref = $self->history->[-1];
497 133 100 66     423 if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'morph') {
      100        
498 115         123 push @{ $self->history }, ($ref = {meth => 'morph', found => 'morph', elapsed => 0, step => 'unknown', level => $self->{'_level'}});
  115         135  
499             }
500 133   100     256 my $step = shift || return;
501 132   100     311 my $allow = shift || $self->run_hook('allow_morph', $step) || return;
502 21         49 my $new = shift; # optionally allow passing in the package to morph to
503 21   100     60 my $lin = $self->{'_morph_lineage'} ||= [];
504 21         27 my $ok = 0;
505 21         28 my $cur = ref $self;
506              
507 21         45 push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
508              
509             # hash - but no step - record for unbless
510 21 100 100     70 if (ref($allow) && ! ($allow = $allow->{$step})) {
    50 66        
    100          
511 1         3 $ref->{'info'} = "not allowed to morph to that step";
512              
513             } elsif (! ($new ||= $self->run_hook('morph_package', $step))) {
514 0         0 $ref->{'info'} = "Missing morph_package for step $step";
515              
516             } elsif ($cur eq $new) {
517 2         10 $ref->{'info'} = "already isa $new";
518 2         3 $ok = 1;
519              
520             ### if we are not already that package - bless us there
521             } else {
522 18         63 (my $file = "$new.pm") =~ s|::|/|g;
523 18 100 66     127 if (UNIVERSAL::can($new, 'fixup_after_morph') # check if the package space exists
    100 66        
    50          
524 6         773 || (eval { require $file } # check for a file that holds this package
525             && UNIVERSAL::can($new, 'fixup_after_morph'))) {
526 12         22 bless $self, $new; # become that package
527 12         24 $self->fixup_after_morph($step);
528 12         28 $ref->{'info'} = "changed $cur to $new";
529             } elsif ($@) {
530 5 100 66     42 if ($allow eq '1' && $@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
531 4         19 $ref->{'info'} = "failed from $cur to $new: $1";
532             } else {
533 1         6 $ref->{'info'} = "failed from $cur to $new: $@";
534 1         9 die "Trouble while morphing from $cur to $new: $@";
535             }
536             } elsif ($allow ne '1') {
537 1         4 $ref->{'info'} = "package $new doesn't support CGI::Ex::App API";
538 1         9 die "Found package $new, but $new does not support CGI::Ex::App API";
539             }
540 16         35 $ok = 1;
541             }
542              
543 19         41 return $ok;
544             }
545              
546             sub replace_path {
547 31     31 1 40 my $self = shift;
548 31         55 my $ref = $self->path;
549 31   100     75 my $i = $self->{'path_i'} || 0;
550 31 100       55 if ($i + 1 > $#$ref) { push @$ref, @_; }
  13         29  
551 18         53 else { splice(@$ref, $i + 1, $#$ref - $i, @_); } # replace remaining entries
552             }
553              
554             sub set_path {
555 3     3 1 500 my $self = shift;
556 3   100     14 my $path = $self->{'path'} ||= [];
557 3 100       12 croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
558 2         7 splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
559             }
560              
561             sub step_by_path_index {
562 45     45 0 55 my $self = shift;
563 45   100     71 my $i = shift || 0;
564 45         68 my $ref = $self->path;
565 43 100       74 return '' if $i < 0;
566 42         115 return $ref->[$i];
567             }
568              
569             sub unmorph {
570 116     116 1 133 my $self = shift;
571 116   100     193 my $step = shift || '_no_step';
572 116   50     204 my $ref = $self->history->[-1] || {};
573 116 100 33     475 if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'unmorph') {
      66        
574 114         128 push @{ $self->history }, ($ref = {meth => 'unmorph', found => 'unmorph', elapsed => 0, step => $step, level => $self->{'_level'}});
  114         145  
575             }
576 116   100     319 my $lin = $self->{'_morph_lineage'} || return;
577 19         22 my $cur = ref $self;
578 19   33     37 my $prev = pop(@$lin) || croak "unmorph called more times than morph (current: $cur)";
579 19 100       40 delete $self->{'_morph_lineage'} if ! @$lin;
580              
581 19 100       33 if ($cur ne $prev) {
582 10         37 $self->fixup_before_unmorph($step);
583 10         15 bless $self, $prev;
584 10         25 $ref->{'info'} = "changed from $cur to $prev";
585             } else {
586 9         16 $ref->{'info'} = "already isa $cur";
587             }
588              
589 19         33 return 1;
590             }
591              
592             ###---------------------###
593             # hooks
594              
595             sub file_print {
596 7     7 1 13 my ($self, $step) = @_;
597 7         17 my $base_dir = $self->base_dir_rel;
598 7         19 my $module = $self->run_hook('name_module', $step);
599 7   66     15 my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step";
600 6         26 $_step =~ s|\B__+|/|g;
601 6 100       24 $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
602 6 100 66     11 foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
  12         36  
603 6         32 return $base_dir . $module . $_step;
604             }
605              
606             sub file_val {
607 10     10 1 21 my ($self, $step) = @_;
608              
609 10   100     18 my $abs = $self->val_path || [];
610 10 100       37 $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
611 10 100       24 $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');
612 10 100       22 return {} if @$abs == 0;
613              
614 9         14 my $base_dir = $self->base_dir_rel;
615 9         19 my $module = $self->run_hook('name_module', $step);
616 9   66     19 my $_step = $self->run_hook('name_step', $step) || croak "Missing name_step";
617 8         22 $_step =~ s|\B__+|/|g;
618 8         13 $_step =~ s/\.\w+$//;
619 8         16 $_step .= '.'. $self->ext_val;
620              
621 8 100 100     17 foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
  25         71  
622              
623 8 100       16 if (@$abs > 1) {
624 1         3 foreach my $_abs (@$abs) {
625 2         6 my $path = "$_abs/$base_dir/$module/$_step";
626 2 50       60 return $path if -e $path;
627             }
628             }
629 8         61 return $abs->[0] . $base_dir . $module . $_step;
630             }
631              
632             sub fill_template {
633 72     72 1 118 my ($self, $step, $outref, $fill) = @_;
634 72 100 66     261 return if ! $fill || ! scalar keys %$fill;
635 71   50     122 my $args = $self->run_hook('fill_args', $step) || {};
636 71         202 local @$args{'text', 'form'} = ($outref, $fill);
637 71         1138 require CGI::Ex::Fill;
638 71         166 CGI::Ex::Fill::fill($args);
639             }
640              
641 25     25 1 60 sub finalize { 1 } # false means show step
642              
643             sub hash_base {
644 78     78 1 135 my ($self, $step) = @_;
645 78   100     241 my $hash = $self->{'hash_base'} ||= {
646             script_name => $self->script_name,
647             path_info => $self->path_info,
648             };
649              
650 78         128 my $copy = $self; eval { require Scalar::Util; Scalar::Util::weaken($copy) };
  78         97  
  78         371  
  78         225  
651 78     1   280 $hash->{'js_validation'} = sub { $copy->run_hook('js_validation', $step, shift) };
  1         714  
652 78 0   0   201 $hash->{'generate_form'} = sub { $copy->run_hook('generate_form', $step, (ref($_[0]) ? (undef, shift) : shift)) };
  0         0  
653 78         148 $hash->{'form_name'} = $self->run_hook('form_name', $step);
654 78         142 $hash->{$self->step_key} = $step;
655 78         177 return $hash;
656             }
657              
658 61   100 61 1 242 sub hash_common { $_[0]->{'hash_common'} ||= {} }
659 82   100 82 1 278 sub hash_errors { $_[0]->{'hash_errors'} ||= {} }
660 72   100 72 1 271 sub hash_fill { $_[0]->{'hash_fill'} ||= {} }
661 76     76 1 162 sub hash_form { $_[0]->form }
662 72   100 72 1 275 sub hash_swap { $_[0]->{'hash_swap'} ||= {} }
663              
664             sub hash_validation {
665 2     2 1 4 my ($self, $step) = @_;
666 2   66     8 return $self->{'hash_validation'}->{$step} ||= do {
667 1         3 my $file = $self->run_hook('file_val', $step);
668 1 50       10 $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies)
669             };
670             }
671              
672             sub info_complete {
673 9     9 1 18 my ($self, $step) = @_;
674 9 100       14 return 0 if ! $self->run_hook('ready_validate', $step);
675 8 100       20 return $self->run_hook('validate', $step, $self->form) ? 1 : 0;
676             }
677              
678             sub js_validation {
679 6     6 1 15 my ($self, $step) = @_;
680 6   100     28 my $form_name = $_[2] || $self->run_hook('form_name', $step);
681 6   100     19 my $hash_val = $_[3] || $self->run_hook('hash_validation', $step);
682 6 100 100     44 return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
      100        
683 2         12 return $self->val_obj->generate_js($hash_val, $form_name, $self->js_uri_path);
684             }
685              
686             sub generate_form {
687 0     0 0 0 my ($self, $step) = @_;
688 0   0     0 my $form_name = $_[2] || $self->run_hook('form_name', $step);
689 0 0       0 my $args = ref($_[3]) eq 'HASH' ? $_[3] : {};
690 0         0 my $hash_val = $self->run_hook('hash_validation', $step);
691 0 0 0     0 return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
      0        
692 0         0 local $args->{'js_uri_path'} = $self->js_uri_path;
693 0         0 return $self->val_obj->generate_form($hash_val, $form_name, $args);
694             }
695              
696 20     20 0 25 sub morph_base { my $self = shift; ref($self) }
  20         36  
697             sub morph_package {
698 20     20 1 499 my ($self, $step) = @_;
699 20         40 my $cur = $self->morph_base; # default to using self as the base for morphed modules
700 20 50 66     60 my $new = ($cur ? $cur .'::' : '') . ($step || croak "Missing step");
701 19         43 $new =~ s/\B__+/::/g; # turn Foo::my_nested__step info Foo::my_nested::step
702 19         193 $new =~ s/(?:_+|\b)(\w)/\u$1/g; # turn Foo::my_step_name into Foo::MyStepName
703 19         86 return $new;
704             }
705              
706             sub name_module {
707 21     21 1 33 my ($self, $step) = @_;
708 21 100 100     70 return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
      66        
709             ? $1 : die "Could not determine module name from \"name_module\" lookup (".($step||'').")\n";
710             }
711              
712 10     10 1 16 sub name_step { my ($self, $step) = @_; $step }
  10         22  
713 28   100 28 1 82 sub next_step { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
714 72     72 1 114 sub post_print { 0 }
715 27     27 1 49 sub post_step { 0 } # true indicates we handled step (exit loop)
716 109     109 1 203 sub pre_step { 0 } # true indicates we handled step (exit loop)
717 100     100 1 228 sub prepare { 1 } # false means show step
718              
719             sub print_out {
720 4     4 1 8 my ($self, $step, $out) = @_;
721 4         9 $self->cgix->print_content_type($self->run_hook('mimetype', $step), $self->run_hook('charset', $step));
722 4 100       112 print ref($out) eq 'SCALAR' ? $$out : $out;
723             }
724              
725             sub ready_validate {
726 12     12 1 20 my ($self, $step) = @_;
727 12 50 33     22 if ($self->run_hook('validate_when_data', $step)
728 0 0       0 and my @keys = keys %{ $self->run_hook('hash_validation', $step) || {} }) {
729 0         0 my $form = $self->form;
730 0 0       0 return (grep { exists $form->{$_} } @keys) ? 1 : 0;
  0         0  
731             }
732 12 100 66     65 return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
733             }
734              
735             sub refine_path {
736 36     36 1 59 my ($self, $step, $is_at_end) = @_;
737 36 100       60 return 0 if ! $is_at_end; # if we are not at the end of the path, do not do anything
738 27   100     44 my $next_step = $self->run_hook('next_step', $step) || return 0;
739 1         8 $self->run_hook('set_ready_validate', $step, 0);
740 1         5 $self->append_path($next_step);
741 1         2 return 1;
742             }
743              
744             sub set_ready_validate {
745 5     5 1 34 my $self = shift;
746 5 100       14 my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift); # hook and method
747 5 100       20 $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
748 5         8 return $is_ready;
749             }
750              
751 101     101 1 202 sub skip { 0 } # success indicates to skip the step (and continue loop)
752              
753             sub swap_template {
754 72     72 1 404 my ($self, $step, $file, $swap) = @_;
755 72         162 my $t = $self->__template_obj($step);
756 72         1102 my $out = '';
757 72 50       211 $t->process($file, $swap, \$out) || die $t->error;
758 72         59948 return $out;
759             }
760              
761             sub __template_obj {
762 72     72   93 my ($self, $step) = @_;
763 72   50     111 my $args = $self->run_hook('template_args', $step) || {};
764 72   33     324 $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
      33        
765 72         158 return $self->template_obj($args);
766             }
767              
768             sub validate {
769 8     8 1 15 my ($self, $step, $form) = @_;
770 8         36 my $hash = $self->__hash_validation($step);
771 8 100 66     65 return 1 if ! ref($hash) || ! scalar keys %$hash;
772              
773 7         8 my @validated_fields;
774 7 100       10 if (my $err_obj = eval { $self->val_obj->validate($form, $hash, \@validated_fields) }) {
  7         24  
775 4         18 $self->add_errors($err_obj->as_hash({as_hash_join => "
\n", as_hash_suffix => '_error'}));
776 4         44 return 0;
777             }
778 3 50       9 die "Step $step: $@" if $@;
779              
780 3         6 foreach my $ref (@validated_fields) { # allow for the validation to give us some redirection
781 3 0       6 $self->append_path( ref $_ ? @$_ : $_) if $_ = $ref->{'append_path'};
    50          
782 3 0       6 $self->replace_path(ref $_ ? @$_ : $_) if $_ = $ref->{'replace_path'};
    50          
783 3 0       6 $self->insert_path( ref $_ ? @$_ : $_) if $_ = $ref->{'insert_path'};
    50          
784             }
785              
786 3         21 return 1;
787             }
788              
789 8     8   19 sub __hash_validation { shift->run_hook('hash_validation', @_) }
790              
791 12     12 1 30 sub validate_when_data { $_[0]->{'validate_when_data'} }
792              
793             ###---------------------###
794             # authentication
795              
796             sub navigate_authenticated {
797 3     3 1 6 my ($self, $args) = @_;
798 3 50       7 $self = $self->new($args) if ! ref $self;
799 3 100       22 croak "Cannot call navigate_authenticated method if default require_auth method is overwritten"
800             if $self->can('require_auth') != \&CGI::Ex::App::require_auth;
801 2         6 $self->require_auth(1);
802 2         6 return $self->navigate;
803             }
804              
805             sub require_auth {
806 116     116 1 150 my $self = shift;
807 116 50 66     237 $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
      100        
808 116   100     316 return $self->{'require_auth'} || 0;
809             }
810              
811 138 100   138 1 294 sub is_authed { my $data = shift->auth_data; $data && ! $data->{'error'} }
  138         313  
812              
813 4     0 0 25 sub check_valid_auth { shift->_do_auth({login_print => sub {}, location_bounce => sub {}}) }
        4      
814              
815             sub get_valid_auth {
816 8     8 1 13 my $self = shift;
817             return $self->_do_auth({
818             login_print => sub { # use CGI::Ex::Auth - but use our formatting and printing
819 7     7   13 my ($auth, $template, $hash) = @_;
820 7         12 local $self->{'__login_file_print'} = $template;
821 7         11 local $self->{'__login_hash_common'} = $hash;
822 7         26 return $self->goto_step($self->login_step);
823             }
824 8         42 });
825             }
826              
827             sub _do_auth {
828 12     12   24 my ($self, $extra) = @_;
829 12 100       17 return $self->auth_data if $self->is_authed;
830 11 50       14 my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
  11 50       31  
  11         121  
831 11   33     70 $args->{'script_name'} ||= $self->script_name;
832 11   33     35 $args->{'path_info'} ||= $self->path_info;
833 11   33     46 $args->{'cgix'} ||= $self->cgix;
834 11   33     94 $args->{'form'} ||= $self->form;
835 11   33     63 $args->{'cookies'} ||= $self->cookies;
836 11   33     64 $args->{'js_uri_path'} ||= $self->js_uri_path;
837 11   50 3   58 $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
  3         3  
  3         8  
838 11   50 3   81 $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
  3         4  
  3         9  
839 11   50 3   56 $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
  3         5  
  3         9  
840              
841 11         30 my $obj = $self->auth_obj($args);
842 11         29 my $resp = $obj->get_valid_auth;
843 4         9 my $data = $obj->last_auth_data;
844 4 100       10 delete $data->{'real_pass'} if defined $data; # data may be defined but false
845 4         11 $self->auth_data($data); # failed authentication may still have auth_data
846 4 100 66     21 return ($resp && $data) ? $data : undef;
847             }
848              
849             ###---------------------###
850             # default steps
851              
852 1     1 0 2 sub js_require_auth { 0 }
853             sub js_run_step { # step that allows for printing javascript libraries that are stored in perls @INC.
854 3     3 0 5 my $self = shift;
855 3   100     5 my $path = $self->form->{'js'} || $self->path_info;
856 3 100       6 $self->cgix->print_js($path =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$! ? $1 : '');
857 3         20 $self->{'_no_post_navigate'} = 1;
858 3         4 return 1;
859             }
860              
861 3     3   6 sub __forbidden_require_auth { 0 }
862 3 50   3   7 sub __forbidden_allow_morph { shift->allow_morph(@_) && 1 }
863 3     3   9 sub __forbidden_info_complete { 0 } # step that will be used the path method determines it is forbidden
864 3     3   7 sub __forbidden_hash_common { shift->stash }
865 3     3   5 sub __forbidden_file_print { \ "

Denied

You do not have access to the step \"[% forbidden_step.html %]\"" }
866              
867 4 50   4   8 sub __error_allow_morph { shift->allow_morph(@_) && 1 }
868 6     6   26 sub __error_info_complete { 0 } # step that is used by the default handle_error
869 6     6   12 sub __error_hash_common { shift->stash }
870 4     4   7 sub __error_file_print { \ "

A fatal error occurred

Step: \"[% error_step.html %]\"
[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
871              
872 7     7   22 sub __login_require_auth { 0 }
873 7 50   7   19 sub __login_allow_morph { shift->allow_morph(@_) && 1 }
874 7     7   17 sub __login_info_complete { 0 } # step used by default authentication
875 7 50   7   22 sub __login_hash_common { shift->{'__login_hash_common'} || {error => "hash_common not set during default __login"} }
876 7 50   7   16 sub __login_file_print { shift->{'__login_file_print'} || \ "file_print not set during default __login
[% login_error %]" }
877              
878             1; # Full documentation resides in CGI/Ex/App.pod