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