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.02';
  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     }
 386
 387     ### record history
 388     my $hist = {
 389         step  => $step,
 390         meth  => $hook,
 391         found => $found,
 392         time  => time,
 393     };
 394
 395     push @{ $self->history }, $hist;
 396
 397     $hist->{'level'} = $self->{'_level'};
 398     local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
 399
 400     $hist->{'elapsed'}  = time - $hist->{'time'};
 401
 402     my $resp = $self->$code($step, @_);
 403
 404     $hist->{'elapsed'}  = time - $hist->{'time'};
 405     $hist->{'response'} = $resp;
 406
 407     return $resp;
 408 }
 409
 410 sub history {
 411   return shift->{'history'} ||= [];
 412 }
 413
 414 sub dump_history {
 415     my $self = shift;
 416     my $all  = shift || 0;
 417     my $hist = $self->history;
 418     my $dump = [];
 419     push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
 420
 421     ### show terse - yet informative info
 422     foreach my $row (@$hist) {
 423         if (! ref($row)
 424             || ref($row) ne 'HASH'
 425             || ! exists $row->{'elapsed'}) {
 426             push @$dump, $row;
 427         } else {
 428             my $note = ('    ' x ($row->{'level'} || 0))
 429                 . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
 430             my $resp = $row->{'response'};
 431             if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
 432                 $note .= ' - {}';
 433             } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
 434                 $note .= ' - []';
 435             } elsif (! ref $resp || ! $all) {
 436                 my $max = $self->{'history_max'} || 30;
 437                 if (length($resp) > $max) {
 438                     $resp = substr($resp, 0, $max);
 439                     $resp =~ s/\n.+//s;
 440                     $resp = "$resp ...";
 441                 }
 442                 $note .= " - $resp";
 443             } else {
 444                 $note = [$note, $resp];
 445             }
 446
 447             push @$dump, $note;
 448         }
 449     }
 450
 451     return $dump;
 452 }
 453
 454 ###----------------------------------------------------------------###
 455 ### utility methods to allow for storing separate steps in other modules
 456
 457 sub allow_morph {
 458   my $self = shift;
 459   return $self->{'allow_morph'} ? 1 : 0;
 460 }
 461
 462 sub allow_nested_morph {
 463   my $self = shift;
 464   return $self->{'allow_nested_morph'} ? 1 : 0;
 465 }
 466
 467 sub morph {
 468     my $self  = shift;
 469     my $step  = shift || return;
 470     my $allow = $self->allow_morph($step) || return;
 471
 472     ### place to store the lineage
 473     my $lin = $self->{'__morph_lineage'} ||= [];
 474     my $cur = ref $self; # what are we currently
 475     push @$lin, $cur;    # store so subsequent unmorph calls can do the right thing
 476
 477     my $hist = {
 478         step  => $step,
 479         meth  => 'morph',
 480         found => 'morph',
 481         time  => time,
 482         elapsed  => 0,
 483         response => 0
 484     };
 485     push @{ $self->history }, $hist;
 486
 487     if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
 488         $hist->{'found'} .= " (not allowed to morph to that step)";
 489         return 0;
 490     }
 491
 492     ### make sure we haven't already been reblessed
 493     if ($#$lin != 0                                       # is this the second morph call
 494         && (! ($allow = $self->allow_nested_morph($step)) # not true
 495             || (ref($allow) && ! $allow->{$step})         # hash - but no step
 496             )) {
 497         $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
 498         return 0; # just return - don't die so that we can morph early
 499     }
 500
 501     ### if we are not already that package - bless us there
 502     my $new = $self->run_hook('morph_package', $step);
 503     if ($cur ne $new) {
 504         my $file = $new .'.pm';
 505         $file =~ s|::|/|g;
 506         if (UNIVERSAL::can($new, 'can')  # check if the package space exists
 507             || eval { require $file }) { # check for a file that holds this package
 508             ### become that package
 509             bless $self, $new;
 510             $hist->{'found'} .= " (changed $cur to $new)";
 511             $self->fixup_after_morph($step);
 512         } else {
 513             if ($@) {
 514                 if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
 515                     $hist->{'found'} .= " (failed from $cur to $new: $1)";
 516                 } else {
 517                     $hist->{'found'} .= " (failed from $cur to $new: $@)";
 518                     my $err = "Trouble while morphing to $file: $@";
 519                     warn $err;
 520                 }
 521             }
 522         }
 523     }
 524
 525     $hist->{'response'} = 1;
 526     return 1;
 527 }
 528
 529 sub unmorph {
 530     my $self = shift;
 531     my $step = shift || '__no_step';
 532     my $lin  = $self->{'__morph_lineage'} || return;
 533     my $cur  = ref $self;
 534
 535     my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
 536     delete $self->{'__morph_lineage'} if ! @$lin;
 537
 538     ### if we are not already that package - bless us there
 539     my $hist = {
 540         step  => $step,
 541         meth  => 'unmorph',
 542         found => 'unmorph',
 543         time  => time,
 544         elapsed  => 0,
 545         response => 0,
 546     };
 547     push @{ $self->history }, $hist;
 548
 549     if ($cur ne $prev) {
 550         $self->fixup_before_unmorph($step);
 551         bless $self, $prev;
 552         $hist->{'found'} .= " (changed from $cur to $prev)";
 553     } else {
 554         $hist->{'found'} .= " (already isa $cur)";
 555     }
 556
 557     $hist->{'response'} = 1;
 558     return $self;
 559 }
 560
 561 sub fixup_after_morph {}
 562
 563 sub fixup_before_unmorph {}
 564
 565 ###----------------------------------------------------------------###
 566 ### allow for authentication
 567
 568 sub navigate_authenticated {
 569     my ($self, $args) = @_;
 570     $self = $self->new($args) if ! ref $self;
 571
 572     $self->require_auth(1);
 573
 574     return $self->navigate;
 575 }
 576
 577 sub require_auth {
 578     my $self = shift;
 579     $self->{'require_auth'} = shift if @_ == 1;
 580     return $self->{'require_auth'};
 581 }
 582
 583 sub is_authed { shift->auth_data }
 584
 585 sub auth_data {
 586     my $self = shift;
 587     $self->{'auth_data'} = shift if @_ == 1;
 588     return $self->{'auth_data'};
 589 }
 590
 591 sub get_valid_auth {
 592     my $self = shift;
 593     return 1 if $self->is_authed;
 594
 595     ### augment the args with sensible defaults
 596     my $args = $self->auth_args;
 597     $args->{'cgix'}             ||= $self->cgix;
 598     $args->{'form'}             ||= $self->form;
 599     $args->{'cookies'}          ||= $self->cookies;
 600     $args->{'js_uri_path'}      ||= $self->js_uri_path;
 601     $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
 602     $args->{'verify_user'}      ||= sub { my ($auth, $user) = @_; $self->verify_user(     $user, $auth) };
 603     $args->{'cleanup_user'}     ||= sub { my ($auth, $user) = @_; $self->cleanup_user(    $user, $auth) };
 604     $args->{'login_print'}      ||= sub {
 605         my ($auth, $template, $hash) = @_;
 606         my $out = $self->run_hook('swap_template', '__login', $template, $hash);
 607         $self->run_hook('fill_template', '__login', \$out, $hash);
 608         $self->run_hook('print_out', '__login', $out);
 609     };
 610
 611     require CGI::Ex::Auth;
 612     my $obj = CGI::Ex::Auth->new($args);
 613     my $resp = $obj->get_valid_auth;
 614
 615     my $data = $obj->last_auth_data;
 616     delete $data->{'real_pass'} if defined $data; # data may be defined but false
 617     $self->auth_data($data); # failed authentication may still have auth_data
 618
 619     return ($resp && $data) ? 1 : 0;
 620 }
 621
 622 sub auth_args { {} }
 623
 624 sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
 625 sub cleanup_user { my ($self, $user) = @_; $user }
 626 sub verify_user  { 1 }
 627
 628 ###----------------------------------------------------------------###
 629 ### a few standard base accessors
 630
 631 sub form {
 632     my $self = shift;
 633     $self->{'form'} = shift if @_ == 1;
 634     return $self->{'form'} ||= $self->cgix->get_form;
 635 }
 636
 637 sub cookies {
 638     my $self = shift;
 639     $self->{'cookies'} = shift if @_ == 1;
 640     return $self->{'cookies'} ||= $self->cgix->get_cookies;
 641 }
 642
 643 sub cgix {
 644     my $self = shift;
 645     $self->{'cgix'} = shift if @_ == 1;
 646     return $self->{'cgix'} ||= do {
 647         require CGI::Ex;
 648         CGI::Ex->new; # return of the do
 649     };
 650 }
 651
 652 sub vob {
 653     my $self = shift;
 654     $self->{'vob'} = shift if @_ == 1;
 655     return $self->{'vob'} ||= do {
 656         require CGI::Ex::Validate;
 657         CGI::Ex::Validate->new($self->vob_args); # return of the do
 658     };
 659 }
 660
 661 sub vob_args {
 662     my $self = shift;
 663     return {
 664         cgix    => $self->cgix,
 665     };
 666 }
 667
 668 ### provide a place for placing variables
 669 sub stash {
 670     my $self = shift;
 671     return $self->{'stash'} ||= {};
 672 }
 673
 674 ###----------------------------------------------------------------###
 675 ### default hook implementations
 676
 677 sub run_step {
 678     my $self = shift;
 679     my $step = shift;
 680
 681     ### if the pre_step exists and returns true, exit the nav_loop
 682     return 1 if $self->run_hook('pre_step', $step);
 683
 684     ### allow for skipping this step (but stay in the nav_loop)
 685     return 0 if $self->run_hook('skip', $step);
 686
 687     ### see if we have complete valid information for this step
 688     ### if so, do the next step
 689     ### if not, get necessary info and print it out
 690     if (   ! $self->run_hook('prepare', $step)
 691         || ! $self->run_hook('info_complete', $step)
 692         || ! $self->run_hook('finalize', $step)) {
 693
 694         ### show the page requesting the information
 695         $self->run_hook('prepared_print', $step);
 696
 697         ### a hook after the printing process
 698         $self->run_hook('post_print', $step);
 699
 700         return 1;
 701     }
 702
 703     ### a hook before end of loop
 704     ### if the post_step exists and returns true, exit the nav_loop
 705     return 1 if $self->run_hook('post_step', $step);
 706
 707     ### let the nav_loop continue searching the path
 708     return 0;
 709 }
 710
 711 sub refine_path {
 712     my ($self, $step, $is_at_end) = @_;
 713     return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
 714
 715     my $next_step = $self->run_hook('next_step', $step) || return 0;
 716     $self->run_hook('set_ready_validate', $step, 0);
 717     $self->append_path($next_step);
 718     return 1;
 719 }
 720
 721 sub prepared_print {
 722     my $self = shift;
 723     my $step = shift;
 724
 725     my $hash_base = $self->run_hook('hash_base',   $step) || {};
 726     my $hash_comm = $self->run_hook('hash_common', $step) || {};
 727     my $hash_form = $self->run_hook('hash_form',   $step) || {};
 728     my $hash_fill = $self->run_hook('hash_fill',   $step) || {};
 729     my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
 730     my $hash_errs = $self->run_hook('hash_errors', $step) || {};
 731
 732     ### fix up errors
 733     $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
 734         foreach keys %$hash_errs;
 735     $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
 736
 737     ### layer hashes together
 738     my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
 739     my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
 740
 741     ### run the print hook - passing it the form and fill info
 742     $self->run_hook('print', $step, $swap, $fill);
 743 }
 744
 745 sub print {
 746     my ($self, $step, $swap, $fill) = @_;
 747
 748     my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
 749
 750     my $out  = $self->run_hook('swap_template', $step, $file, $swap);
 751
 752     $self->run_hook('fill_template', $step, \$out, $fill);
 753
 754     $self->run_hook('print_out', $step, $out);
 755 }
 756
 757 sub print_out {
 758     my ($self, $step, $out) = @_;
 759
 760     $self->cgix->print_content_type;
 761     print $out;
 762 }
 763
 764 sub swap_template {
 765     my ($self, $step, $file, $swap) = @_;
 766
 767     my $args = $self->run_hook('template_args', $step);
 768     $args->{'INCLUDE_PATH'} ||= sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" };
 769
 770     require CGI::Ex::Template;
 771     my $t = CGI::Ex::Template->new($args);
 772
 773     my $out = '';
 774     $t->process($file, $swap, \$out) || die $t->error;
 775
 776     return $out;
 777 }
 778
 779 sub template_args { {} }
 780
 781 sub fill_template {
 782     my ($self, $step, $outref, $fill) = @_;
 783
 784     return if ! $fill;
 785
 786     my $args = $self->run_hook('fill_args', $step);
 787     local $args->{'text'} = $outref;
 788     local $args->{'form'} = $fill;
 789
 790     require CGI::Ex::Fill;
 791     CGI::Ex::Fill::fill($args);
 792 }
 793
 794 sub fill_args { {} }
 795
 796 sub pre_step   { 0 } # success indicates we handled step (don't continue step or loop)
 797 sub skip       { 0 } # success indicates to skip the step (and continue loop)
 798 sub prepare    { 1 } # failure means show step
 799 sub finalize   { 1 } # failure means show step
 800 sub post_print { 0 } # success indicates we handled step (don't continue loop)
 801 sub post_step  { 0 } # success indicates we handled step (don't continue step or loop)
 802
 803 sub name_step {
 804     my ($self, $step) = @_;
 805     return $step;
 806 }
 807
 808 sub morph_package {
 809     my $self = shift;
 810     my $step = shift || '';
 811     my $cur = ref $self; # default to using self as the base for morphed modules
 812     my $new = $cur .'::'. $step;
 813     $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
 814     return $new;
 815 }
 816
 817 sub name_module {
 818     my $self = shift;
 819     my $step = shift || '';
 820
 821     return $self->{'name_module'} ||= do {
 822         # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
 823         my $script = $ENV{'SCRIPT_NAME'} || $0;
 824         $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
 825         $1; # return of the do
 826     };
 827 }
 828
 829 sub file_print {
 830     my $self = shift;
 831     my $step = shift;
 832
 833     my $base_dir = $self->base_dir_rel;
 834     my $module   = $self->run_hook('name_module', $step);
 835     my $_step    = $self->run_hook('name_step', $step) || die "Missing name_step";
 836     $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
 837
 838     foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 839
 840     return $base_dir . $module . $_step;
 841 }
 842
 843 sub file_val {
 844     my $self = shift;
 845     my $step = shift;
 846
 847     my $abs      = $self->base_dir_abs || return {};
 848     my $base_dir = $self->base_dir_rel;
 849     my $module   = $self->run_hook('name_module', $step);
 850     my $_step    = $self->run_hook('name_step', $step);
 851     $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
 852
 853     foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 854
 855     return $abs . $base_dir . $module . $_step;
 856 }
 857
 858 sub info_complete {
 859     my ($self, $step) = @_;
 860     return 0 if ! $self->run_hook('ready_validate', $step);
 861     return 0 if ! $self->run_hook('validate', $step, $self->form);
 862     return 1;
 863 }
 864
 865 sub ready_validate {
 866     my ($self, $step) = @_;
 867     return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
 868 }
 869
 870 sub set_ready_validate { # hook and method
 871     my $self = shift;
 872     my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
 873     $ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
 874     return $is_ready;
 875 }
 876
 877 sub validate {
 878     my ($self, $step, $form) = @_;
 879
 880     my $hash = $self->run_hook('hash_validation', $step);
 881     my $what_was_validated = [];
 882
 883     my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) };
 884     die "Step $step: $@" if $@ && ! $err_obj;
 885
 886     ### had an error - store the errors and return false
 887     if ($err_obj) {
 888         $self->add_errors($err_obj->as_hash({
 889             as_hash_join   => "<br>\n",
 890             as_hash_suffix => '_error',
 891         }));
 892         return 0;
 893     }
 894
 895     ### allow for the validation to give us some redirection
 896     foreach my $ref (@$what_was_validated) {
 897         foreach my $method (qw(append_path replace_path insert_path)) {
 898             next if ! (my $val = $ref->{$method});
 899             $self->$method(ref $val ? @$val : $val);
 900         }
 901     }
 902
 903     return 1;
 904 }
 905
 906 ### creates javascript suitable for validating the form
 907 sub js_validation {
 908     my $self = shift;
 909     my $step = shift;
 910     return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
 911
 912     my $form_name = shift || $self->run_hook('form_name', $step);
 913     my $hash_val  = shift || $self->run_hook('hash_validation', $step);
 914     my $js_uri    = $self->js_uri_path;
 915     return '' if UNIVERSAL::isa($hash_val, 'HASH')  && ! scalar keys %$hash_val
 916         || UNIVERSAL::isa($hash_val, 'ARRAY') && ! @$hash_val;
 917
 918     return $self->vob->generate_js($hash_val, $form_name, $js_uri);
 919 }
 920
 921 sub form_name { 'theform' }
 922
 923 sub hash_validation {
 924   my ($self, $step) = @_;
 925
 926   return $self->{'hash_validation'}->{$step} ||= do {
 927       my $hash;
 928       my $file = $self->run_hook('file_val', $step);
 929
 930       ### allow for returning the validation hash in the filename
 931       ### a scalar ref means it is a yaml document to be read by get_validation
 932       if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
 933           $hash = $file;
 934
 935       ### read the file - if it is not found, errors will be in the webserver logs (all else dies)
 936       } elsif ($file) {
 937           $hash = $self->vob->get_validation($file) || {};
 938
 939       } else {
 940           $hash = {};
 941       }
 942
 943       $hash; # return of the do
 944   };
 945 }
 946
 947 sub hash_base {
 948     my ($self, $step) = @_;
 949
 950     return $self->{'hash_base'} ||= do {
 951         ### create a weak copy of self to use in closures
 952         my $copy;
 953         if (eval {require Scalar::Util} && defined &Scalar::Util::weaken) {
 954             $copy = $self;
 955             Scalar::Util::weaken($copy);
 956         } else {
 957             $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8)
 958         }
 959
 960         my $hash = {
 961             script_name     => $ENV{'SCRIPT_NAME'} || $0,
 962             path_info       => $ENV{'PATH_INFO'}   || '',
 963             js_validation   => sub { $copy->run_hook('js_validation', $step, shift) },
 964             form_name       => sub { $copy->run_hook('form_name', $step) },
 965             $self->step_key => $step,
 966         }; # return of the do
 967     };
 968 }
 969
 970 sub hash_common { shift->{'hash_common'} ||= {} }
 971 sub hash_form   { shift->form }
 972 sub hash_fill   { shift->{'hash_fill'}   ||= {} }
 973 sub hash_swap   { shift->{'hash_swap'}   ||= {} }
 974 sub hash_errors { shift->{'hash_errors'} ||= {} }
 975
 976 ###----------------------------------------------------------------###
 977 ### routines to support the base hooks
 978
 979 sub add_errors {
 980     my $self = shift;
 981     my $hash = $self->hash_errors;
 982     my $args = ref($_[0]) ? shift : {@_};
 983     foreach my $key (keys %$args) {
 984         my $_key = ($key =~ /error$/) ? $key : "${key}_error";
 985         if ($hash->{$_key}) {
 986             $hash->{$_key} .= '<br>' . $args->{$key};
 987         } else {
 988             $hash->{$_key} = $args->{$key};
 989         }
 990     }
 991     $hash->{'has_errors'} = 1;
 992 }
 993
 994 sub has_errors { scalar keys %{ shift->hash_errors } }
 995
 996 sub format_error {
 997     my ($self, $error) = @_;
 998     return $error;
 999 }
