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