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