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