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