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