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