Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/App.pm

   1 package CGI::Ex::App;
   2
   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 ###----------------------------------------------------------------###
   8
   9 use strict;
  10 use Carp qw(croak);
  11 BEGIN {
  12     eval { use Time::HiRes qw(time) };
  13     eval { use Scalar::Util };
  14 }
  15
  16 our $VERSION = '2.22';
  17
  18 sub new {
  19     my $class = shift || croak "Usage: ".__PACKAGE__."->new";
  20     my $self  = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
  21     bless $self, $class;
  22
  23     $self->init;
  24     $self->init_from_conf;
  25
  26     return $self;
  27 }
  28
  29 sub init_from_conf {
  30     my $self = shift;
  31     return if ! $self->load_conf;
  32     my $conf = $self->conf;
  33     @{ $self }{ keys %$conf } = values %$conf;
  34     return;
  35 }
  36
  37 ###---------------------###
  38
  39 sub navigate {
  40     my ($self, $args) = @_;
  41     $self = $self->new($args) if ! ref $self;
  42
  43     $self->{'_time'} = time;
  44     eval {
  45         return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
  46
  47         eval {
  48             local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
  49             $self->nav_loop;
  50         };
  51         croak $@ if $@ && $@ ne "Long Jump\n";
  52
  53         $self->post_navigate if ! $self->{'_no_post_navigate'};
  54     };
  55     $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors
  56
  57     $self->destroy;
  58
  59     return $self;
  60 }
  61
  62 sub nav_loop {
  63     my $self = shift;
  64
  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;
  70         croak $err;
  71     }
  72
  73     my $path = $self->path;
  74
  75     ### allow for an early return
  76     return if $self->pre_loop($path); # a true value means to abort the navigate
  77
  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);
  86             next;
  87         }
  88         $step = $1; # untaint
  89
  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);
  95             }
  96         }
  97
  98         ### allow for becoming another package (allows for some steps in external files)
  99         $self->morph($step);
 100
 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];
 108                 next if ! @match;
 109                 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
 110                 last;
 111             }
 112         }
 113
 114         ### run the guts of the step
 115         my $handled = $self->run_hook('run_step', $step);
 116
 117         ### Allow for the run_step to intercept.
 118         ### A true status means the run_step took over navigation.
 119         if ($handled) {
 120             $self->unmorph($step);
 121             return;
 122         }
 123
 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);
 127
 128         $self->unmorph($step);
 129     }
 130
 131     ### allow for one exit point after the loop
 132     return if $self->post_loop($path); # a true value means to abort the navigate
 133
 134     ### run the default step as a last resort
 135     $self->insert_path($self->default_step);
 136     $self->nav_loop; # go recursive
 137
 138     return;
 139 }
 140
 141 sub path {
 142     my $self = shift;
 143     if (! $self->{'path'}) {
 144         my $path = $self->{'path'} = []; # empty path
 145
 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];
 153                 next if ! @match;
 154                 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
 155                 last;
 156             }
 157         }
 158
 159         ### make sure the step is valid
 160         my $step = $self->form->{$self->step_key};
 161         if (defined $step) {
 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;
 171             } else {
 172                 push @$path, $step;
 173             }
 174         }
 175     }
 176
 177     return $self->{'path'};
 178 }
 179
 180 sub run_hook {
 181     my $self = shift;
 182     my $hook = shift;
 183     my $step = shift;
 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');
 187
 188     my $hist;
 189     if (! $self->{'no_history'}) {
 190         $hist = {
 191             step  => $step,
 192             meth  => $hook,
 193             found => $found,
 194             time  => time,
 195         };
 196         push @{ $self->history }, $hist;
 197         $hist->{'level'} = $self->{'_level'};
 198         $hist->{'elapsed'}  = time - $hist->{'time'};
 199     }
 200     local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
 201
 202     my $resp = $self->$code($step, @_);
 203
 204     if (! $self->{'no_history'}) {
 205         $hist->{'elapsed'} = time - $hist->{'time'};
 206         $hist->{'response'} = $resp;
 207     }
 208
 209     return $resp;
 210 }
 211
 212 sub run_step {
 213     my $self = shift;
 214     my $step = shift;
 215
 216     ### if the pre_step exists and returns true, exit the nav_loop
 217     return 1 if $self->run_hook('pre_step', $step);
 218
 219     ### allow for skipping this step (but stay in the nav_loop)
 220     return 0 if $self->run_hook('skip', $step);
 221
 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)) {
 228
 229         ### show the page requesting the information
 230         $self->run_hook('prepared_print', $step);
 231
 232         ### a hook after the printing process
 233         $self->run_hook('post_print', $step);
 234
 235         return 1;
 236     }
 237
 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);
 241
 242     ### let the nav_loop continue searching the path
 243     return 0;
 244 }
 245
 246 sub prepared_print {
 247     my $self = shift;
 248     my $step = shift;
 249
 250     my $hash_form = $self->run_hook('hash_form',   $step) || {};
 251     my $hash_base = $self->run_hook('hash_base',   $step) || {};
 252     my $hash_comm = $self->run_hook('hash_common', $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) || {};
 256
 257     $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
 258     $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
 259
 260     my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
 261     my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
 262
 263     $self->run_hook('print', $step, $swap, $fill);
 264 }
 265
 266 sub print {
 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);
 272 }
 273
 274 sub handle_error {
 275     my ($self, $err) = @_;
 276
 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
 280
 281     $self->stash->{'error_step'} = $self->current_step;
 282     $self->stash->{'error'}      = $err;
 283     $self->replace_path($self->error_step);
 284
 285     eval { $self->jump };
 286     die $@ if $@ && $@ ne "Long Jump\n";
 287 }
 288
 289 ###---------------------###
 290 # read only accessors
 291
 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 }
 319
 320 sub conf_obj {
 321     my $self = shift;
 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);
 328     };
 329 }
 330
 331 sub template_obj {
 332     my ($self, $args) = @_;
 333     return $self->{'template_obj'} || do {
 334         require Template::Alloy;
 335         Template::Alloy->new($args);
 336     };
 337 }
 338
 339 sub auth_obj {
 340     my ($self, $args) = @_;
 341     return $self->{'auth_obj'} || do {
 342         require CGI::Ex::Auth;
 343         CGI::Ex::Auth->new($args);
 344     };
 345 }
 346
 347 sub val_obj {
 348     my $self = shift;
 349     return $self->{'val_obj'} || do {
 350         my $args = $self->val_args || {};
 351         $args->{'cgix'} ||= $self->cgix;
 352         require CGI::Ex::Validate;
 353         CGI::Ex::Validate->new($args);
 354     };
 355 }
 356
 357 ###---------------------###
 358 # read/write accessors
 359
 360 sub auth_data    { (@_ == 2) ? $_[0]->{'auth_data'}    = pop : $_[0]->{'auth_data'}              }
 361 sub base_dir_abs { (@_ == 2) ? $_[0]->{'base_dir_abs'} = pop : $_[0]->{'base_dir_abs'} || ['.']  }
 362 sub base_dir_rel { (@_ == 2) ? $_[0]->{'base_dir_rel'} = pop : $_[0]->{'base_dir_rel'} || ''     }
 363 sub cgix         { (@_ == 2) ? $_[0]->{'cgix'}         = pop : $_[0]->{'cgix'}         ||= do { require CGI::Ex; CGI::Ex->new } }
 364 sub cookies      { (@_ == 2) ? $_[0]->{'cookies'}      = pop : $_[0]->{'cookies'}      ||= $_[0]->cgix->get_cookies }
 365 sub ext_conf     { (@_ == 2) ? $_[0]->{'ext_conf'}     = pop : $_[0]->{'ext_conf'}     || 'pl'   }
 366 sub ext_print    { (@_ == 2) ? $_[0]->{'ext_print'}    = pop : $_[0]->{'ext_print'}    || 'html' }
 367 sub ext_val      { (@_ == 2) ? $_[0]->{'ext_val'}      = pop : $_[0]->{'ext_val'}      || 'val'  }
 368 sub form         { (@_ == 2) ? $_[0]->{'form'}         = pop : $_[0]->{'form'}         ||= $_[0]->cgix->get_form    }
 369 sub load_conf    { (@_ == 2) ? $_[0]->{'load_conf'}    = pop : $_[0]->{'load_conf'}              }
 370
 371 sub conf {
 372     my $self = shift;
 373     $self->{'conf'} = pop if @_ == 1;
 374     return $self->{'conf'} ||= do {
 375         my $conf = $self->conf_file;
 376         if (! ref $conf) {
 377             $conf = $self->conf_obj->read($conf, {no_warn_on_fail => 1}) || ($self->conf_die_on_fail ? croak $@ : {});
 378         }
 379         my $hash = $self->conf_validation;
 380         if ($hash && scalar keys %$hash) {
 381             my $err_obj = $self->val_obj->validate($conf, $hash);
 382             die $err_obj if $err_obj;
 383         }
 384         $conf;
 385     }
 386 }
 387
 388 sub conf_file {
 389     my $self = shift;
 390     $self->{'conf_file'} = pop if @_ == 1;
 391     return $self->{'conf_file'} ||= do {
 392         my $module = $self->name_module || croak 'Missing name_module during conf_file call';
 393         $module .'.'. $self->ext_conf;
 394     };
 395 }
 396
 397 ###---------------------###
 398 # general methods
 399
 400 sub add_to_base          { my $self = shift; $self->add_to_hash($self->hash_base,   @_) }
 401 sub add_to_common        { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
 402 sub add_to_errors        { shift->add_errors(@_) }
 403 sub add_to_fill          { my $self = shift; $self->add_to_hash($self->hash_fill,   @_) }
 404 sub add_to_form          { my $self = shift; $self->add_to_hash($self->hash_form,   @_) }
 405 sub add_to_path          { shift->append_path(@_) } # legacy
 406 sub add_to_swap          { my $self = shift; $self->add_to_hash($self->hash_swap,   @_) }
 407 sub cleanup_user         { my ($self, $user) = @_; $user }
 408 sub current_step         { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
 409 sub destroy              {}
 410 sub first_step           { $_[0]->step_by_path_index(0) }
 411 sub fixup_after_morph    {}
 412 sub fixup_before_unmorph {}
 413 sub format_error         { my ($self, $error) = @_; $error }
 414 sub get_pass_by_user     { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
 415 sub has_errors           { scalar keys %{ $_[0]->hash_errors } }
 416 sub init                 {}
 417 sub last_step            { $_[0]->step_by_path_index($#{ $_[0]->path }) }
 418 sub path_info_map        {}
 419 sub post_loop            { 0 } # true value means to abort the nav_loop - don't recurse
 420 sub post_navigate        {}
 421 sub pre_loop             { 0 } # true value means to abort the nav_loop routine
 422 sub pre_navigate         { 0 } # true means to not enter nav_loop
 423 sub previous_step        { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) - 1) }
 424 sub valid_steps          {}
 425 sub verify_user          { 1 }
 426
 427 sub add_errors {
 428     my $self = shift;
 429     my $hash = $self->hash_errors;
 430     my $args = ref($_[0]) ? shift : {@_};
 431     foreach my $key (keys %$args) {
 432         my $_key = ($key =~ /error$/) ? $key : "${key}_error";
 433         if ($hash->{$_key}) {
 434             $hash->{$_key} .= '<br>' . $args->{$key};
 435         } else {
 436             $hash->{$_key} = $args->{$key};
 437         }
 438     }
 439     $hash->{'has_errors'} = 1;
 440 }
 441
 442 sub add_to_hash {
 443     my $self = shift;
 444     my $old  = shift;
 445     my $new  = shift;
 446     $new = {$new, @_} if ! ref $new; # non-hashref
 447     $old->{$_} = $new->{$_} foreach keys %$new;
 448 }
 449
 450 sub append_path { my $self = shift; push @{ $self->path }, @_ }
 451
 452 sub clear_app {
 453     my $self = shift;
 454     delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
 455                          _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
 456     return $self;
 457 }
 458
 459 sub dump_history {
 460     my ($self, $all) = @_;
 461
 462     my $hist = $self->history;
 463     my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
 464
 465     foreach my $row (@$hist) {
 466         if (! ref($row) || ref($row) ne 'HASH' || ! exists $row->{'elapsed'}) {
 467             push @$dump, $row;
 468             next;
 469         }
 470         my $note = ('    ' x ($row->{'level'} || 0))
 471             . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
 472         my $resp = $row->{'response'};
 473         if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
 474             $note .= ' - {}';
 475         } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
 476             $note .= ' - []';
 477         } elsif (! defined $resp) {
 478             $note .= ' - undef';
 479         } elsif (! ref $resp || ! $all) {
 480             my $max = $self->{'history_max'} || 30;
 481             if (length($resp) > $max) {
 482                 $resp = substr($resp, 0, $max);
 483                 $resp =~ s/\n.+//s;
 484                 $resp = "$resp ...";
 485             }
 486             $note .= " - $resp";
 487         } else {
 488             $note = [$note, $resp];
 489         }
 490         push @$dump, $note;
 491     }
 492
 493     return $dump;
 494 }
 495
 496 sub exit_nav_loop {
 497     my $self = shift;
 498
 499     ### undo morphs
 500     if (my $ref = $self->{'_morph_lineage'}) {
 501         ### use the saved index - this allows for early "morphers" to only get rolled back so far
 502         my $index = $self->{'_morph_lineage_start_index'};
 503         $index = -1 if ! defined $index;
 504         $self->unmorph while $#$ref != $index;
 505     }
 506
 507     die "Long Jump\n";
 508 }
 509
 510 sub find_hook {
 511     my ($self, $hook, $step) = @_;
 512     croak "Missing hook name" if ! $hook;
 513     if ($step && (my $code = $self->can("${step}_${hook}"))) {
 514         return [$code, "${step}_${hook}"],
 515     } elsif ($code = $self->can($hook)) {
 516         return [$code, $hook];
 517     } else {
 518         return [];
 519     }
 520 }
 521
 522 sub insert_path {
 523     my $self = shift;
 524     my $ref  = $self->path;
 525     my $i    = $self->{'path_i'} || 0;
 526     if ($i + 1 > $#$ref) {
 527         push @$ref, @_;
 528     } else {
 529         splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
 530     }
 531 }
 532
 533 sub jump {
 534     my $self   = shift;
 535     my $i      = @_ == 1 ? shift : 1;
 536     my $path   = $self->path;
 537     my $path_i = $self->{'path_i'};
 538     croak "Can't jump if nav_loop not started" if ! defined $path_i;
 539
 540     if ($i =~ /^\w+$/) {
 541         if (   $i eq 'FIRST'   ) { $i = - $path_i - 1 }
 542         elsif ($i eq 'LAST'    ) { $i = $#$path - $path_i }
 543         elsif ($i eq 'NEXT'    ) { $i = 1  }
 544         elsif ($i eq 'CURRENT' ) { $i = 0  }
 545         elsif ($i eq 'PREVIOUS') { $i = -1 }
 546         else { # look for a step by that name
 547             for (my $j = $#$path; $j >= 0; $j --) {
 548                 if ($path->[$j] eq $i) {
 549                     $i = $j - $path_i;
 550                     last;
 551                 }
 552             }
 553         }
 554     }
 555     croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/;
 556
 557     ### manipulate the path to contain the new jump location
 558     my $cut_i   = $path_i + $i;
 559     my @replace = ($cut_i > $#$path) ? $self->default_step
 560                 : ($cut_i < 0)       ? @$path
 561                 :                      @$path[$cut_i .. $#$path];
 562     $self->replace_path(@replace);
 563
 564     $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
 565
 566     $self->{'path_i'}++; # move along now that the path is updated
 567     $self->nav_loop;     # recurse on the path
 568     $self->exit_nav_loop;
 569 }
 570
 571 sub js_uri_path {
 572     my $self   = shift;
 573     my $script = $self->script_name;
 574     my $js_step = $self->js_step;
 575     return ($self->can('path') == \&CGI::Ex::App::path)
 576         ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
 577         : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
 578 }
 579
 580
 581 sub morph {
 582     my $self  = shift;
 583     my $step  = shift || return;
 584     my $allow = $self->run_hook('allow_morph', $step) || return;
 585     my $lin   = $self->{'_morph_lineage'} ||= [];
 586     my $cur   = ref $self; # what are we currently
 587     push @$lin, $cur;     # store so subsequent unmorph calls can do the right thing
 588
 589     my $hist = {step => $step, meth => 'morph', found => 'morph', time => time, elapsed => 0, response => 0};
 590     push @{ $self->history }, $hist if ! $self->{'no_history'};
 591
 592     if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
 593         $hist->{'found'} .= " (not allowed to morph to that step)";
 594         return 0;
 595     }
 596
 597     ### make sure we haven't already been reblessed
 598     if ($#$lin != 0                                       # is this the second morph call
 599         && (! ($allow = $self->allow_nested_morph($step)) # not true
 600             || (ref($allow) && ! $allow->{$step})         # hash - but no step
 601             )) {
 602         $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
 603         return 0; # just return - don't die so that we can morph early
 604     }
 605
 606     ### if we are not already that package - bless us there
 607     my $new = $self->run_hook('morph_package', $step);
 608     if ($cur ne $new) {
 609         (my $file = "$new.pm") =~ s|::|/|g;
 610         if (UNIVERSAL::can($new, 'can')  # check if the package space exists
 611             || eval { require $file }) { # check for a file that holds this package
 612             bless $self, $new;           # become that package
 613             $hist->{'found'} .= " (changed $cur to $new)";
 614             $self->fixup_after_morph($step);
 615         } elsif ($@) {
 616             if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
 617                 $hist->{'found'} .= " (failed from $cur to $new: $1)";
 618             } else {
 619                 $hist->{'found'} .= " (failed from $cur to $new: $@)";
 620                 my $err = "Trouble while morphing to $file: $@";
 621                 warn $err;
 622             }
 623         }
 624     }
 625
 626     $hist->{'response'} = 1;
 627     return 1;
 628 }
 629
 630 sub replace_path {
 631     my $self = shift;
 632     my $ref  = $self->path;
 633     my $i    = $self->{'path_i'} || 0;
 634     if ($i + 1 > $#$ref) {
 635         push @$ref, @_;
 636     } else {
 637         splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
 638     }
 639 }
 640
 641 sub set_path {
 642     my $self = shift;
 643     my $path = $self->{'path'} ||= [];
 644     croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
 645     splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
 646 }
 647
 648 sub step_by_path_index {
 649     my $self = shift;
 650     my $i    = shift || 0;
 651     my $ref  = $self->path;
 652     return '' if $i < 0;
 653     return $ref->[$i];
 654 }
 655
 656 sub unmorph {
 657     my $self = shift;
 658     my $step = shift || '_no_step';
 659     my $lin  = $self->{'_morph_lineage'} || return;
 660     my $cur  = ref $self;
 661
 662     my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
 663     delete $self->{'_morph_lineage'} if ! @$lin;
 664
 665     my $hist = {step => $step, meth => 'unmorph', found => 'unmorph', time => time, elapsed => 0, response => 0};
 666     push @{ $self->history }, $hist if ! $self->{'no_history'};
 667
 668     if ($cur ne $prev) {
 669         $self->fixup_before_unmorph($step);
 670         bless $self, $prev;
 671         $hist->{'found'} .= " (changed from $cur to $prev)";
 672     } else {
 673         $hist->{'found'} .= " (already isa $cur)";
 674     }
 675
 676     $hist->{'response'} = 1;
 677     return $self;
 678 }
 679
 680 ###---------------------###
 681 # hooks
 682
 683 sub file_print {
 684     my ($self, $step) = @_;
 685
 686     my $base_dir = $self->base_dir_rel;
 687     my $module   = $self->run_hook('name_module', $step);
 688     my $_step    = $self->run_hook('name_step', $step) || croak "Missing name_step";
 689     $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
 690
 691     foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 692
 693     return $base_dir . $module . $_step;
 694 }
 695
 696 sub file_val {
 697     my ($self, $step) = @_;
 698
 699     ### determine the path to begin looking for files - allow for an arrayref
 700     my $abs = $self->val_path || [];
 701     $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
 702     $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');
 703     return {} if @$abs == 0;
 704
 705     my $base_dir = $self->base_dir_rel;
 706     my $module   = $self->run_hook('name_module', $step);
 707     my $_step    = $self->run_hook('name_step', $step) || croak "Missing name_step";
 708     $_step =~ s/\.\w+$//;
 709     $_step .= '.'. $self->ext_val;
 710
 711     foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 712
 713     if (@$abs > 1) {
 714         foreach my $_abs (@$abs) {
 715             my $path = $_abs . $base_dir . $module . $_step;
 716             return $path if -e $path;
 717         }
 718     }
 719
 720     return $abs->[0] . $base_dir . $module . $_step;
 721 }
 722
 723 sub fill_template {
 724     my ($self, $step, $outref, $fill) = @_;
 725     return if ! $fill || ! scalar keys %$fill;
 726
 727     my $args = $self->run_hook('fill_args', $step) || {};
 728     local $args->{'text'} = $outref;
 729     local $args->{'form'} = $fill;
 730
 731     require CGI::Ex::Fill;
 732     CGI::Ex::Fill::fill($args);
 733 }
 734
 735 sub finalize  { 1 } # failure means show step
 736
 737 sub hash_base {
 738     my ($self, $step) = @_;
 739
 740     return $self->{'hash_base'} ||= do {
 741         ### create a weak copy of self to use in closures
 742         my $copy = $self;
 743         eval {require Scalar::Util; Scalar::Util::weaken($copy)};
 744         my $hash = {
 745             script_name     => $self->script_name,
 746             path_info       => $self->path_info,
 747             js_validation   => sub { $copy->run_hook('js_validation', $step, shift) },
 748             form_name       => $self->run_hook('form_name', $step),
 749             $self->step_key => $step,
 750         }; # return of the do
 751     };
 752 }
 753
 754 sub hash_common { $_[0]->{'hash_common'} ||= {} }
 755 sub hash_errors { $_[0]->{'hash_errors'} ||= {} }
 756 sub hash_fill   { $_[0]->{'hash_fill'}   ||= {} }
 757 sub hash_form   { $_[0]->form }
 758 sub hash_swap   { $_[0]->{'hash_swap'}   ||= {} }
 759
 760 sub hash_validation {
 761   my ($self, $step) = @_;
 762   return $self->{'hash_validation'}->{$step} ||= do {
 763       my $file = $self->run_hook('file_val', $step);
 764       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)
 765       $hash; # return of the do
 766   };
 767 }
 768
 769 sub info_complete {
 770     my ($self, $step) = @_;
 771     return 0 if ! $self->run_hook('ready_validate', $step);
 772     return 0 if ! $self->run_hook('validate', $step, $self->form);
 773     return 1;
 774 }
 775
 776 sub js_validation {
 777     my ($self, $step) = @_;
 778     return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
 779
 780     my $form_name = $_[2] || $self->run_hook('form_name', $step);
 781     my $hash_val  = $_[3] || $self->run_hook('hash_validation', $step);
 782     my $js_uri    = $self->js_uri_path;
 783     return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
 784
 785     return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
 786 }
 787
 788 sub morph_package {
 789     my ($self, $step) = @_;
 790     my $cur = ref $self; # default to using self as the base for morphed modules
 791     my $new = $cur .'::'. ($step || croak "Missing step");
 792     $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
 793     return $new;
 794 }
 795
 796 sub name_module {
 797     my ($self, $step) = @_;
 798     return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
 799         ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
 800         : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")";
 801 }
 802
 803 sub name_step  { my ($self, $step) = @_; $step }
 804 sub next_step  { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
 805 sub post_print { 0 }
 806 sub post_step  { 0 } # success indicates we handled step (don't continue step or loop)
 807 sub pre_step   { 0 } # success indicates we handled step (don't continue step or loop)
 808 sub prepare    { 1 } # failure means show step
 809
 810 sub print_out {
 811     my ($self, $step, $out) = @_;
 812
 813     $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
 814     print ref($out) eq 'SCALAR' ? $$out : $out;
 815 }
 816
 817 sub ready_validate { ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0 }
 818
 819 sub refine_path {
 820     my ($self, $step, $is_at_end) = @_;
 821     return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
 822
 823     my $next_step = $self->run_hook('next_step', $step) || return 0;
 824     $self->run_hook('set_ready_validate', $step, 0);
 825     $self->append_path($next_step);
 826     return 1;
 827 }
 828
 829 sub set_ready_validate { # hook and method
 830     my $self = shift;
 831     my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
 832     $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
 833     return $is_ready;
 834 }
 835
 836 sub skip { 0 } # success indicates to skip the step (and continue loop)
 837
 838 sub swap_template {
 839     my ($self, $step, $file, $swap) = @_;
 840
 841     my $args = $self->run_hook('template_args', $step) || {};
 842     $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
 843
 844     my $t = $self->template_obj($args);
 845     my $out = '';
 846     $t->process($file, $swap, \$out) || die $t->error;
 847     return $out;
 848 }
 849
 850 sub validate {
 851     my ($self, $step, $form) = @_;
 852
 853     my $hash = $self->run_hook('hash_validation', $step);
 854     my $what_was_validated = [];
 855
 856     return 1 if ! ref($hash) || ! scalar keys %$hash;
 857     my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) };
 858     die "Step $step: $@" if $@ && ! $err_obj;
 859
 860     ### had an error - store the errors and return false
 861     if ($err_obj) {
 862         $self->add_errors($err_obj->as_hash({
 863             as_hash_join   => "<br>\n",
 864             as_hash_suffix => '_error',
 865         }));
 866         return 0;
 867     }
 868
 869     ### allow for the validation to give us some redirection
 870     foreach my $ref (@$what_was_validated) {
 871         foreach my $method (qw(append_path replace_path insert_path)) {
 872             next if ! (my $val = $ref->{$method});
 873             $self->$method(ref $val ? @$val : $val);
 874         }
 875     }
 876
 877     return 1;
 878 }
 879
 880 ###---------------------###
 881 # authentication
 882
 883 sub navigate_authenticated {
 884     my ($self, $args) = @_;
 885     $self = $self->new($args) if ! ref $self;
 886
 887     croak "The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting"
 888         if $self->can('require_auth') != \&CGI::Ex::App::require_auth;
 889
 890     $self->require_auth(1);
 891
 892     return $self->navigate;
 893 }
 894
 895 sub require_auth {
 896     my $self = shift;
 897     $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
 898     return $self->{'require_auth'} || 0;
 899 }
 900
 901 sub is_authed {
 902     my $data = shift->auth_data;
 903     return $data && ! $data->{'error'};
 904 }
 905
 906 sub check_valid_auth {
 907     return shift->_do_auth({
 908         login_print     => sub {}, # check only - don't login if not
 909         location_bounce => sub {}, # call get_valid_auth - but don't bounce to other locations
 910     });
 911 }
 912
 913 sub get_valid_auth {
 914     my $self = shift;
 915
 916     return $self->_do_auth({
 917         login_print => sub { # use CGI::Ex::Auth - but use our formatting and printing
 918             my ($auth, $template, $hash) = @_;
 919             my $step = $self->login_step;
 920             my $hash_base = $self->run_hook('hash_base',   $step) || {};
 921             my $hash_comm = $self->run_hook('hash_common', $step) || {};
 922             my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
 923             my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
 924
 925             my $out = $self->run_hook('swap_template', $step, $template, $swap);
 926             $self->run_hook('fill_template', $step, \$out, $hash);
 927             $self->run_hook('print_out', $step, \$out);
 928         }
 929     });
 930 }
 931
 932 sub _do_auth {
 933     my ($self, $extra) = @_;
 934     return $self->auth_data if $self->is_authed;
 935
 936     my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
 937     $args->{'script_name'}      ||= $self->script_name;
 938     $args->{'path_info'}        ||= $self->path_info;
 939     $args->{'cgix'}             ||= $self->cgix;
 940     $args->{'form'}             ||= $self->form;
 941     $args->{'cookies'}          ||= $self->cookies;
 942     $args->{'js_uri_path'}      ||= $self->js_uri_path;
 943     $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
 944     $args->{'verify_user'}      ||= sub { my ($auth, $user) = @_; $self->verify_user(     $user, $auth) };
 945     $args->{'cleanup_user'}     ||= sub { my ($auth, $user) = @_; $self->cleanup_user(    $user, $auth) };
 946
 947     my $obj  = $self->auth_obj($args);
 948     my $resp = $obj->get_valid_auth;
 949
 950     my $data = $obj->last_auth_data;
 951     delete $data->{'real_pass'} if defined $data; # data may be defined but false
 952     $self->auth_data($data); # failed authentication may still have auth_data
 953
 954     return ($resp && $data) ? $data : undef;
 955 }
 956
 957 ###---------------------###
 958 # default steps
 959
 960 ### A simple step that allows for printing javascript libraries that are stored in perls @INC.
 961 ### Which ever step is in js_step should do something similar for js validation to work.
 962 sub js_run_step {
 963     my $self = shift;
 964
 965     ### make sure path info looks like /js/CGI/Ex/foo.js
 966     my $file = $self->form->{'js'} || $self->path_info;
 967     $file = ($file =~  m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
 968
 969     $self->cgix->print_js($file);
 970     $self->{'_no_post_navigate'} = 1;
 971     return 1;
 972 }
 973
 974 ### A step that will be used the path method determines it is forbidden
 975 sub __forbidden_info_complete { 0 }
 976 sub __forbidden_hash_swap  { shift->stash }
 977 sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
 978
 979 ### A step that is used by the default handle_error
 980 sub __error_info_complete { 0 }
 981 sub __error_hash_swap  { shift->stash }
 982 sub __error_file_print { \ "<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
 983
 984 1;
 985
 986 ### See the perldoc in CGI/Ex/App.pod