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

   1 package CGI::Ex::App;
   2
   3 ###----------------------------------------------------------------###
   4 #  See the perldoc in CGI/Ex/App.pod
   5 #  Copyright 2007 - Paul Seamons                                     #
   6 #  Distributed under the Perl Artistic License without warranty      #
   7 ###----------------------------------------------------------------###
   8
   9 use strict;
  10 use vars qw($VERSION);
  11
  12 BEGIN {
  13     $VERSION = '2.17';
  14
  15     Time::HiRes->import('time') if eval {require Time::HiRes};
  16     eval {require Scalar::Util};
  17 }
  18
  19 sub croak {
  20     my $msg = shift;
  21     $msg = 'Something happened' if ! defined $msg;
  22     die $msg if ref $msg || $msg =~ /\n\z/;
  23     my ($pkg, $file, $line, $sub) = caller(1);
  24     die "$msg in ${sub}() at $file line $line\n";
  25 }
  26
  27 ###----------------------------------------------------------------###
  28
  29 sub new {
  30     my $class = shift || croak "Usage: Package->new";
  31     my $self  = shift || {};
  32     bless $self, $class;
  33
  34     $self->init;
  35
  36     $self->init_from_conf;
  37
  38     return $self;
  39 }
  40
  41 sub init {}
  42
  43 sub destroy {}
  44
  45 ###----------------------------------------------------------------###
  46
  47 sub init_from_conf {
  48     my $self = shift;
  49     return if ! $self->load_conf;
  50     my $conf = $self->conf;
  51     @{ $self }{ keys %$conf } = values %$conf;
  52     return;
  53 }
  54
  55 sub load_conf { shift->{'load_conf'} ||= @_ ? 1 : 0 }
  56
  57 sub conf {
  58     my $self = shift;
  59     return $self->{'conf'} ||= do {
  60         my $conf = $self->conf_obj->read($self->conf_file, {no_warn_on_fail => 1}) || croak $@;
  61         my $hash = $self->conf_validation;
  62         if ($hash && scalar keys %$hash) {
  63             my $err_obj = $self->vob->validate($conf, $hash);
  64             die $err_obj if $err_obj;
  65         }
  66         $conf;
  67     }
  68 }
  69
  70 sub conf_path {
  71     my $self = shift;
  72     return $self->{'conf_path'} || $self->base_dir_abs;
  73 }
  74
  75 sub conf_file {
  76     my $self = shift;
  77     return $self->{'conf_file'} ||= do {
  78         my $module = $self->name_module || croak 'Missing name_module during conf_file call';
  79         $module .'.'. $self->conf_ext;
  80     };
  81 }
  82
  83 sub conf_ext {
  84     my $self = shift;
  85     $self->{'conf_ext'} = shift if @_ == 1;
  86     return $self->{'conf_ext'} || 'pl';
  87 }
  88
  89 sub conf_args { shift->{'conf_args'} || {} }
  90
  91 sub conf_obj {
  92     my $self = shift;
  93     return $self->{'conf_obj'} || do {
  94         my $args = $self->conf_args;
  95         $args->{'paths'}     ||= $self->conf_path;
  96         $args->{'directive'} ||= 'MERGE';
  97         require CGI::Ex::Conf;
  98         CGI::Ex::Conf->new($args);
  99     };
 100 }
 101
 102 sub conf_validation {}
 103
 104 ###----------------------------------------------------------------###
 105
 106 sub navigate {
 107     my ($self, $args) = @_;
 108     $self = $self->new($args) if ! ref $self;
 109
 110     $self->{'_time'} = time;
 111
 112     eval {
 113         ### a chance to do things at the very beginning
 114         return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
 115
 116         ### run the step loop
 117         eval {
 118             local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
 119             $self->nav_loop;
 120         };
 121         if ($@) {
 122             ### rethrow the error unless we long jumped out of recursive nav_loop calls
 123             croak $@ if $@ ne "Long Jump\n";
 124         }
 125
 126         ### one chance to do things at the very end
 127         $self->post_navigate if ! $self->{'_no_post_navigate'};
 128
 129
 130     };
 131     $self->handle_error($@) if $@; # catch any errors
 132
 133     $self->{'_time'} = time;
 134
 135     $self->destroy;
 136
 137     return $self;
 138 }
 139
 140 sub nav_loop {
 141     my $self = shift;
 142
 143     ### keep from an infinate nesting
 144     local $self->{'_recurse'} = $self->{'_recurse'} || 0;
 145     if ($self->{'_recurse'}++ >= $self->recurse_limit) {
 146         my $err = "recurse_limit (".$self->recurse_limit.") reached";
 147         $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
 148         croak $err;
 149     }
 150
 151     my $path = $self->path;
 152
 153     ### allow for an early return
 154     return if $self->pre_loop($path); # a true value means to abort the navigate
 155
 156     ### iterate on each step of the path
 157     foreach ($self->{'path_i'} ||= 0;
 158              $self->{'path_i'} <= $#$path;
 159              $self->{'path_i'} ++) {
 160         my $step = $path->[$self->{'path_i'}];
 161         if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
 162             $self->stash->{'forbidden_step'} = $step;
 163             $self->replace_path($self->forbidden_step);
 164             next;
 165         }
 166         $step = $1; # untaint
 167
 168         ### allow for per-step authentication
 169         if (! $self->is_authed) {
 170             my $req = $self->run_hook('require_auth', $step, 1);
 171             if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
 172                 return if ! $self->get_valid_auth;
 173             }
 174         }
 175
 176         ### allow for becoming another package (allows for some steps in external files)
 177         $self->morph($step);
 178
 179         ### allow for mapping path_info pieces to form elements
 180         if (my $info = $self->path_info) {
 181             my $maps = $self->run_hook('path_info_map', $step) || [];
 182             croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }'
 183                 if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
 184             foreach my $map (@$maps) {
 185                 my @match = $info =~ $map->[0];
 186                 next if ! @match;
 187                 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
 188                 last;
 189             }
 190         }
 191
 192         ### run the guts of the step
 193         my $handled = $self->run_hook('run_step', $step);
 194
 195         ### Allow for the run_step to intercept.
 196         ### A true status means the run_step took over navigation.
 197         if ($handled) {
 198             $self->unmorph($step);
 199             return;
 200         }
 201
 202         ### if there are no future steps - allow for this step to designate one to follow
 203         my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
 204         $self->run_hook('refine_path', $step, $is_at_end);
 205
 206         $self->unmorph($step);
 207     }
 208
 209     ### allow for one exit point after the loop
 210     return if $self->post_loop($path); # a true value means to abort the navigate
 211
 212     ### run the default step as a last resort
 213     $self->insert_path($self->default_step);
 214     $self->nav_loop; # go recursive
 215
 216     return;
 217 }
 218
 219 sub pre_navigate { 0 }  # true means to not enter nav_loop
 220
 221 sub post_navigate {}
 222
 223 sub pre_loop  { 0 } # true value means to abort the nav_loop routine
 224
 225 sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
 226
 227 sub recurse_limit { shift->{'recurse_limit'} || 15 }
 228
 229 ### default die handler - show what happened and die (so its in the error logs)
 230 sub handle_error {
 231   my $self = shift;
 232   my $err  = shift;
 233
 234   die $err if $self->{'_handling_error'};
 235   local $self->{'_handling_error'} = 1;
 236   local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error
 237
 238   $self->stash->{'error_step'} = $self->current_step;
 239   $self->stash->{'error'}      = $err;
 240   $self->replace_path($self->error_step);
 241   $self->jump; # exits nav loop when finished
 242 }
 243
 244 ###----------------------------------------------------------------###
 245
 246 sub default_step   { shift->{'default_step'}   || 'main'    }
 247 sub js_step        { shift->{'js_step'}        || 'js'      }
 248 sub login_step     { shift->{'login_step'}     || '__login' }
 249 sub error_step     { shift->{'error_step'}     || '__error' }
 250 sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
 251
 252 sub step_key { shift->{'step_key'} || 'step' }
 253
 254 sub path {
 255     my $self = shift;
 256     if (! $self->{'path'}) {
 257         my $path = $self->{'path'} = []; # empty path
 258
 259         ### add initial items to the form hash from path_info5B
 260         if (my $info = $self->path_info) {
 261             my $maps = $self->path_info_map_base || [];
 262             croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }'
 263                 if ! UNIVERSAL::isa($maps, 'ARRAY') || (@$maps && ! UNIVERSAL::isa($maps->[0], 'ARRAY'));
 264             foreach my $map (@$maps) {
 265                 my @match = $info =~ $map->[0];
 266                 next if ! @match;
 267                 $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map;
 268                 last;
 269             }
 270         }
 271
 272         ### make sure the step is valid
 273         my $step = $self->form->{$self->step_key};
 274         if (defined $step) {
 275             if ($step =~ /^_/) {         # can't begin with _
 276                 $self->stash->{'forbidden_step'} = $step;
 277                 push @$path, $self->forbidden_step;
 278             } elsif ($self->valid_steps  # must be in valid_steps if defined
 279                 && ! $self->valid_steps->{$step}
 280                 && $step ne $self->default_step
 281                 && $step ne $self->js_step) {
 282                 $self->stash->{'forbidden_step'} = $step;
 283                 push @$path, $self->forbidden_step;
 284             } else {
 285                 push @$path, $step;
 286             }
 287         }
 288     }
 289
 290     return $self->{'path'};
 291 }
 292
 293 sub path_info_map_base {
 294     my $self = shift;
 295     return [[qr{/(\w+)}, $self->step_key]];
 296 }
 297
 298 sub set_path {
 299     my $self = shift;
 300     my $path = $self->{'path'} ||= [];
 301     croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
 302     splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
 303 }
 304
 305 ### legacy - same as append_path
 306 sub add_to_path {
 307     my $self = shift;
 308     push @{ $self->path }, @_;
 309 }
 310
 311 sub append_path {
 312     my $self = shift;
 313     push @{ $self->path }, @_;
 314 }
 315
 316 sub replace_path {
 317     my $self = shift;
 318     my $ref  = $self->path;
 319     my $i    = $self->{'path_i'} || 0;
 320     if ($i + 1 > $#$ref) {
 321         push @$ref, @_;
 322     } else {
 323         splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries
 324     }
 325 }
 326
 327 sub insert_path {
 328     my $self = shift;
 329     my $ref  = $self->path;
 330     my $i    = $self->{'path_i'} || 0;
 331     if ($i + 1 > $#$ref) {
 332         push @$ref, @_;
 333     } else {
 334         splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
 335     }
 336 }
 337
 338 ### a hash of paths that are allowed, default undef is all are allowed
 339 sub valid_steps {}
 340
 341 ###----------------------------------------------------------------###
 342 ### allow for checking where we are in the path and for jumping around
 343
 344 sub exit_nav_loop {
 345     my $self = shift;
 346
 347     ### undo morphs
 348     if (my $ref = $self->{'_morph_lineage'}) {
 349         ### use the saved index - this allows for early "morphers" to only get rolled back so far
 350         my $index = $self->{'_morph_lineage_start_index'};
 351         $index = -1 if ! defined $index;
 352         $self->unmorph while $#$ref != $index;
 353     }
 354
 355     ### long jump back
 356     die "Long Jump\n";
 357 }
 358
 359 sub jump {
 360     my $self   = shift;
 361     my $i      = @_ == 1 ? shift : 1;
 362     my $path   = $self->path;
 363     my $path_i = $self->{'path_i'};
 364     croak "Can't jump if nav_loop not started" if ! defined $path_i;
 365
 366     ### validate where we are jumping to
 367     if ($i =~ /^\w+$/) {
 368         if ($i eq 'FIRST') {
 369             $i = - $path_i - 1;
 370         } elsif ($i eq 'LAST') {
 371             $i = $#$path - $path_i;
 372         } elsif ($i eq 'NEXT') {
 373             $i = 1;
 374         } elsif ($i eq 'CURRENT') {
 375             $i = 0;
 376         } elsif ($i eq 'PREVIOUS') {
 377             $i = -1;
 378         } else { # look for a step by that name
 379             for (my $j = $#$path; $j >= 0; $j --) {
 380                 if ($path->[$j] eq $i) {
 381                     $i = $j - $path_i;
 382                     last;
 383                 }
 384             }
 385         }
 386     }
 387     if ($i !~ /^-?\d+$/) {
 388         require Carp;
 389         Carp::croak("Invalid jump index ($i)");
 390     }
 391
 392     ### manipulate the path to contain the new jump location
 393     my @replace;
 394     my $cut_i  = $path_i + $i;
 395     if ($cut_i > $#$path) {
 396         push @replace, $self->default_step;
 397     } elsif ($cut_i < 0) {
 398         push @replace, @$path;
 399     } else {
 400         push @replace, @$path[$cut_i .. $#$path];
 401     }
 402     $self->replace_path(@replace);
 403
 404     ### record the number of jumps
 405     $self->{'jumps'} ||= 0;
 406     $self->{'jumps'} ++;
 407
 408     ### run the newly fixed up path (recursively)
 409     $self->{'path_i'} ++; # move along now that the path is updated
 410     $self->nav_loop;
 411     $self->exit_nav_loop;
 412 }
 413
 414 sub step_by_path_index {
 415     my $self = shift;
 416     my $i    = shift || 0;
 417     my $ref  = $self->path;
 418     return '' if $i < 0;
 419     return $self->default_step if $i > $#$ref;
 420     return $ref->[$i];
 421 }
 422
 423 sub previous_step {
 424     my $self = shift;
 425     return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
 426 }
 427
 428 sub current_step {
 429     my $self = shift;
 430     return $self->step_by_path_index( ($self->{'path_i'} || 0) );
 431 }
 432
 433 sub next_step { # method and hook
 434     my $self = shift;
 435     return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
 436 }
 437
 438 sub last_step {
 439     my $self = shift;
 440     return $self->step_by_path_index( $#{ $self->path } );
 441 }
 442
 443 sub first_step {
 444     my $self = shift;
 445     return $self->step_by_path_index( 0 );
 446 }
 447
 448 ###----------------------------------------------------------------###
 449 ### hooks and history
 450
 451 sub find_hook {
 452     my $self    = shift;
 453     my $hook    = shift || do { require Carp; Carp::confess("Missing hook name") };
 454     my $step    = shift || '';
 455     my $code;
 456     if ($step && ($code = $self->can("${step}_${hook}"))) {
 457         return [$code, "${step}_${hook}"],
 458
 459     } elsif ($code = $self->can($hook)) {
 460         return [$code, $hook];
 461
 462     } else {
 463         return [];
 464
 465     }
 466 }
 467
 468 sub run_hook {
 469     my $self    = shift;
 470     my $hook    = shift;
 471     my $step    = shift;
 472
 473     my ($code, $found) = @{ $self->find_hook($hook, $step) };
 474     if (! $code) {
 475         croak "Could not find a method named ${step}_${hook} or ${hook}";
 476     } elsif (! UNIVERSAL::isa($code, 'CODE')) {
 477         croak "Value for $hook ($found) is not a code ref ($code)";
 478     }
 479
 480     ### record history
 481     my $hist = {
 482         step  => $step,
 483         meth  => $hook,
 484         found => $found,
 485         time  => time,
 486     };
 487
 488     push @{ $self->history }, $hist;
 489
 490     $hist->{'level'} = $self->{'_level'};
 491     local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
 492
 493     $hist->{'elapsed'}  = time - $hist->{'time'};
 494
 495     my $resp = $self->$code($step, @_);
 496
 497     $hist->{'elapsed'}  = time - $hist->{'time'};
 498     $hist->{'response'} = $resp;
 499
 500     return $resp;
 501 }
 502
 503 sub history {
 504   return shift->{'history'} ||= [];
 505 }
 506
 507 sub dump_history {
 508     my $self = shift;
 509     my $all  = shift || 0;
 510     my $hist = $self->history;
 511     my $dump = [];
 512     push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
 513
 514     ### show terse - yet informative info
 515     foreach my $row (@$hist) {
 516         if (! ref($row)
 517             || ref($row) ne 'HASH'
 518             || ! exists $row->{'elapsed'}) {
 519             push @$dump, $row;
 520         } else {
 521             my $note = ('    ' x ($row->{'level'} || 0))
 522                 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
 523             my $resp = $row->{'response'};
 524             if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
 525                 $note .= ' - {}';
 526             } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
 527                 $note .= ' - []';
 528             } elsif (! defined $resp) {
 529                 $note .= ' - undef';
 530             } elsif (! ref $resp || ! $all) {
 531                 my $max = $self->{'history_max'} || 30;
 532                 if (length($resp) > $max) {
 533                     $resp = substr($resp, 0, $max);
 534                     $resp =~ s/\n.+//s;
 535                     $resp = "$resp ...";
 536                 }
 537                 $note .= " - $resp";
 538             } else {
 539                 $note = [$note, $resp];
 540             }
 541
 542             push @$dump, $note;
 543         }
 544     }
 545
 546     return $dump;
 547 }
 548
 549 ###----------------------------------------------------------------###
 550 ### utility methods to allow for storing separate steps in other modules
 551
 552 sub allow_morph {
 553   my $self = shift;
 554   return $self->{'allow_morph'} ? 1 : 0;
 555 }
 556
 557 sub allow_nested_morph {
 558   my $self = shift;
 559   return $self->{'allow_nested_morph'} ? 1 : 0;
 560 }
 561
 562 sub morph {
 563     my $self  = shift;
 564     my $step  = shift || return;
 565     my $allow = $self->allow_morph($step) || return;
 566
 567     ### place to store the lineage
 568     my $lin = $self->{'_morph_lineage'} ||= [];
 569     my $cur = ref $self; # what are we currently
 570     push @$lin, $cur;    # store so subsequent unmorph calls can do the right thing
 571
 572     my $hist = {
 573         step  => $step,
 574         meth  => 'morph',
 575         found => 'morph',
 576         time  => time,
 577         elapsed  => 0,
 578         response => 0
 579     };
 580     push @{ $self->history }, $hist;
 581
 582     if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
 583         $hist->{'found'} .= " (not allowed to morph to that step)";
 584         return 0;
 585     }
 586
 587     ### make sure we haven't already been reblessed
 588     if ($#$lin != 0                                       # is this the second morph call
 589         && (! ($allow = $self->allow_nested_morph($step)) # not true
 590             || (ref($allow) && ! $allow->{$step})         # hash - but no step
 591             )) {
 592         $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
 593         return 0; # just return - don't die so that we can morph early
 594     }
 595
 596     ### if we are not already that package - bless us there
 597     my $new = $self->run_hook('morph_package', $step);
 598     if ($cur ne $new) {
 599         my $file = $new .'.pm';
 600         $file =~ s|::|/|g;
 601         if (UNIVERSAL::can($new, 'can')  # check if the package space exists
 602             || eval { require $file }) { # check for a file that holds this package
 603             ### become that package
 604             bless $self, $new;
 605             $hist->{'found'} .= " (changed $cur to $new)";
 606             $self->fixup_after_morph($step);
 607         } else {
 608             if ($@) {
 609                 if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
 610                     $hist->{'found'} .= " (failed from $cur to $new: $1)";
 611                 } else {
 612                     $hist->{'found'} .= " (failed from $cur to $new: $@)";
 613                     my $err = "Trouble while morphing to $file: $@";
 614                     warn $err;
 615                 }
 616             }
 617         }
 618     }
 619
 620     $hist->{'response'} = 1;
 621     return 1;
 622 }
 623
 624 sub unmorph {
 625     my $self = shift;
 626     my $step = shift || '_no_step';
 627     my $lin  = $self->{'_morph_lineage'} || return;
 628     my $cur  = ref $self;
 629
 630     my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
 631     delete $self->{'_morph_lineage'} if ! @$lin;
 632
 633     ### if we are not already that package - bless us there
 634     my $hist = {
 635         step  => $step,
 636         meth  => 'unmorph',
 637         found => 'unmorph',
 638         time  => time,
 639         elapsed  => 0,
 640         response => 0,
 641     };
 642     push @{ $self->history }, $hist;
 643
 644     if ($cur ne $prev) {
 645         $self->fixup_before_unmorph($step);
 646         bless $self, $prev;
 647         $hist->{'found'} .= " (changed from $cur to $prev)";
 648     } else {
 649         $hist->{'found'} .= " (already isa $cur)";
 650     }
 651
 652     $hist->{'response'} = 1;
 653     return $self;
 654 }
 655
 656 sub fixup_after_morph {}
 657
 658 sub fixup_before_unmorph {}
 659
 660 ###----------------------------------------------------------------###
 661 ### allow for authentication
 662
 663 sub navigate_authenticated {
 664     my ($self, $args) = @_;
 665     $self = $self->new($args) if ! ref $self;
 666
 667     if ($self->can('require_auth') != \&CGI::Ex::App::require_auth) {
 668         require Carp;
 669         Carp::croak("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting");
 670     }
 671     $self->require_auth(1);
 672
 673     return $self->navigate;
 674 }
 675
 676 sub require_auth {
 677     my $self = shift;
 678     $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
 679     return $self->{'require_auth'} || 0;
 680 }
 681
 682 sub is_authed { shift->auth_data }
 683
 684 sub auth_data {
 685     my $self = shift;
 686     $self->{'auth_data'} = shift if @_ == 1;
 687     return $self->{'auth_data'};
 688 }
 689
 690 sub get_valid_auth {
 691     my $self = shift;
 692     return 1 if $self->is_authed;
 693
 694     my $args = $self->auth_args;
 695
 696     ### allow passed in args
 697     if (my $extra = shift) {
 698         $args = {%$args, %$extra};
 699     }
 700
 701     ### augment the args with sensible defaults
 702     $args->{'script_name'}      ||= $self->script_name;
 703     $args->{'path_info'}        ||= $self->path_info;
 704     $args->{'cgix'}             ||= $self->cgix;
 705     $args->{'form'}             ||= $self->form;
 706     $args->{'cookies'}          ||= $self->cookies;
 707     $args->{'js_uri_path'}      ||= $self->js_uri_path;
 708     $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
 709     $args->{'verify_user'}      ||= sub { my ($auth, $user) = @_; $self->verify_user(     $user, $auth) };
 710     $args->{'cleanup_user'}     ||= sub { my ($auth, $user) = @_; $self->cleanup_user(    $user, $auth) };
 711     $args->{'login_print'}      ||= sub {
 712         my ($auth, $template, $hash) = @_;
 713         my $step = $self->login_step;
 714         my $hash_base = $self->run_hook('hash_base',   $step) || {};
 715         my $hash_comm = $self->run_hook('hash_common', $step) || {};
 716         my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
 717         my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
 718
 719         my $out = $self->run_hook('swap_template', $step, $template, $swap);
 720         $self->run_hook('fill_template', $step, \$out, $hash);
 721         $self->run_hook('print_out', $step, \$out);
 722     };
 723
 724     require CGI::Ex::Auth;
 725     my $obj = CGI::Ex::Auth->new($args);
 726     my $resp = $obj->get_valid_auth;
 727
 728     my $data = $obj->last_auth_data;
 729     delete $data->{'real_pass'} if defined $data; # data may be defined but false
 730     $self->auth_data($data); # failed authentication may still have auth_data
 731
 732     return ($resp && $data) ? 1 : 0;
 733 }
 734
 735 sub auth_args { {} }
 736
 737 sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
 738 sub cleanup_user { my ($self, $user) = @_; $user }
 739 sub verify_user  { 1 }
 740
 741 ###----------------------------------------------------------------###
 742 ### a few standard base accessors
 743
 744 sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
 745
 746 sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
 747
 748 sub cgix {
 749     my $self = shift;
 750     $self->{'cgix'} = shift if @_ == 1;
 751     return $self->{'cgix'} ||= do {
 752         require CGI::Ex;
 753         CGI::Ex->new; # return of the do
 754     };
 755 }
 756
 757 sub form {
 758     my $self = shift;
 759     $self->{'form'} = shift if @_ == 1;
 760     return $self->{'form'} ||= $self->cgix->get_form;
 761 }
 762
 763 sub cookies {
 764     my $self = shift;
 765     $self->{'cookies'} = shift if @_ == 1;
 766     return $self->{'cookies'} ||= $self->cgix->get_cookies;
 767 }
 768
 769 sub vob {
 770     my $self = shift;
 771     $self->{'vob'} = shift if @_ == 1;
 772     return $self->{'vob'} ||= do {
 773         require CGI::Ex::Validate;
 774         my $args = $self->vob_args;
 775         $args->{'cgix'} ||= $self->cgix;
 776         CGI::Ex::Validate->new($self->vob_args); # return of the do
 777     };
 778 }
 779
 780 sub vob_args { shift->{'vob_args'} || {} }
 781
 782 sub vob_path {
 783     my $self = shift;
 784     return $self->{'vob_path'} || $self->template_path;
 785 }
 786
 787 ### provide a place for placing variables
 788 sub stash {
 789     my $self = shift;
 790     return $self->{'stash'} ||= {};
 791 }
 792
 793 sub clear_app {
 794     my $self = shift;
 795
 796     delete @{ $self }{qw(
 797         cgix
 798         vob
 799         form
 800         cookies
 801         stash
 802         path
 803         path_i
 804         history
 805         _morph_lineage_start_index
 806         _morph_lineage
 807         hash_errors
 808         hash_fill
 809         hash_swap
 810         hash_common
 811     )};
 812
 813     return $self;
 814 }
 815
 816 ###----------------------------------------------------------------###
 817 ### default hook implementations
 818
 819 sub path_info_map { }
 820
 821 sub run_step {
 822     my $self = shift;
 823     my $step = shift;
 824
 825     ### if the pre_step exists and returns true, exit the nav_loop
 826     return 1 if $self->run_hook('pre_step', $step);
 827
 828     ### allow for skipping this step (but stay in the nav_loop)
 829     return 0 if $self->run_hook('skip', $step);
 830
 831     ### see if we have complete valid information for this step
 832     ### if so, do the next step
 833     ### if not, get necessary info and print it out
 834     if (   ! $self->run_hook('prepare', $step)
 835         || ! $self->run_hook('info_complete', $step)
 836         || ! $self->run_hook('finalize', $step)) {
 837
 838         ### show the page requesting the information
 839         $self->run_hook('prepared_print', $step);
 840
 841         ### a hook after the printing process
 842         $self->run_hook('post_print', $step);
 843
 844         return 1;
 845     }
 846
 847     ### a hook before end of loop
 848     ### if the post_step exists and returns true, exit the nav_loop
 849     return 1 if $self->run_hook('post_step', $step);
 850
 851     ### let the nav_loop continue searching the path
 852     return 0;
 853 }
 854
 855 sub refine_path {
 856     my ($self, $step, $is_at_end) = @_;
 857     return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
 858
 859     my $next_step = $self->run_hook('next_step', $step) || return 0;
 860     $self->run_hook('set_ready_validate', $step, 0);
 861     $self->append_path($next_step);
 862     return 1;
 863 }
 864
 865 sub prepared_print {
 866     my $self = shift;
 867     my $step = shift;
 868
 869     my $hash_base = $self->run_hook('hash_base',   $step) || {};
 870     my $hash_comm = $self->run_hook('hash_common', $step) || {};
 871     my $hash_form = $self->run_hook('hash_form',   $step) || {};
 872     my $hash_fill = $self->run_hook('hash_fill',   $step) || {};
 873     my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
 874     my $hash_errs = $self->run_hook('hash_errors', $step) || {};
 875
 876     ### fix up errors
 877     $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
 878         foreach keys %$hash_errs;
 879     $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
 880
 881     ### layer hashes together
 882     my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
 883     my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
 884
 885     ### run the print hook - passing it the form and fill info
 886     $self->run_hook('print', $step, $swap, $fill);
 887 }
 888
 889 sub print {
 890     my ($self, $step, $swap, $fill) = @_;
 891     my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
 892     my $out  = $self->run_hook('swap_template', $step, $file, $swap);
 893     $self->run_hook('fill_template', $step, \$out, $fill);
 894     $self->run_hook('print_out',     $step, \$out);
 895 }
 896
 897 sub print_out {
 898     my ($self, $step, $out) = @_;
 899
 900     $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
 901     print ref($out) eq 'SCALAR' ? $$out : $out;
 902 }
 903
 904 sub mimetype { shift->{'mimetype'} || 'text/html' }
 905 sub charset  { shift->{'charset'}  || '' }
 906
 907 sub swap_template {
 908     my ($self, $step, $file, $swap) = @_;
 909
 910     my $args = $self->run_hook('template_args', $step);
 911     $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
 912
 913     my $t = $self->template_obj($args);
 914     my $out = '';
 915     $t->process($file, $swap, \$out) || die $t->error;
 916
 917     return $out;
 918 }
 919
 920 sub template_path {
 921     my $self = shift;
 922     return $self->{'template_path'} || $self->base_dir_abs;
 923 }
 924
 925 sub template_args { shift->{'template_args'} || {} }
 926
 927 sub template_obj {
 928     my ($self, $args) = @_;
 929
 930     require CGI::Ex::Template;
 931     my $t = CGI::Ex::Template->new($args);
 932 }
 933
 934 sub fill_template {
 935     my ($self, $step, $outref, $fill) = @_;
 936
 937     return if ! $fill;
 938
 939     my $args = $self->run_hook('fill_args', $step);
 940     local $args->{'text'} = $outref;
 941     local $args->{'form'} = $fill;
 942
 943     require CGI::Ex::Fill;
 944     CGI::Ex::Fill::fill($args);
 945 }
 946
 947 sub fill_args { shift->{'fill_args'} || {} }
 948
 949 sub pre_step   { 0 } # success indicates we handled step (don't continue step or loop)
 950 sub skip       { 0 } # success indicates to skip the step (and continue loop)
 951 sub prepare    { 1 } # failure means show step
 952 sub finalize   { 1 } # failure means show step
 953 sub post_print { 0 }
 954 sub post_step  { 0 } # success indicates we handled step (don't continue step or loop)
 955
 956 sub morph_package {
 957     my $self = shift;
 958     my $step = shift || '';
 959     my $cur = ref $self; # default to using self as the base for morphed modules
 960     my $new = $cur .'::'. $step;
 961     $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
 962     return $new;
 963 }
 964
 965 sub name_module {
 966     my $self = shift;
 967     my $step = shift || '';
 968
 969     return $self->{'name_module'} ||= do {
 970         # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
 971         my $script = $self->script_name;
 972         $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
 973         $1; # return of the do
 974     };
 975 }
 976
 977 sub name_step {
 978     my ($self, $step) = @_;
 979     return $step;
 980 }
 981
 982 sub file_print {
 983     my $self = shift;
 984     my $step = shift;
 985
 986     my $base_dir = $self->base_dir_rel;
 987     my $module   = $self->run_hook('name_module', $step);
 988     my $_step    = $self->run_hook('name_step', $step) || die "Missing name_step";
 989     $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
 990
 991     foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 992
 993     return $base_dir . $module . $_step;
 994 }
 995
 996 sub file_val {
 997     my $self = shift;
 998     my $step = shift;
 999
1000     ### determine the path to begin looking for files - allow for an arrayref
1001     my $abs = $self->vob_path || [];
1002     $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
1003     $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');
1004     return {} if @$abs == 0;
1005
1006     my $base_dir = $self->base_dir_rel;
1007     my $module   = $self->run_hook('name_module', $step);
1008     my $_step    = $self->run_hook('name_step', $step) || die "Missing name_step";
1009     $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
1010
1011     foreach (@$abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
1012
1013     if (@$abs > 1) {
1014         foreach my $_abs (@$abs) {
1015             my $path = $_abs . $base_dir . $module . $_step;
1016             return $path if -e $path;
1017         }
1018     }
1019
1020     return $abs->[0] . $base_dir . $module . $_step;
1021 }
1022
1023 sub info_complete {
1024     my ($self, $step) = @_;
1025     return 0 if ! $self->run_hook('ready_validate', $step);
1026     return 0 if ! $self->run_hook('validate', $step, $self->form);
1027     return 1;
1028 }
1029
1030 sub ready_validate {
1031     my ($self, $step) = @_;
1032     return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
1033 }
1034
1035 sub set_ready_validate { # hook and method
1036     my $self = shift;
1037     my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
1038     $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
1039     return $is_ready;
1040 }
1041
1042 sub validate {
1043     my ($self, $step, $form) = @_;
1044
1045     my $hash = $self->run_hook('hash_validation', $step);
1046     my $what_was_validated = [];
1047
1048     my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) };
1049     die "Step $step: $@" if $@ && ! $err_obj;
1050
1051     ### had an error - store the errors and return false
1052     if ($err_obj) {
1053         $self->add_errors($err_obj->as_hash({
1054             as_hash_join   => "<br>\n",
1055             as_hash_suffix => '_error',
1056         }));
1057         return 0;
1058     }
1059
1060     ### allow for the validation to give us some redirection
1061     foreach my $ref (@$what_was_validated) {
1062         foreach my $method (qw(append_path replace_path insert_path)) {
1063             next if ! (my $val = $ref->{$method});
1064             $self->$method(ref $val ? @$val : $val);
1065         }
1066     }
1067
1068     return 1;
1069 }
1070
1071 ### creates javascript suitable for validating the form
1072 sub js_validation {
1073     my $self = shift;
1074     my $step = shift;
1075     return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
1076
1077     my $form_name = shift || $self->run_hook('form_name', $step);
1078     my $hash_val  = shift || $self->run_hook('hash_validation', $step);
1079     my $js_uri    = $self->js_uri_path;
1080     return '' if UNIVERSAL::isa($hash_val, 'HASH')  && ! scalar keys %$hash_val
1081         || UNIVERSAL::isa($hash_val, 'ARRAY') && ! @$hash_val;
1082
1083     return $self->vob->generate_js($hash_val, $form_name, $js_uri);
1084 }
1085
1086 sub form_name { 'theform' }
1087
1088 sub hash_validation {
1089   my ($self, $step) = @_;
1090
1091   return $self->{'hash_validation'}->{$step} ||= do {
1092       my $hash;
1093       my $file = $self->run_hook('file_val', $step);
1094
1095       ### allow for returning the validation hash in the filename
1096       ### a scalar ref means it is a yaml document to be read by get_validation
1097       if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
1098           $hash = $file;
1099
1100       ### read the file - if it is not found, errors will be in the webserver logs (all else dies)
1101       } elsif ($file) {
1102           $hash = $self->vob->get_validation($file) || {};
1103
1104       } else {
1105           $hash = {};
1106       }
1107
1108       $hash; # return of the do
1109   };
1110 }
1111
1112 sub hash_base {
1113     my ($self, $step) = @_;
1114
1115     return $self->{'hash_base'} ||= do {
1116         ### create a weak copy of self to use in closures
1117         my $copy = $self;
1118         eval {require Scalar::Util; Scalar::Util::weaken($copy)};
1119         my $hash = {
1120             script_name     => $self->script_name,
1121             path_info       => $self->path_info,
1122             js_validation   => sub { $copy->run_hook('js_validation', $step, shift) },
1123             form_name       => $self->run_hook('form_name', $step),
1124             $self->step_key => $step,
1125         }; # return of the do
1126     };
1127 }
1128
1129 sub hash_common { shift->{'hash_common'} ||= {} }
1130 sub hash_form   { shift->form }
1131 sub hash_fill   { shift->{'hash_fill'}   ||= {} }
1132 sub hash_swap   { shift->{'hash_swap'}   ||= {} }
1133 sub hash_errors { shift->{'hash_errors'} ||= {} }
1134
1135 ###----------------------------------------------------------------###
1136 ### routines to support the base hooks
1137
1138 sub add_errors {
1139     my $self = shift;
1140     my $hash = $self->hash_errors;
1141     my $args = ref($_[0]) ? shift : {@_};
1142     foreach my $key (keys %$args) {
1143         my $_key = ($key =~ /error$/) ? $key : "${key}_error";
1144         if ($hash->{$_key}) {
1145             $hash->{$_key} .= '<br>' . $args->{$key};
1146         } else {
1147             $hash->{$_key} = $args->{$key};
1148         }
1149     }
1150     $hash->{'has_errors'} = 1;
1151 }
1152
1153 sub has_errors { scalar keys %{ shift->hash_errors } }
1154
1155 sub format_error {
1156     my ($self, $error) = @_;
1157     return $error;
1158 }
1159
1160 sub add_to_errors { shift->add_errors(@_) }
1161 sub add_to_swap   { my $self = shift; $self->add_to_hash($self->hash_swap,   @_) }
1162 sub add_to_fill   { my $self = shift; $self->add_to_hash($self->hash_fill,   @_) }
1163 sub add_to_form   { my $self = shift; $self->add_to_hash($self->hash_form,   @_) }
1164 sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
1165 sub add_to_base   { my $self = shift; $self->add_to_hash($self->hash_base,   @_) }
1166
1167 sub add_to_hash {
1168     my $self = shift;
1169     my $old  = shift;
1170     my $new  = shift;
1171     $new = {$new, @_} if ! ref $new; # non-hashref
1172     $old->{$_} = $new->{$_} foreach keys %$new;
1173 }
1174
1175
1176 sub base_dir_rel {
1177     my $self = shift;
1178     $self->{'base_dir_rel'} = shift if @_ == 1;
1179     return $self->{'base_dir_rel'} || '';
1180 }
1181
1182 sub base_dir_abs {
1183     my $self = shift;
1184     $self->{'base_dir_abs'} = shift if @_ == 1;
1185     return $self->{'base_dir_abs'} || ['.']; # default to the current directory
1186 }
1187
1188 sub ext_print {
1189     my $self = shift;
1190     $self->{'ext_print'} = shift if @_ == 1;
1191     return $self->{'ext_print'} || 'html';
1192 }
1193
1194 sub ext_val {
1195     my $self = shift;
1196     $self->{'ext_val'} = shift if @_ == 1;
1197     return $self->{'ext_val'} || 'val';
1198 }
1199
1200 ### where to find the javascript files
1201 ### default to using this script as a handler
1202 sub js_uri_path {
1203     my $self   = shift;
1204     my $script = $self->script_name;
1205     my $js_step = $self->js_step;
1206     return ($self->can('path') == \&CGI::Ex::App::path)
1207         ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
1208         : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
1209 }
1210
1211 ###----------------------------------------------------------------###
1212 ### a simple step that allows for printing javascript libraries that
1213 ### are stored in perls @INC.  Which ever step is in js_step should do something similar.
1214
1215 sub js_run_step {
1216     my $self = shift;
1217
1218     ### make sure path info looks like /js/CGI/Ex/foo.js
1219     my $file = $self->form->{'js'} || $self->path_info;
1220     $file = ($file =~  m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
1221
1222     $self->cgix->print_js($file);
1223     $self->{'_no_post_navigate'} = 1;
1224     return 1;
1225 }
1226
1227 ###----------------------------------------------------------------###
1228 ### a step that will be used if a valid_steps is defined
1229 ### and the current step of the path is not in valid_steps
1230 ### or if the step is a "hidden" step that begins with _
1231 ### or if the step name contains \W
1232
1233 sub __forbidden_info_complete { 0 }
1234
1235 sub __forbidden_hash_swap { shift->stash }
1236
1237 sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
1238
1239 ###----------------------------------------------------------------###
1240 ### a step that is used by the default handle_error
1241
1242 sub __error_info_complete { 0 }
1243
1244 sub __error_hash_swap { shift->stash }
1245
1246 sub __error_file_print { \ "<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
1247
1248 ###----------------------------------------------------------------###
1249
1250 1;
1251
1252 ### See the perldoc in CGI/Ex/App.pod