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