1000
1001 sub add_to_errors { shift->add_errors(@_) }
1002 sub add_to_swap   { my $self = shift; $self->add_to_hash($self->hash_swap,   @_) }
1003 sub add_to_fill   { my $self = shift; $self->add_to_hash($self->hash_fill,   @_) }
1004 sub add_to_form   { my $self = shift; $self->add_to_hash($self->hash_form,   @_) }
1005 sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
1006 sub add_to_base   { my $self = shift; $self->add_to_hash($self->hash_base,   @_) }
1007
1008 sub add_to_hash {
1009     my $self = shift;
1010     my $old  = shift;
1011     my $new  = shift;
1012     $new = {$new, @_} if ! ref $new; # non-hashref
1013     $old->{$_} = $new->{$_} foreach keys %$new;
1014 }
1015
1016
1017 sub base_dir_rel {
1018     my $self = shift;
1019     $self->{'base_dir_rel'} = shift if $#_ != -1;
1020     return $self->{'base_dir_rel'} || '';
1021 }
1022
1023 sub base_dir_abs {
1024     my $self = shift;
1025     $self->{'base_dir_abs'} = shift if $#_ != -1;
1026     return $self->{'base_dir_abs'} || '';
1027 }
1028
1029 sub ext_val {
1030     my $self = shift;
1031     $self->{'ext_val'} = shift if $#_ != -1;
1032     return $self->{'ext_val'} || 'val';
1033 }
1034
1035 sub ext_print {
1036     my $self = shift;
1037     $self->{'ext_print'} = shift if $#_ != -1;
1038     return $self->{'ext_print'} || 'html';
1039 }
1040
1041 ### where to find the javascript files
1042 ### default to using this script as a handler
1043 sub js_uri_path {
1044     my $self   = shift;
1045     my $script = $ENV{'SCRIPT_NAME'} || return '';
1046     my $js_step = $self->js_step;
1047     return ($self->can('path') == \&CGI::Ex::App::path)
1048         ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own)
1049         : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths
1050 }
1051
1052 ###----------------------------------------------------------------###
1053 ### a simple step that allows for printing javascript libraries that
1054 ### are stored in perls @INC.  Which ever step is in js_step should do something similar.
1055
1056 sub js_run_step {
1057     my $self = shift;
1058
1059     ### make sure path info looks like /js/CGI/Ex/foo.js
1060     my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
1061     $file = ($file =~  m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
1062
1063     $self->cgix->print_js($file);
1064     $self->{'_no_post_navigate'} = 1;
1065     return 1;
1066 }
1067
1068 ###----------------------------------------------------------------###
1069 ### a step that will be used if a valid_steps is defined
1070 ### and the current step of the path is not in valid_steps
1071 ### or if the step is a "hidden" step that begins with _
1072 ### or if the step name contains \W
1073
1074 sub __forbidden_info_complete { 0 }
1075
1076 sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} }
1077
1078 sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
1079
1080 ###----------------------------------------------------------------###
1081
1082 1;
1083
1084 ### See the perldoc in CGI/Ex/App.pod