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