CGI::Ex 2.24

diff --git a/Changes b/Changes
index 60acdaae09591c15b661f7120412f3024ead810e..daee1c7c54a952d7f11b631a5ba14b59ebda711b 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,12 @@
+2.24
+     2008-02-26
+        * Allow for smith.name
+        * Simplify some code in App.
+        * Allow for post_navigate to get called even in case of error.
+        * Added morph_base to App
+        * Added validate_when_data hook.
+        * Added samples/app/app1 which is a path based application
+

 2.23
      2007-12-20
         * Add the onevent load option - make sure validate_if figures into dependencies
 2.23
      2007-12-20
         * Add the onevent load option - make sure validate_if figures into dependencies

diff --git a/MANIFEST b/MANIFEST
index a9184f990e29a24836cc8681f672b82fb9c85f98..2ccf8e768cc3e77b299f10ec17c85d7ba36f2782 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -19,6 +19,22 @@ MANIFEST
 MANIFEST.SKIP
 META.yml
 README
 MANIFEST.SKIP
 META.yml
 README

+samples/app/app1/app1.pl
+samples/app/app1/app1.yaml
+samples/app/app1/INSTALL
+samples/app/app1/js.pl
+samples/app/app1/lib/App1.pm
+samples/app/app1/lib/App1/CustInfo.pm
+samples/app/app1/lib/App1/DoBill.pm
+samples/app/app1/lib/App1/PickDomain.pm
+samples/app/app1/lib/App1/PickDomainAlternate.pm
+samples/app/app1/lib/App1/Thankyou.pm
+samples/app/app1/tt/cust_info.html
+samples/app/app1/tt/footer.tt
+samples/app/app1/tt/header.tt
+samples/app/app1/tt/pick_domain.html
+samples/app/app1/tt/pick_domain_alternate.html
+samples/app/app1/tt/thankyou.html

 samples/app/cgi_ex_1.cgi
 samples/app/cgi_ex_2.cgi
 samples/benchmark/bench_auth.pl
 samples/app/cgi_ex_1.cgi
 samples/app/cgi_ex_2.cgi
 samples/benchmark/bench_auth.pl

diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index 70b054aa68005c8835013e3efdde0f2a8d518e87..df427d3d3b21adbedaabcc9867a3c9895da2a3c3 100644 (file)
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -11,3 +11,6 @@ blib
 .cvsignore
 tmon\.out
 WrapEx.pm
 .cvsignore
 tmon\.out
 WrapEx.pm

+cover_db
+Var.pm
+Tutorial.pod

diff --git a/META.yml b/META.yml
index b314ee3528af7cd9cd244e5d0ebaaa4a4e42db43..4c708a095e27e03207df81cd20d1194db0b41022 100644 (file)
--- a/META.yml
+++ b/META.yml
@@ -1,7 +1,7 @@
 # http://module-build.sourceforge.net/META-spec.html
 #XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
 name:         CGI-Ex
 # http://module-build.sourceforge.net/META-spec.html
 #XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
 name:         CGI-Ex

-version:      2.23
+version:      2.24

 version_from: lib/CGI/Ex.pm
 installdirs:  site
 requires:
 version_from: lib/CGI/Ex.pm
 installdirs:  site
 requires:

diff --git a/README b/README
index 1553dbf937525a90e44c0c51e85dc69790052e45..43ec2c2b627eced217465589c960ba070e272412 100644 (file)
--- a/README
+++ b/README
@@ -276,6 +276,10 @@ CGI::Ex METHODS
         shortened name which will be looked for in @INC. (ie
         /full/path/to/my.js or CGI/Ex/validate.js or CGI::Ex::validate)
 
         shortened name which will be looked for in @INC. (ie
         /full/path/to/my.js or CGI/Ex/validate.js or CGI::Ex::validate)
 

+            #!/usr/bin/perl
+            use CGI::Ex;
+            CGI::Ex->print_js($ENV{'PATH_INFO'});
+

     "->swap_template"
         This is intended as a simple yet strong subroutine to swap in tags
         to a document. It is intended to be very basic for those who may not
     "->swap_template"
         This is intended as a simple yet strong subroutine to swap in tags
         to a document. It is intended to be very basic for those who may not

diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm
index f1842d69ce5935cc8bef70206282bc1de7f20340..bc44ab4ca563d088bcfae39e092417a7a4d53b1b 100644 (file)
--- a/lib/CGI/Ex.pm
+++ b/lib/CGI/Ex.pm
@@ -24,7 +24,7 @@ use vars qw($VERSION
 use base qw(Exporter);
 
 BEGIN {
 use base qw(Exporter);
 
 BEGIN {

-    $VERSION               = '2.23';
+    $VERSION               = '2.24';

     $PREFERRED_CGI_MODULE  ||= 'CGI';
     @EXPORT = ();
     @EXPORT_OK = qw(get_form
     $PREFERRED_CGI_MODULE  ||= 'CGI';
     @EXPORT = ();
     @EXPORT_OK = qw(get_form


@@ -486,7 +486,7 @@ sub print_js {
 
     ### get file info
     my $stat;
 
     ### get file info
     my $stat;

-    if ($js_file && $js_file =~ m|^(\w+(?:/+\w+)*\.js)$|i) {
+    if ($js_file && $js_file =~ m|^/+?(\w+(?:/+\w+)*\.js)$|i) {

         foreach my $path (@INC) {
             my $_file = "$path/$1";
             next if ! -f $_file;
         foreach my $path (@INC) {
             my $_file = "$path/$1";
             next if ! -f $_file;


@@ -979,6 +979,10 @@ that the javascript will cache.  Takes either a full filename,
 or a shortened name which will be looked for in @INC. (ie /full/path/to/my.js
 or CGI/Ex/validate.js or CGI::Ex::validate)
 
 or a shortened name which will be looked for in @INC. (ie /full/path/to/my.js
 or CGI/Ex/validate.js or CGI::Ex::validate)
 

+    #!/usr/bin/perl
+    use CGI::Ex;
+    CGI::Ex->print_js($ENV{'PATH_INFO'});
+

 =item C<-E<gt>swap_template>
 
 This is intended as a simple yet strong subroutine to swap
 =item C<-E<gt>swap_template>
 
 This is intended as a simple yet strong subroutine to swap

diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm
index cf97e676ea235a3f0443ea6374aedd689f0c3ab4..e93c896b9f5646ae249793deeed8d78f6b471344 100644 (file)
--- a/lib/CGI/Ex/App.pm
+++ b/lib/CGI/Ex/App.pm
@@ -1,10 +1,9 @@
 package CGI::Ex::App;
 
 package CGI::Ex::App;
 

-###----------------------------------------------------------------###
+###---------------------###

 #  See the perldoc in CGI/Ex/App.pod
 #  Copyright 2007 - Paul Seamons
 #  Distributed under the Perl Artistic License without warranty
 #  See the perldoc in CGI/Ex/App.pod
 #  Copyright 2007 - Paul Seamons
 #  Distributed under the Perl Artistic License without warranty

-###----------------------------------------------------------------###

 
 use strict;
 use Carp qw(croak);
 
 use strict;
 use Carp qw(croak);


@@ -12,8 +11,7 @@ BEGIN {
     eval { use Time::HiRes qw(time) };
     eval { use Scalar::Util };
 }
     eval { use Time::HiRes qw(time) };
     eval { use Scalar::Util };
 }

-
-our $VERSION = '2.23';
+our $VERSION = '2.24';

 
 sub new {
     my $class = shift || croak "Usage: ".__PACKAGE__."->new";
 
 sub new {
     my $class = shift || croak "Usage: ".__PACKAGE__."->new";


@@ -26,6 +24,7 @@ sub new {
     return $self;
 }
 
     return $self;
 }
 

+sub init {}

 sub init_from_conf {
     my $self = shift;
     return if ! $self->load_conf;
 sub init_from_conf {
     my $self = shift;
     return if ! $self->load_conf;


@@ -43,26 +42,19 @@ sub navigate {
     $self->{'_time'} = time;
     eval {
         return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
     $self->{'_time'} = time;
     eval {
         return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;

-
-        eval {
-            local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
-            $self->nav_loop;
-        };
-        croak $@ if $@ && $@ ne "Long Jump\n";
-
-        $self->post_navigate if ! $self->{'_no_post_navigate'};
+        local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []};
+        $self->nav_loop;

     };
     $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors
     };
     $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors

+    $self->handle_error($@) if ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n";

 
     $self->destroy;
 
     $self->destroy;

-

     return $self;
 }
 
 sub nav_loop {
     my $self = shift;
 
     return $self;
 }
 
 sub nav_loop {
     my $self = shift;
 

-    ### keep from an infinate nesting

     local $self->{'_recurse'} = $self->{'_recurse'} || 0;
     if ($self->{'_recurse'}++ >= $self->recurse_limit) {
         my $err = "recurse_limit (".$self->recurse_limit.") reached";
     local $self->{'_recurse'} = $self->{'_recurse'} || 0;
     if ($self->{'_recurse'}++ >= $self->recurse_limit) {
         my $err = "recurse_limit (".$self->recurse_limit.") reached";


@@ -71,35 +63,25 @@ sub nav_loop {
     }
 
     my $path = $self->path;
     }
 
     my $path = $self->path;

+    return if $self->pre_loop($path);

 
 

-    ### allow for an early return
-    return if $self->pre_loop($path); # a true value means to abort the navigate
-
-    ### iterate on each step of the path
-    foreach ($self->{'path_i'} ||= 0;
-             $self->{'path_i'} <= $#$path;
-             $self->{'path_i'} ++) {
+    foreach ($self->{'path_i'} ||= 0; $self->{'path_i'} <= $#$path; $self->{'path_i'}++) {

         my $step = $path->[$self->{'path_i'}];
         my $step = $path->[$self->{'path_i'}];

-        if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
+        if ($step !~ /^([^\W0-9]\w*)$/) {

             $self->stash->{'forbidden_step'} = $step;
             $self->replace_path($self->forbidden_step);
             next;
         }
         $step = $1; # untaint
 
             $self->stash->{'forbidden_step'} = $step;
             $self->replace_path($self->forbidden_step);
             next;
         }
         $step = $1; # untaint
 

-        ### allow for per-step authentication

         if (! $self->is_authed) {
             my $req = $self->run_hook('require_auth', $step, 1);
         if (! $self->is_authed) {
             my $req = $self->run_hook('require_auth', $step, 1);

-            if (ref($req) ? $req->{$step} : $req) { # in the hash - or true
-                return if ! $self->run_hook('get_valid_auth', $step);
-            }
+            return if (ref($req) ? $req->{$step} : $req) && ! $self->run_hook('get_valid_auth', $step);

         }
 
         }
 

-        ### allow for becoming another package (allows for some steps in external files)
-        $self->morph($step);
+        $self->morph($step); # let steps be in external modules

 
 

-        ### allow for mapping path_info pieces to form elements
-        if (my $info = $self->path_info) {
+        if (my $info = $self->path_info) { # allow for mapping path_info pieces to form elements

             my $maps = $self->run_hook('path_info_map', $step) || [];
             croak 'Usage: sub path_info_map { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
             foreach my $map (@$maps) {
             my $maps = $self->run_hook('path_info_map', $step) || [];
             croak 'Usage: sub path_info_map { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
             foreach my $map (@$maps) {


@@ -111,28 +93,19 @@ sub nav_loop {
             }
         }
 
             }
         }
 

-        ### run the guts of the step
-        my $handled = $self->run_hook('run_step', $step);
-
-        ### Allow for the run_step to intercept.
-        ### A true status means the run_step took over navigation.
-        if ($handled) {
+        if ($self->run_hook('run_step', $step)) {

             $self->unmorph($step);
             return;
         }
 
             $self->unmorph($step);
             return;
         }
 

-        ### if there are no future steps - allow for this step to designate one to follow

         my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;
         my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0;

-        $self->run_hook('refine_path', $step, $is_at_end);
-
+        $self->run_hook('refine_path', $step, $is_at_end); # no more steps - allow for this step to designate one to follow

         $self->unmorph($step);
     }
 
         $self->unmorph($step);
     }
 

-    ### allow for one exit point after the loop
-    return if $self->post_loop($path); # a true value means to abort the navigate
+    return if $self->post_loop($path);

 
 

-    ### run the default step as a last resort
-    $self->insert_path($self->default_step);
+    $self->insert_path($self->default_step); # run the default step as a last resort

     $self->nav_loop; # go recursive
 
     return;
     $self->nav_loop; # go recursive
 
     return;


@@ -140,11 +113,9 @@ sub nav_loop {
 
 sub path {
     my $self = shift;
 
 sub path {
     my $self = shift;

-    if (! $self->{'path'}) {
-        my $path = $self->{'path'} = []; # empty path
-
-        ### add initial items to the form hash from path_info5B
-        if (my $info = $self->path_info) {
+    return $self->{'path'} ||= do {
+        my $path = [];
+        if (my $info = $self->path_info) { # add initial items to the form hash from path_info

             my $maps = $self->path_info_map_base || [];
             croak 'Usage: sub path_info_map_base { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
             foreach my $map (@$maps) {
             my $maps = $self->path_info_map_base || [];
             croak 'Usage: sub path_info_map_base { [] }' if ! UNIVERSAL::isa($maps, 'ARRAY');
             foreach my $map (@$maps) {


@@ -156,8 +127,7 @@ sub path {
             }
         }
 
             }
         }
 

-        ### make sure the step is valid
-        my $step = $self->form->{$self->step_key};
+        my $step = $self->form->{$self->step_key}; # make sure the step is valid

         if (defined $step) {
             if ($step =~ /^_/) {         # can't begin with _
                 $self->stash->{'forbidden_step'} = $step;
         if (defined $step) {
             if ($step =~ /^_/) {         # can't begin with _
                 $self->stash->{'forbidden_step'} = $step;


@@ -172,9 +142,8 @@ sub path {
                 push @$path, $step;
             }
         }
                 push @$path, $step;
             }
         }

-    }
-
-    return $self->{'path'};
+        $path;
+    };

 }
 
 sub run_hook {
 }
 
 sub run_hook {


@@ -187,22 +156,15 @@ sub run_hook {
 
     my $hist;
     if (! $self->{'no_history'}) {
 
     my $hist;
     if (! $self->{'no_history'}) {

-        $hist = {
-            step  => $step,
-            meth  => $hook,
-            found => $found,
-            time  => time,
-        };
-        push @{ $self->history }, $hist;
-        $hist->{'level'} = $self->{'_level'};
-        $hist->{'elapsed'}  = time - $hist->{'time'};
+        push @{ $self->history }, ($hist = {step => $step, meth => $hook, found => $found, time => time, level => $self->{'_level'}});
+        $hist->{'elapsed'} = time - $hist->{'time'};

     }
     local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
 
     my $resp = $self->$code($step, @_);
 
     if (! $self->{'no_history'}) {
     }
     local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
 
     my $resp = $self->$code($step, @_);
 
     if (! $self->{'no_history'}) {

-        $hist->{'elapsed'} = time - $hist->{'time'};
+        $hist->{'elapsed'}  = time - $hist->{'time'};

         $hist->{'response'} = $resp;
     }
 
         $hist->{'response'} = $resp;
     }
 


@@ -213,53 +175,38 @@ sub run_step {
     my $self = shift;
     my $step = shift;
 
     my $self = shift;
     my $step = shift;
 

-    ### if the pre_step exists and returns true, exit the nav_loop
-    return 1 if $self->run_hook('pre_step', $step);
-
-    ### allow for skipping this step (but stay in the nav_loop)
-    return 0 if $self->run_hook('skip', $step);
+    return 1 if $self->run_hook('pre_step', $step); # if true exit the nav_loop
+    return 0 if $self->run_hook('skip', $step);     # if true skip this step

 
 

-    ### see if we have complete valid information for this step
-    ### if so, do the next step
-    ### if not, get necessary info and print it out
+    # check for complete valid information for this step

     if (   ! $self->run_hook('prepare', $step)
         || ! $self->run_hook('info_complete', $step)
         || ! $self->run_hook('finalize', $step)) {
 
     if (   ! $self->run_hook('prepare', $step)
         || ! $self->run_hook('info_complete', $step)
         || ! $self->run_hook('finalize', $step)) {
 

-        ### show the page requesting the information
-        $self->run_hook('prepared_print', $step);
-
-        ### a hook after the printing process
-        $self->run_hook('post_print', $step);
+        $self->run_hook('prepared_print', $step); # show the page requesting the information
+        $self->run_hook('post_print', $step);     # a hook after the printing process

 
         return 1;
     }
 
 
         return 1;
     }
 

-    ### a hook before end of loop
-    ### if the post_step exists and returns true, exit the nav_loop
-    return 1 if $self->run_hook('post_step', $step);
-
-    ### let the nav_loop continue searching the path
-    return 0;
+    return 1 if $self->run_hook('post_step', $step); # if true exit the nav_loop
+    return 0; # let the nav_loop continue searching the path

 }
 
 sub prepared_print {
     my $self = shift;
     my $step = shift;
 }
 
 sub prepared_print {
     my $self = shift;
     my $step = shift;

-

     my $hash_form = $self->run_hook('hash_form',   $step) || {};
     my $hash_base = $self->run_hook('hash_base',   $step) || {};
     my $hash_comm = $self->run_hook('hash_common', $step) || {};
     my $hash_form = $self->run_hook('hash_form',   $step) || {};
     my $hash_base = $self->run_hook('hash_base',   $step) || {};
     my $hash_comm = $self->run_hook('hash_common', $step) || {};

-    my $hash_fill = $self->run_hook('hash_fill',   $step) || {};

     my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
     my $hash_swap = $self->run_hook('hash_swap',   $step) || {};

+    my $hash_fill = $self->run_hook('hash_fill',   $step) || {};

     my $hash_errs = $self->run_hook('hash_errors', $step) || {};
     my $hash_errs = $self->run_hook('hash_errors', $step) || {};

-

     $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
     $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
 
     $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) foreach keys %$hash_errs;
     $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
 

-    my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};

     my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
     my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};

-
+    my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};

     $self->run_hook('print', $step, $swap, $fill);
 }
 
     $self->run_hook('print', $step, $swap, $fill);
 }
 


@@ -273,15 +220,11 @@ sub print {
 
 sub handle_error {
     my ($self, $err) = @_;
 
 sub handle_error {
     my ($self, $err) = @_;

-

     die $err if $self->{'_handling_error'};
     die $err if $self->{'_handling_error'};

-    local $self->{'_handling_error'} = 1;
-    local $self->{'_recurse'} = 0; # allow for this next step - even if we hit a recurse error
-
+    local @{ $self }{'_handling_error', '_recurse' } = (1, 0); # allow for this next step - even if we hit a recurse error

     $self->stash->{'error_step'} = $self->current_step;
     $self->stash->{'error'}      = $err;
     $self->replace_path($self->error_step);
     $self->stash->{'error_step'} = $self->current_step;
     $self->stash->{'error'}      = $err;
     $self->replace_path($self->error_step);

-

     eval { $self->jump };
     die $@ if $@ && $@ ne "Long Jump\n";
 }
     eval { $self->jump };
     die $@ if $@ && $@ ne "Long Jump\n";
 }


@@ -379,7 +322,7 @@ sub conf {
         my $hash = $self->conf_validation;
         if ($hash && scalar keys %$hash) {
             my $err_obj = $self->val_obj->validate($conf, $hash);
         my $hash = $self->conf_validation;
         if ($hash && scalar keys %$hash) {
             my $err_obj = $self->val_obj->validate($conf, $hash);

-            die $err_obj if $err_obj;
+            croak "$err_obj" if $err_obj;

         }
         $conf;
     }
         }
         $conf;
     }


@@ -404,6 +347,7 @@ sub add_to_fill          { my $self = shift; $self->add_to_hash($self->hash_fill
 sub add_to_form          { my $self = shift; $self->add_to_hash($self->hash_form,   @_) }
 sub add_to_path          { shift->append_path(@_) } # legacy
 sub add_to_swap          { my $self = shift; $self->add_to_hash($self->hash_swap,   @_) }
 sub add_to_form          { my $self = shift; $self->add_to_hash($self->hash_form,   @_) }
 sub add_to_path          { shift->append_path(@_) } # legacy
 sub add_to_swap          { my $self = shift; $self->add_to_hash($self->hash_swap,   @_) }

+sub append_path          { my $self = shift; push @{ $self->path }, @_ }

 sub cleanup_user         { my ($self, $user) = @_; $user }
 sub current_step         { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
 sub destroy              {}
 sub cleanup_user         { my ($self, $user) = @_; $user }
 sub current_step         { $_[0]->step_by_path_index($_[0]->{'path_i'} || 0) }
 sub destroy              {}


@@ -413,7 +357,6 @@ sub fixup_before_unmorph {}
 sub format_error         { my ($self, $error) = @_; $error }
 sub get_pass_by_user     { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
 sub has_errors           { scalar keys %{ $_[0]->hash_errors } }
 sub format_error         { my ($self, $error) = @_; $error }
 sub get_pass_by_user     { croak "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
 sub has_errors           { scalar keys %{ $_[0]->hash_errors } }

-sub init                 {}

 sub last_step            { $_[0]->step_by_path_index($#{ $_[0]->path }) }
 sub path_info_map        {}
 sub post_loop            { 0 } # true value means to abort the nav_loop - don't recurse
 sub last_step            { $_[0]->step_by_path_index($#{ $_[0]->path }) }
 sub path_info_map        {}
 sub post_loop            { 0 } # true value means to abort the nav_loop - don't recurse


@@ -447,8 +390,6 @@ sub add_to_hash {
     $old->{$_} = $new->{$_} foreach keys %$new;
 }
 
     $old->{$_} = $new->{$_} foreach keys %$new;
 }
 

-sub append_path { my $self = shift; push @{ $self->path }, @_ }
-

 sub clear_app {
     my $self = shift;
     delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
 sub clear_app {
     my $self = shift;
     delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history


@@ -470,22 +411,17 @@ sub dump_history {
         my $note = ('    ' x ($row->{'level'} || 0))
             . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
         my $resp = $row->{'response'};
         my $note = ('    ' x ($row->{'level'} || 0))
             . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
         my $resp = $row->{'response'};

-        if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
-            $note .= ' - {}';
-        } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
-            $note .= ' - []';
-        } elsif (! defined $resp) {
-            $note .= ' - undef';
-        } elsif (! ref $resp || ! $all) {
-            my $max = $self->{'history_max'} || 30;
-            if (length($resp) > $max) {
-                $resp = substr($resp, 0, $max);
-                $resp =~ s/\n.+//s;
-                $resp = "$resp ...";
-            }
-            $note .= " - $resp";
-        } else {
+        if ($all) {

             $note = [$note, $resp];
             $note = [$note, $resp];

+        } else {
+            $note .= ' - '
+                .(! defined $resp                                 ? 'undef'
+                  : ref($resp) eq 'ARRAY' && ! @$resp             ? '[]'
+                  : ref($resp) eq 'HASH'  && ! scalar keys %$resp ? '{}'
+                  : do {
+                      $resp = $1 if $resp =~ /^(.+)\n/;
+                      length($resp) > 30 ? substr($resp, 0, 30)." ..." : $resp;
+                  });

         }
         push @$dump, $note;
     }
         }
         push @$dump, $note;
     }


@@ -495,15 +431,11 @@ sub dump_history {
 
 sub exit_nav_loop {
     my $self = shift;
 
 sub exit_nav_loop {
     my $self = shift;

-
-    ### undo morphs
-    if (my $ref = $self->{'_morph_lineage'}) {
-        ### use the saved index - this allows for early "morphers" to only get rolled back so far
-        my $index = $self->{'_morph_lineage_start_index'};
+    if (my $ref = $self->{'_morph_lineage'}) { # undo morphs
+        my $index = $self->{'_morph_lineage_start_index'}; # allow for early "morphers" to only get rolled back so far

         $index = -1 if ! defined $index;
         $self->unmorph while $#$ref != $index;
     }
         $index = -1 if ! defined $index;
         $self->unmorph while $#$ref != $index;
     }

-

     die "Long Jump\n";
 }
 
     die "Long Jump\n";
 }
 


@@ -514,55 +446,46 @@ sub find_hook {
         return [$code, "${step}_${hook}"],
     } elsif ($code = $self->can($hook)) {
         return [$code, $hook];
         return [$code, "${step}_${hook}"],
     } elsif ($code = $self->can($hook)) {
         return [$code, $hook];

-    } else {
-        return [];

     }
     }

+    return [];

 }
 
 sub insert_path {
     my $self = shift;
     my $ref  = $self->path;
     my $i    = $self->{'path_i'} || 0;
 }
 
 sub insert_path {
     my $self = shift;
     my $ref  = $self->path;
     my $i    = $self->{'path_i'} || 0;

-    if ($i + 1 > $#$ref) {
-        push @$ref, @_;
-    } else {
-        splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
-    }
+    if ($i + 1 > $#$ref) { push @$ref, @_ }
+    else                 { splice(@$ref, $i + 1, 0, @_) } # insert a path at the current location

 }
 
 sub jump {
     my $self   = shift;
     my $i      = @_ == 1 ? shift : 1;
     my $path   = $self->path;
 }
 
 sub jump {
     my $self   = shift;
     my $i      = @_ == 1 ? shift : 1;
     my $path   = $self->path;

-    my $path_i = $self->{'path_i'};
-    croak "Can't jump if nav_loop not started" if ! defined $path_i;
-
-    if ($i =~ /^\w+$/) {
-        if (   $i eq 'FIRST'   ) { $i = - $path_i - 1 }
-        elsif ($i eq 'LAST'    ) { $i = $#$path - $path_i }
-        elsif ($i eq 'NEXT'    ) { $i = 1  }
-        elsif ($i eq 'CURRENT' ) { $i = 0  }
-        elsif ($i eq 'PREVIOUS') { $i = -1 }
-        else { # look for a step by that name
-            for (my $j = $#$path; $j >= 0; $j --) {
-                if ($path->[$j] eq $i) {
-                    $i = $j - $path_i;
-                    last;
-                }
+    my $path_i = $self->{'path_i'}; croak "Can't jump if nav_loop not started" if ! defined $path_i;
+
+    if (   $i eq 'FIRST'   ) { $i = - $path_i - 1 }
+    elsif ($i eq 'LAST'    ) { $i = $#$path - $path_i }
+    elsif ($i eq 'NEXT'    ) { $i = 1  }
+    elsif ($i eq 'CURRENT' ) { $i = 0  }
+    elsif ($i eq 'PREVIOUS') { $i = -1 }
+    else { # look for a step by that name
+        for (my $j = $#$path; $j >= 0; $j --) {
+            if ($path->[$j] eq $i) {
+                $i = $j - $path_i;
+                last;

             }
         }
     }
     croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/;
 
             }
         }
     }
     croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/;
 

-    ### manipulate the path to contain the new jump location
-    my $cut_i   = $path_i + $i;
+    my $cut_i   = $path_i + $i; # manipulate the path to contain the new jump location

     my @replace = ($cut_i > $#$path) ? $self->default_step
                 : ($cut_i < 0)       ? @$path
                 :                      @$path[$cut_i .. $#$path];
     $self->replace_path(@replace);
 
     $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;
     my @replace = ($cut_i > $#$path) ? $self->default_step
                 : ($cut_i < 0)       ? @$path
                 :                      @$path[$cut_i .. $#$path];
     $self->replace_path(@replace);
 
     $self->{'jumps'} = ($self->{'jumps'} || 0) + 1;

-

     $self->{'path_i'}++; # move along now that the path is updated
     $self->nav_loop;     # recurse on the path
     $self->exit_nav_loop;
     $self->{'path_i'}++; # move along now that the path is updated
     $self->nav_loop;     # recurse on the path
     $self->exit_nav_loop;


@@ -682,12 +605,10 @@ sub unmorph {
 
 sub file_print {
     my ($self, $step) = @_;
 
 sub file_print {
     my ($self, $step) = @_;

-

     my $base_dir = $self->base_dir_rel;
     my $module   = $self->run_hook('name_module', $step);
     my $_step    = $self->run_hook('name_step', $step) || croak "Missing name_step";
     $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
     my $base_dir = $self->base_dir_rel;
     my $module   = $self->run_hook('name_module', $step);
     my $_step    = $self->run_hook('name_step', $step) || croak "Missing name_step";
     $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;

-

     foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 
     return $base_dir . $module . $_step;
     foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
 
     return $base_dir . $module . $_step;


@@ -696,7 +617,6 @@ sub file_print {
 sub file_val {
     my ($self, $step) = @_;
 
 sub file_val {
     my ($self, $step) = @_;
 

-    ### determine the path to begin looking for files - allow for an arrayref

     my $abs = $self->val_path || [];
     $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
     $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');
     my $abs = $self->val_path || [];
     $abs = $abs->() if UNIVERSAL::isa($abs, 'CODE');
     $abs = [$abs] if ! UNIVERSAL::isa($abs, 'ARRAY');


@@ -723,31 +643,26 @@ sub file_val {
 sub fill_template {
     my ($self, $step, $outref, $fill) = @_;
     return if ! $fill || ! scalar keys %$fill;
 sub fill_template {
     my ($self, $step, $outref, $fill) = @_;
     return if ! $fill || ! scalar keys %$fill;

-

     my $args = $self->run_hook('fill_args', $step) || {};
     my $args = $self->run_hook('fill_args', $step) || {};

-    local $args->{'text'} = $outref;
-    local $args->{'form'} = $fill;
-
+    local @{ $args }{'text', 'form'} = ($outref, $fill);

     require CGI::Ex::Fill;
     CGI::Ex::Fill::fill($args);
 }
 
     require CGI::Ex::Fill;
     CGI::Ex::Fill::fill($args);
 }
 

-sub finalize  { 1 } # failure means show step
+sub finalize  { 1 } # false means show step

 
 sub hash_base {
     my ($self, $step) = @_;
 
     return $self->{'hash_base'} ||= do {
 
 sub hash_base {
     my ($self, $step) = @_;
 
     return $self->{'hash_base'} ||= do {

-        ### create a weak copy of self to use in closures
-        my $copy = $self;
-        eval {require Scalar::Util; Scalar::Util::weaken($copy)};
+        my $copy = $self;  eval { require Scalar::Util; Scalar::Util::weaken($copy) };

         my $hash = {
             script_name     => $self->script_name,
             path_info       => $self->path_info,
             js_validation   => sub { $copy->run_hook('js_validation', $step, shift) },
             form_name       => $self->run_hook('form_name', $step),
             $self->step_key => $step,
         my $hash = {
             script_name     => $self->script_name,
             path_info       => $self->path_info,
             js_validation   => sub { $copy->run_hook('js_validation', $step, shift) },
             form_name       => $self->run_hook('form_name', $step),
             $self->step_key => $step,

-        }; # return of the do
+        };

     };
 }
 
     };
 }
 


@@ -761,8 +676,7 @@ sub hash_validation {
   my ($self, $step) = @_;
   return $self->{'hash_validation'}->{$step} ||= do {
       my $file = $self->run_hook('file_val', $step);
   my ($self, $step) = @_;
   return $self->{'hash_validation'}->{$step} ||= do {
       my $file = $self->run_hook('file_val', $step);

-      my $hash = $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies)
-      $hash; # return of the do
+      $file ? $self->val_obj->get_validation($file) : {}; # if the file is not found, errors will be in the webserver logs (all else dies)

   };
 }
 
   };
 }
 


@@ -776,19 +690,18 @@ sub info_complete {
 sub js_validation {
     my ($self, $step) = @_;
     return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
 sub js_validation {
     my ($self, $step) = @_;
     return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself

-

     my $form_name = $_[2] || $self->run_hook('form_name', $step);
     my $hash_val  = $_[3] || $self->run_hook('hash_validation', $step);
     my $js_uri    = $self->js_uri_path;
     return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
     my $form_name = $_[2] || $self->run_hook('form_name', $step);
     my $hash_val  = $_[3] || $self->run_hook('hash_validation', $step);
     my $js_uri    = $self->js_uri_path;
     return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;

-

     return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
 }
 
     return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
 }
 

+sub morph_base { my $self = shift; ref($self) }

 sub morph_package {
     my ($self, $step) = @_;
 sub morph_package {
     my ($self, $step) = @_;

-    my $cur = ref $self; # default to using self as the base for morphed modules
-    my $new = $cur .'::'. ($step || croak "Missing step");
+    my $cur = $self->morph_base; # default to using self as the base for morphed modules
+    my $new = ($cur ? $cur .'::' : '') . ($step || croak "Missing step");

     $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
     return $new;
 }
     $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
     return $new;
 }


@@ -803,18 +716,26 @@ sub name_module {
 sub name_step  { my ($self, $step) = @_; $step }
 sub next_step  { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
 sub post_print { 0 }
 sub name_step  { my ($self, $step) = @_; $step }
 sub next_step  { $_[0]->step_by_path_index(($_[0]->{'path_i'} || 0) + 1) }
 sub post_print { 0 }

-sub post_step  { 0 } # success indicates we handled step (don't continue step or loop)
-sub pre_step   { 0 } # success indicates we handled step (don't continue step or loop)
-sub prepare    { 1 } # failure means show step
+sub post_step  { 0 } # true indicates we handled step (exit loop)
+sub pre_step   { 0 } # true indicates we handled step (exit loop)
+sub prepare    { 1 } # false means show step

 
 sub print_out {
     my ($self, $step, $out) = @_;
 
 sub print_out {
     my ($self, $step, $out) = @_;

-

     $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
     print ref($out) eq 'SCALAR' ? $$out : $out;
 }
 
     $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
     print ref($out) eq 'SCALAR' ? $$out : $out;
 }
 

-sub ready_validate { ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0 }
+sub ready_validate {
+    my ($self, $step) = @_;
+    if ($self->run_hook('validate_when_data', $step)) {
+        if (my @keys = keys %{ $self->run_hook('hash_validation', $step) || {} }) {
+            my $form = $self->form;
+            return (grep { exists $form->{$_} } @keys) ? 1 : 0;
+        }
+    }
+    return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
+}

 
 sub refine_path {
     my ($self, $step, $is_at_end) = @_;
 
 sub refine_path {
     my ($self, $step, $is_at_end) = @_;


@@ -877,18 +798,17 @@ sub validate {
     return 1;
 }
 
     return 1;
 }
 

+sub validate_when_data { $_[0]->{'validate_when_data'} }
+

 ###---------------------###
 # authentication
 
 sub navigate_authenticated {
     my ($self, $args) = @_;
     $self = $self->new($args) if ! ref $self;
 ###---------------------###
 # authentication
 
 sub navigate_authenticated {
     my ($self, $args) = @_;
     $self = $self->new($args) if ! ref $self;

-
-    croak "The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting"
+    croak "Can't call navigate_authenticated method if default require_auth method is overwritten"

         if $self->can('require_auth') != \&CGI::Ex::App::require_auth;
         if $self->can('require_auth') != \&CGI::Ex::App::require_auth;

-

     $self->require_auth(1);
     $self->require_auth(1);

-

     return $self->navigate;
 }
 
     return $self->navigate;
 }
 


@@ -898,10 +818,7 @@ sub require_auth {
     return $self->{'require_auth'} || 0;
 }
 
     return $self->{'require_auth'} || 0;
 }
 

-sub is_authed {
-    my $data = shift->auth_data;
-    return $data && ! $data->{'error'};
-}
+sub is_authed { my $data = shift->auth_data; $data && ! $data->{'error'} }

 
 sub check_valid_auth {
     return shift->_do_auth({
 
 sub check_valid_auth {
     return shift->_do_auth({


@@ -921,8 +838,7 @@ sub get_valid_auth {
             my $hash_comm = $self->run_hook('hash_common', $step) || {};
             my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
             my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
             my $hash_comm = $self->run_hook('hash_common', $step) || {};
             my $hash_swap = $self->run_hook('hash_swap',   $step) || {};
             my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};

-
-            my $out = $self->run_hook('swap_template', $step, $template, $swap);
+            my $out  = $self->run_hook('swap_template', $step, $template, $swap);

             $self->run_hook('fill_template', $step, \$out, $hash);
             $self->run_hook('print_out', $step, \$out);
         }
             $self->run_hook('fill_template', $step, \$out, $hash);
             $self->run_hook('print_out', $step, \$out);
         }


@@ -957,27 +873,21 @@ sub _do_auth {
 ###---------------------###
 # default steps
 
 ###---------------------###
 # default steps
 

-### A simple step that allows for printing javascript libraries that are stored in perls @INC.
-### Which ever step is in js_step should do something similar for js validation to work.
-sub js_run_step {
+sub js_run_step { # step that allows for printing javascript libraries that are stored in perls @INC.

     my $self = shift;
     my $self = shift;

-
-    ### make sure path info looks like /js/CGI/Ex/foo.js

     my $file = $self->form->{'js'} || $self->path_info;
     my $file = $self->form->{'js'} || $self->path_info;

-    $file = ($file =~  m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
+    $file = ($file =~  m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; # make sure path info looks like /js/CGI/Ex/foo.js

 
     $self->cgix->print_js($file);
     $self->{'_no_post_navigate'} = 1;
     return 1;
 }
 
 
     $self->cgix->print_js($file);
     $self->{'_no_post_navigate'} = 1;
     return 1;
 }
 

-### A step that will be used the path method determines it is forbidden
-sub __forbidden_info_complete { 0 }
+sub __forbidden_info_complete { 0 } # step that will be used the path method determines it is forbidden

 sub __forbidden_hash_swap  { shift->stash }
 sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
 
 sub __forbidden_hash_swap  { shift->stash }
 sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
 

-### A step that is used by the default handle_error
-sub __error_info_complete { 0 }
+sub __error_info_complete { 0 } # step that is used by the default handle_error

 sub __error_hash_swap  { shift->stash }
 sub __error_file_print { \ "<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
 
 sub __error_hash_swap  { shift->stash }
 sub __error_file_print { \ "<h1>A fatal error occurred</h1>Step: <b>\"[% error_step %]\"</b><br>[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" }
 

diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod
index 8194920dcae1aa3e228bb8f382b82568ee0c06bc..2967cbe3972d4bdf5caa4aff09db3c0c9978b5e3 100644 (file)
--- a/lib/CGI/Ex/App.pod
+++ b/lib/CGI/Ex/App.pod
@@ -256,6 +256,7 @@ during the run_step hook.
 
         ->info_complete (hook - ran if prepare was true)
             ->ready_validate (hook)
 
         ->info_complete (hook - ran if prepare was true)
             ->ready_validate (hook)

+                ->validate_when_data (hook)

                 # returns false from info_complete if ! ready_validate
             ->validate (hook - uses CGI::Ex::Validate to validate form info)
                 ->hash_validation (hook)
                 # returns false from info_complete if ! ready_validate
             ->validate (hook - uses CGI::Ex::Validate to validate form info)
                 ->hash_validation (hook)


@@ -2102,6 +2103,13 @@ and check for its presence - such as the following:
 Changing the behavior of ready_validate can help in making wizard type
 applications.
 
 Changing the behavior of ready_validate can help in making wizard type
 applications.
 

+You can also use the validate_when_data hook to change the behavior of
+ready_validate.  If valiate_when_data returns true, then
+ready_validate will look for keys in the form matching keys that are
+in hash_validation - if they exist ready_validate will be true.  If
+there are no hash_validation keys, ready_validate uses its default
+behavior.
+

 =item refine_path (hook)
 
 Called at the end of nav_loop.  Passed a single value indicating
 =item refine_path (hook)
 
 Called at the end of nav_loop.  Passed a single value indicating


@@ -2278,8 +2286,11 @@ This method is not normally used.
 =item set_ready_validate (hook and method)
 
 Sets that the validation is ready (or not) to validate.  Should set the value
 =item set_ready_validate (hook and method)
 
 Sets that the validation is ready (or not) to validate.  Should set the value

-checked by the hook ready_validate.  The following would complement the
-processing flag above:
+checked by the hook ready_validate.  Has no affect if validate_when_data
+flag is set.
+
+The following would complement the "processing" flag example given in
+ready_validate description:

 
     sub set_ready_validate {
         my $self = shift;
 
     sub set_ready_validate {
         my $self = shift;


@@ -2466,6 +2477,14 @@ path.  A validation item of:
 
 would append 'bar' and 'baz' to the path should all validation succeed.
 
 
 would append 'bar' and 'baz' to the path should all validation succeed.
 

+=item validate_when_data (hook)
+
+Defaults to "validate_when_data" property which defaults to false.  Called
+during the ready_validate hook.  If returns true, ready_validate will look
+for keys in the form matching keys that are in hash_validation - if they exist
+ready_validate will be true.  If there are no hash_validation keys, ready_validate
+uses its default behavior.
+

 =item verify_user (method)
 
 Installed as a hook to CGI::Ex::App during get_valid_auth.  Should return
 =item verify_user (method)
 
 Installed as a hook to CGI::Ex::App during get_valid_auth.  Should return

diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm
index 5e9cbcbb3fdbc7a1e2dbfca37cd15785d0fe60df..38797d784c16a9dad699046cb9e496c0ff025a8b 100644 (file)
--- a/lib/CGI/Ex/Auth.pm
+++ b/lib/CGI/Ex/Auth.pm
@@ -18,7 +18,7 @@ use MIME::Base64 qw(encode_base64 decode_base64);
 use Digest::MD5 qw(md5_hex);
 use CGI::Ex;
 
 use Digest::MD5 qw(md5_hex);
 use CGI::Ex;
 

-$VERSION = '2.23';
+$VERSION = '2.24';

 
 ###----------------------------------------------------------------###
 
 
 ###----------------------------------------------------------------###
 


@@ -334,19 +334,20 @@ sub no_cookies_print {
 sub login_print {
     my $self = shift;
     my $hash = $self->login_hash_common;
 sub login_print {
     my $self = shift;
     my $hash = $self->login_hash_common;

-    my $template = $self->login_template;
+    my $file = $self->login_template;

 
     ### allow for a hooked override
     if (my $meth = $self->{'login_print'}) {
 
     ### allow for a hooked override
     if (my $meth = $self->{'login_print'}) {

-        $meth->($self, $template, $hash);
+        $meth->($self, $file, $hash);

         return 0;
     }
 
     ### process the document
         return 0;
     }
 
     ### process the document

-    require CGI::Ex::Template;
-    my $cet = CGI::Ex::Template->new($self->template_args);
+    my $args = $self->template_args;
+    $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_include_path,
+    my $t = $self->template_obj($args);

     my $out = '';
     my $out = '';

-    $cet->process_simple($template, $hash, \$out) || die $cet->error;
+    $t->process_simple($file, $hash, \$out) || die $t->error;

 
     ### fill in form fields
     require CGI::Ex::Fill;
 
     ### fill in form fields
     require CGI::Ex::Fill;


@@ -359,14 +360,17 @@ sub login_print {
     return 0;
 }
 
     return 0;
 }
 

-sub template_args {
-    my $self = shift;
-    return $self->{'template_args'} ||= {
-        INCLUDE_PATH => $self->template_include_path,
+sub template_obj {
+    my ($self, $args) = @_;
+    return $self->{'template_obj'} || do {
+        require Template::Alloy;
+        Template::Alloy->new($args);

     };
 }
 
     };
 }
 

-sub template_include_path { shift->{'template_include_path'} || '' }
+sub template_args { $_[0]->{'template_args'} ||= {} }
+
+sub template_include_path { $_[0]->{'template_include_path'} || '' }

 
 sub login_hash_common {
     my $self = shift;
 
 sub login_hash_common {
     my $self = shift;


@@ -892,9 +896,10 @@ __END__
 
 =head1 DESCRIPTION
 
 
 =head1 DESCRIPTION
 

-CGI::Ex::Auth allows for auto-expiring, safe and easy web based logins.  Auth uses
-javascript modules that perform MD5 hashing to cram the password on
-the client side before passing them through the internet.
+CGI::Ex::Auth allows for auto-expiring, safe and easy web based
+logins.  Auth uses javascript modules that perform MD5 hashing to cram
+the password on the client side before passing them through the
+internet.

 
 For the stored cookie you can choose to use simple cram mechanisms,
 secure hash cram tokens, auto expiring logins (not cookie based),
 
 For the stored cookie you can choose to use simple cram mechanisms,
 secure hash cram tokens, auto expiring logins (not cookie based),


@@ -902,13 +907,22 @@ and Crypt::Blowfish protection.  You can also choose to keep
 passwords plaintext and to use perl's crypt for testing
 passwords.
 
 passwords plaintext and to use perl's crypt for testing
 passwords.
 

-A downside to this module is that it does not use a session to
-preserve state so get_pass_by_user has to happen on every request (any
-authenticated area has to verify authentication each time).  A plus is
-that you don't need to use a session if you don't want to.  It is up
-to the interested reader to add caching to the get_pass_by_user
+A theoretical downside to this module is that it does not use a
+session to preserve state so get_pass_by_user has to happen on every
+request (any authenticated area has to verify authentication each
+time).  In theory you should be checking the password everytime a user
+makes a request to make sure the password is still valid.  A definite
+plus is that you don't need to use a session if you don't want to.  It
+is up to the interested reader to add caching to the get_pass_by_user

 method.
 
 method.
 

+In the end, the only truly secure login method is across an https
+connection.  Any connection across non-https (non-secure) is
+susceptible to cookie hijacking or tcp hijacking - though the
+possibility of this is normally small and typically requires access to
+a machine somewhere in your TCP chain.  If in doubt - you should try
+to use https.
+

 =head1 METHODS
 
 =over 4
 =head1 METHODS
 
 =over 4


@@ -965,6 +979,7 @@ described separately.
     secure_hash_keys
     template_args
     template_include_path
     secure_hash_keys
     template_args
     template_include_path

+    template_obj

     text_user
     text_pass
     text_save
     text_user
     text_pass
     text_save

diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm
index 872b113ab81c4c2f3ed6a9219cb47baf2304fc1d..1288e7b735a1f30fb37880a32c4f31f66bd230f6 100644 (file)
--- a/lib/CGI/Ex/Conf.pm
+++ b/lib/CGI/Ex/Conf.pm
@@ -29,7 +29,7 @@ use vars qw($VERSION
             );
 @EXPORT_OK = qw(conf_read conf_write in_cache);
 
             );
 @EXPORT_OK = qw(conf_read conf_write in_cache);
 

-$VERSION = '2.23';
+$VERSION = '2.24';

 
 $DEFAULT_EXT = 'conf';
 
 
 $DEFAULT_EXT = 'conf';
 

diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm
index 75c3003c60e6ce055a604f58536156861d35c711..c6d69846d775fccbf1aa9d82e5264deac0d61113 100644 (file)
--- a/lib/CGI/Ex/Die.pm
+++ b/lib/CGI/Ex/Die.pm
@@ -23,7 +23,7 @@ use CGI::Ex;
 use CGI::Ex::Dump qw(debug ctrace dex_html);
 
 BEGIN {
 use CGI::Ex::Dump qw(debug ctrace dex_html);
 
 BEGIN {

-  $VERSION = '2.23';
+  $VERSION = '2.24';

   $SHOW_TRACE = 0      if ! defined $SHOW_TRACE;
   $IGNORE_EVAL = 0     if ! defined $IGNORE_EVAL;
   $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
   $SHOW_TRACE = 0      if ! defined $SHOW_TRACE;
   $IGNORE_EVAL = 0     if ! defined $IGNORE_EVAL;
   $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;

diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm
index 18ecb1e8dd8aafa618847b54d430900e11de17a4..9025c4ff9c616f49df6b84b1332f0bb1c1abc196 100644 (file)
--- a/lib/CGI/Ex/Dump.pm
+++ b/lib/CGI/Ex/Dump.pm
@@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
 use strict;
 use Exporter;
 
 use strict;
 use Exporter;
 

-$VERSION   = '2.23';
+$VERSION   = '2.24';

 @ISA       = qw(Exporter);
 @EXPORT    = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
 @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug);
 @ISA       = qw(Exporter);
 @EXPORT    = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
 @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug);

diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm
index 0d1a2109692df1263ab9931b503a217b6ac0692a..1f94d8dadddabca4e8ba27df0a2654434b29b23b 100644 (file)
--- a/lib/CGI/Ex/Fill.pm
+++ b/lib/CGI/Ex/Fill.pm
@@ -24,7 +24,7 @@ use vars qw($VERSION
 use base qw(Exporter);
 
 BEGIN {
 use base qw(Exporter);
 
 BEGIN {

-    $VERSION   = '2.23';
+    $VERSION   = '2.24';

     @EXPORT    = qw(form_fill);
     @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
 };
     @EXPORT    = qw(form_fill);
     @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
 };

diff --git a/lib/CGI/Ex/JSONDump.pm b/lib/CGI/Ex/JSONDump.pm
index c2bafee3e56cbd73bd7ec5fe45565be2b9311689..c08f496c98c2a7eb4e34229c6b9a26a0b8b47590 100644 (file)
--- a/lib/CGI/Ex/JSONDump.pm
+++ b/lib/CGI/Ex/JSONDump.pm
@@ -17,7 +17,7 @@ use strict;
 use base qw(Exporter);
 
 BEGIN {
 use base qw(Exporter);
 
 BEGIN {

-    $VERSION  = '2.23';
+    $VERSION  = '2.24';

 
     @EXPORT = qw(JSONDump);
     @EXPORT_OK = @EXPORT;
 
     @EXPORT = qw(JSONDump);
     @EXPORT_OK = @EXPORT;

diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm
index 51d644457b94da1e77eaa530bd60518e7b082f0c..97d29bc7be61e0b3aca35211da1e3257f2884379 100644 (file)
--- a/lib/CGI/Ex/Template.pm
+++ b/lib/CGI/Ex/Template.pm
@@ -25,7 +25,7 @@ use vars qw($VERSION
             $VOBJS
             );
 
             $VOBJS
             );
 

-$VERSION = '2.23';
+$VERSION = '2.24';

 
 ### install true symbol table aliases that can be localized
 *QR_PRIVATE        = *Template::Alloy::QR_PRIVATE;
 
 ### install true symbol table aliases that can be localized
 *QR_PRIVATE        = *Template::Alloy::QR_PRIVATE;

diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm
index f67a4baa368215838f97aa19d03111c2eab242c6..eadc98145fc84cf747c654f005c04d44d4b302c8 100644 (file)
--- a/lib/CGI/Ex/Validate.pm
+++ b/lib/CGI/Ex/Validate.pm
@@ -22,7 +22,7 @@ use vars qw($VERSION
             @UNSUPPORTED_BROWSERS
             );
 
             @UNSUPPORTED_BROWSERS
             );
 

-$VERSION = '2.23';
+$VERSION = '2.24';

 
 $DEFAULT_EXT   = 'val';
 $QR_EXTRA      = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
 
 $DEFAULT_EXT   = 'val';
 $QR_EXTRA      = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;


@@ -661,13 +661,7 @@ sub check_type {
     return 0 if $value =~ m/(\.\-|\-\.|\.\.)/;
     return 0 if length($value) > 255;
     return 0 if $value !~ s/\.([a-z]+)$//;
     return 0 if $value =~ m/(\.\-|\-\.|\.\.)/;
     return 0 if length($value) > 255;
     return 0 if $value !~ s/\.([a-z]+)$//;

-
-    my $ext = $1;
-    if ($ext eq 'name') { # .name domains
-      return 0 if $value !~ /^[a-z0-9][a-z0-9\-]{0,62} \. [a-z0-9][a-z0-9\-]{0,62}$/x;
-    } else {              # any other domains
-      return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)* [a-z0-9][a-z0-9\-]{0,62}$/x;
-    }
+    return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)* [a-z0-9][a-z0-9\-]{0,62}$/x;

 
   ### validate a url
   } elsif ($type eq 'URL') {
 
   ### validate a url
   } elsif ($type eq 'URL') {

diff --git a/lib/CGI/Ex/validate.js b/lib/CGI/Ex/validate.js
index ad80759bdce2a6f822ed4c2f2662aae775852ad2..51e68af3ee3fe82637253685784971d7880d9f46 100644 (file)
--- a/lib/CGI/Ex/validate.js
+++ b/lib/CGI/Ex/validate.js
@@ -1,4 +1,4 @@
-// Copyright 2007 - Paul Seamons - $Revision: 1.73 $
+// Copyright 2007 - Paul Seamons - $Revision: 1.74 $

 // Distributed under the Perl Artistic License without warranty
 // See perldoc CGI::Ex::Validate for usage
 
 // Distributed under the Perl Artistic License without warranty
 // See perldoc CGI::Ex::Validate for usage
 


@@ -533,10 +533,7 @@ function v_check_type (value, type, field, form) {
   if (value.match(/^[.\-]/))             return 0;
   if (value.match(/(\.-|-\.|\.\.)/))  return 0;
   if (! (m = value.match(/^(.+\.)([a-z]{2,10})$/))) return 0;
   if (value.match(/^[.\-]/))             return 0;
   if (value.match(/(\.-|-\.|\.\.)/))  return 0;
   if (! (m = value.match(/^(.+\.)([a-z]{2,10})$/))) return 0;

-  if (m[2] == 'name') {
-   if (! m[1].match(/^([a-z0-9\-]{1,62}\.){2}$/)) return 0;
-  } else
-   if (! m[1].match(/^([a-z0-9\-]{1,62}\.)+$/)) return 0;
+  if (! m[1].match(/^([a-z0-9\-]{1,62}\.)+$/)) return 0;

 
  } else if (type == 'URL') {
   if (! value) return 0;
 
  } else if (type == 'URL') {
   if (! value) return 0;

diff --git a/samples/app/app1/INSTALL b/samples/app/app1/INSTALL
new file mode 100644 (file)
index 0000000..3c23f7e
--- /dev/null
+++ b/samples/app/app1/INSTALL
@@ -0,0 +1,7 @@
+To install and play with this sample, simply recursively copy or
+symlink the app1 directory into a cgi-bin or mod_perl registry script
+directory.  (If a symlink is made - be sure to set FollowSymlinks in
+your apache conf).
+
+Once the scripts are in the proper directory - make sure the permissions
+are set on app1.pl.  Then navigate to app1.pl through a web browser.

diff --git a/samples/app/app1/app1.pl b/samples/app/app1/app1.pl
new file mode 100755 (executable)
index 0000000..d05de5e
--- /dev/null
+++ b/samples/app/app1/app1.pl
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+app1 - Signup application using bare CGI::Ex::App
+
+ * configuration comes from conf file
+ * steps are in separate modules
+
+=cut
+
+use strict;
+use warnings;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use base qw(App1);
+
+App1->navigate;
+exit;

diff --git a/samples/app/app1/app1.yaml b/samples/app/app1/app1.yaml
new file mode 100644 (file)
index 0000000..1280a70
--- /dev/null
+++ b/samples/app/app1/app1.yaml
@@ -0,0 +1,15 @@
+---
+# configuration file for app1.pl
+
+# this is the path of steps that signup will go through
+# you could add intermediate steps here if you wanted to
+# in yahoo speak - this is a signup profile's list of brokers
+path:
+ - pick_domain
+ - pick_domain_alternate
+ - cust_info
+ - do_bill
+ - thankyou
+
+# setting this to 1 will turn off all history tracing
+no_history: 0

diff --git a/samples/app/app1/js.pl b/samples/app/app1/js.pl
new file mode 100755 (executable)
index 0000000..795068b
--- /dev/null
+++ b/samples/app/app1/js.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+js.pl - simple @INC js printer
+
+=head1 DESCRIPTION
+
+This is necessary because app1.pl hard codes path.
+
+=cut
+
+use strict;
+use warnings;
+
+use CGI::Ex;
+CGI::Ex->print_js($ENV{'PATH_INFO'});

diff --git a/samples/app/app1/lib/App1.pm b/samples/app/app1/lib/App1.pm
new file mode 100644 (file)
index 0000000..a86c1a0
--- /dev/null
+++ b/samples/app/app1/lib/App1.pm
@@ -0,0 +1,46 @@
+package App1;
+
+=head1 NAME
+
+App1 - base class for use in app1.pl
+
+=cut
+
+use strict;
+use warnings;
+use base qw(CGI::Ex::App);
+use FindBin qw($Bin);
+use CGI::Ex::Dump qw(debug);
+
+###----------------------------------------------------------------###
+
+# preload these so that their load times don't affect the dump_history times
+use CGI;
+use Template::Alloy qw(Parse Play Compile);
+
+sub post_navigate {
+    my $self = shift;
+    debug $self->dump_history
+        if ! $self->{'no_history'};
+}
+
+###----------------------------------------------------------------###
+
+sub load_conf       { 1 } # let configuration be read from a file
+sub conf_file       { "$Bin/app1.yaml" }
+sub conf_validation { {path => {required => 1, max_values => 100}} }
+
+sub allow_morph     { 1 } # allow each step to be in a separate file
+
+sub name_module     { "" } # allow content files to be in /tt/ directory directly
+sub template_path   { "$Bin/tt" }
+sub template_args   { {COMPILE_DIR => "/tmp/tt/app1.cache"} }
+
+# if we want automatic javascript validation, and we have overridden the path,
+# we need to give the script a way to find the validate.js
+sub js_uri_path { (my $path = $ENV{'SCRIPT_NAME'}) =~ s|[^/]+$|js.pl|; $path }
+
+# setting this instructs the flow to continue until a step does not have data
+sub validate_when_data { 1 }
+
+1;

diff --git a/samples/app/app1/lib/App1/CustInfo.pm b/samples/app/app1/lib/App1/CustInfo.pm
new file mode 100644 (file)
index 0000000..c164b07
--- /dev/null
+++ b/samples/app/app1/lib/App1/CustInfo.pm
@@ -0,0 +1,71 @@
+package App1::CustInfo;
+
+=head1 NAME
+
+App1::CustInfo - enter user info and verify it
+
+=cut
+
+use strict;
+use warnings;
+use base qw(App1);
+use CGI::Ex::Dump qw(debug);
+
+sub hash_swap {
+    my $self = shift;
+    return {
+        countries => $self->_countries,
+    };
+}
+
+sub hash_fill {
+    return if shift->ready_validate;
+    return {country => 'US'};
+}
+
+sub hash_validation {
+    my $self = shift;
+    return {
+        'group no_alert'   => 1,
+        'group no_confirm' => 1,
+        'group onevent'    => [qw(change blur submit)],
+        first_name => {
+            required => 1,
+            max_len  => 50,
+            custom   => sub { my ($key, $val) = @_; $val ne 'Matt' },
+            custom_error => 'Too many people named Matt - please use a different first name',
+        },
+        last_name => {
+            required => 1,
+            max_len  => 50,
+            min_len  => 2,
+        },
+        password => {
+            required     => 1,
+            max_len      => 15,
+            match        => 'm/[a-z]/i',
+            match_error  => 'Password must contain a letter',
+            match2       => 'm/[0-9]/',
+            match2_error => 'Password must contain a number',
+        },
+        password2 => {
+            equals => 'password',
+        },
+        country => {
+            required => 1,
+            custom   => sub { my ($key, $val) = @_; $self->_countries->{$val} },
+            custom_error => "Please pick from the list of valid countries",
+        }
+    };
+}
+
+sub _countries {
+    # this is better off in a database
+    return {
+        US => "United States",
+        CA => "Canada",
+        MX => "Mexico",
+    };
+}
+
+1;

diff --git a/samples/app/app1/lib/App1/DoBill.pm b/samples/app/app1/lib/App1/DoBill.pm
new file mode 100644 (file)
index 0000000..e759e91
--- /dev/null
+++ b/samples/app/app1/lib/App1/DoBill.pm
@@ -0,0 +1,47 @@
+package App1::DoBill;
+
+=head1 NAME
+
+App1::DoBill - This step would process the billing
+
+=cut
+
+use strict;
+use warnings;
+use base qw(App1);
+use CGI::Ex::Dump qw(debug);
+
+sub run_step {
+    my $self = shift;
+
+    my $r = $self->cgix->apache_request;
+    local $| = 1 if ! $r;
+
+    $self->cgix->print_content_type;
+
+    print "<div id=fake_progress>\n";
+    print "At this point I would do something useful with the form data<br>\n";
+    print "I would probably add the customer and lineitems and bill the order<br>\n";
+    debug $self->form;
+    print "But for now I will just pretend I'm doing something for 10 seconds<br>\n";
+
+    my $max = 10;
+    for my $i (1 .. $max) {
+        $r->rflush if $r;
+        sleep 1;
+        print "Sleep $i/$max<br>\n";
+    }
+
+    print "</div>\n";
+    # this little progress effect would be better off with something like yui
+    print "<script>
+        var el = document.getElementById('fake_progress');
+        if (el) el.style.display='none';
+        document.scrollTop = '0px';
+        </script>\n";
+
+    return 0;
+}
+
+1;
+

diff --git a/samples/app/app1/lib/App1/PickDomain.pm b/samples/app/app1/lib/App1/PickDomain.pm
new file mode 100644 (file)
index 0000000..e106b53
--- /dev/null
+++ b/samples/app/app1/lib/App1/PickDomain.pm
@@ -0,0 +1,49 @@
+package App1::PickDomain;
+
+=head1 NAME
+
+App1::PickDomain - usually the first step - pick a domain
+
+=cut
+
+use strict;
+use warnings;
+use base qw(App1);
+
+sub hash_swap {
+    my $self = shift;
+    return {
+        remote_addr => $ENV{'REMOTE_ADDR'},
+        time        => scalar(localtime),
+    };
+}
+
+sub hash_validation {
+    return {
+        'group no_alert'   => 1,
+        'group no_confirm' => 1,
+        domain => {
+            required   => 1,
+            to_lower_case => 1,
+            type       => 'DOMAIN',
+            type_error => 'Please enter a valid domain',
+        },
+    };
+}
+
+sub finalize {
+    my $self = shift;
+    my $domain = $self->form->{'domain'};
+
+    # contrived "check" for availability
+    # in theory - these checks would also cache with something like memcache
+    if ($domain =~ /^(\w+)\.com$/) { # for this test - .com isn't available
+        $self->stash->{'domain_prefix'} = $1;
+    } else {
+        $self->stash->{'domain_available'} = 1;
+    }
+
+    return 1;
+}
+
+1;

diff --git a/samples/app/app1/lib/App1/PickDomainAlternate.pm b/samples/app/app1/lib/App1/PickDomainAlternate.pm
new file mode 100644 (file)
index 0000000..750882e
--- /dev/null
+++ b/samples/app/app1/lib/App1/PickDomainAlternate.pm
@@ -0,0 +1,35 @@
+package App1::PickDomainAlternate;
+
+=head1 NAME
+
+App1::PickDomainAlternate - pick from a list of generated alternates when pick_domain fails
+
+=cut
+
+use strict;
+use warnings;
+use base qw(App1);
+
+sub skip { return 1 if shift->stash->{'domain_available'} }
+
+sub hash_swap {
+    my $self = shift;
+    return $self->{'pda_hash_swap'} ||= do { # cache since hash_fill is using us also
+        my $dom  = $self->stash->{'domain_prefix'} || die "Missing domain_prefix";
+
+        my @domains = map {"$dom.$_"} qw(net org biz info us); # contrived availability check
+        my $hash = {domains => \@domains};
+    };
+}
+
+sub hash_fill {
+    my $self = shift;
+    my $doms = $self->hash_swap->{'domains'};
+    return {
+        domain => $doms->[1], # promote .org #[rand @$doms],
+    };
+}
+
+sub info_complete { 0 } # step always shows when called
+
+1;

diff --git a/samples/app/app1/lib/App1/Thankyou.pm b/samples/app/app1/lib/App1/Thankyou.pm
new file mode 100644 (file)
index 0000000..e88e8b8
--- /dev/null
+++ b/samples/app/app1/lib/App1/Thankyou.pm
@@ -0,0 +1,24 @@
+package App1::Thankyou;
+
+=head1 NAME
+
+App1::Thankyou - show the final page of the application
+
+=cut
+
+use strict;
+use warnings;
+use base qw(App1);
+use CGI::Ex::Dump qw(debug);
+
+sub info_complete { 0 } # path officially ends here - don't try and run any other steps
+
+sub hash_swap {
+    my $self = shift;
+    return {
+        login_link => "some_sort_of_login_link",
+    };
+}
+
+1;
+

diff --git a/samples/app/app1/tt/cust_info.html b/samples/app/app1/tt/cust_info.html
new file mode 100644 (file)
index 0000000..47a52fa
--- /dev/null
+++ b/samples/app/app1/tt/cust_info.html
@@ -0,0 +1,54 @@
+[% PROCESS "header.tt" title => "Account Information" %]
+
+<span style="color:green">Congratulations! The test domain <b>[% domain %]</b> is available.</span><br>
+
+Please enter your account information.
+<form name=[% form_name %] action=[% script_name %] method=post>
+<input type=hidden name=domain>
+
+<table>
+<tr>
+  <td><label>First Name:</label></td>
+  <td><input type=text name=first_name></td>
+  <td><span class=error id=first_name_error>[% first_name_error %]</span></td>
+</tr>
+<tr>
+  <td><label>Last Name:</label></td>
+  <td><input type=text name=last_name></td>
+  <td><span class=error id=last_name_error>[% last_name_error %]</span></td>
+</tr>
+<tr>
+  <td><label>Country:</label></td>
+  <td>
+    <select name=country>
+      <option value="">Choose country</option>
+      [%- FOR code IN countries.keys.sort %]
+      <option value="[% code %]">[% countries.$code %]</option>
+      [%- END %]
+    </select>
+  </td>
+  <td><span class=error id=country_error>[% country_error %]</span></td>
+</tr>
+<tr>
+  <td><label>Password:</label></td>
+  <td><input type=text name=password></td>
+  <td><span class=error id=password_error>[% password_error %]</span></td>
+</tr>
+<tr>
+  <td><label>Password<br>Verify:</label></td>
+  <td><input type=text name=password2></td>
+  <td><span class=error id=password2_error>[% password2_error %]</span></td>
+</tr>
+
+<tr>
+  <td colspan=2 align=right>
+    <input type=submit value="Bill me"><br>
+  </td>
+  <td>&nbsp;</td>
+</tr>
+</table>
+
+</form>
+[% js_validation %]
+
+[% PROCESS "footer.tt" %]

diff --git a/samples/app/app1/tt/footer.tt b/samples/app/app1/tt/footer.tt
new file mode 100644 (file)
index 0000000..cceeff1
--- /dev/null
+++ b/samples/app/app1/tt/footer.tt
@@ -0,0 +1,3 @@
+<hr>
+</body>
+</html>

diff --git a/samples/app/app1/tt/header.tt b/samples/app/app1/tt/header.tt
new file mode 100644 (file)
index 0000000..b24b55d
--- /dev/null
+++ b/samples/app/app1/tt/header.tt
@@ -0,0 +1,11 @@
+<html>
+<head>
+<title>[% title.html %]</title>
+<style>
+.error {
+  color:red;
+}
+</style>
+</head>
+<body>
+<h1>[% title.html %]</h1>

diff --git a/samples/app/app1/tt/pick_domain.html b/samples/app/app1/tt/pick_domain.html
new file mode 100644 (file)
index 0000000..36e59f9
--- /dev/null
+++ b/samples/app/app1/tt/pick_domain.html
@@ -0,0 +1,15 @@
+[% PROCESS "header.tt" title => "Pick Domain" %]
+
+(Your ip is [% remote_addr %]) (The time is [% time %])
+
+<form name=[% form_name %] action=[% script_name %] method=post>
+
+<label>Pick a domain:</label>
+<input type=text name=domain>
+<input type=submit value="Check"><br>
+<span class=error id=domain_error>[% domain_error %]</span>
+
+</form>
+[% js_validation %]
+
+[% PROCESS "footer.tt" %]

diff --git a/samples/app/app1/tt/pick_domain_alternate.html b/samples/app/app1/tt/pick_domain_alternate.html
new file mode 100644 (file)
index 0000000..f593d30
--- /dev/null
+++ b/samples/app/app1/tt/pick_domain_alternate.html
@@ -0,0 +1,15 @@
+[% PROCESS "header.tt" title => "Pick Domain" %]
+
+<span class=error>We're sorry - the domain [% domain %] is not available.</span><br>
+Please choose from the following domains...
+
+<form name=[% form_name %] action=[% script_name %] method=post>
+
+[%- FOR d IN domains %]
+<input type=radio name=domain value="[% d.html %]"> [% d.html %]<br>
+[%- END %]
+<input type=submit value="Signup Domain"><br>
+
+</form>
+
+[% PROCESS "footer.tt" %]

diff --git a/samples/app/app1/tt/thankyou.html b/samples/app/app1/tt/thankyou.html
new file mode 100644 (file)
index 0000000..5d764e3
--- /dev/null
+++ b/samples/app/app1/tt/thankyou.html
@@ -0,0 +1,8 @@
+[% PROCESS "header.tt" title => "Signup Success" %]
+
+Thank you for signing up [% domain %].<br>
+To login, we would probably provide a link like "[% login_link.html %]".<br>
+
+[% DUMP %]
+
+[% PROCESS "footer.tt" %]

diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t
index 3fe81be023eeb197188882a1a375ea1bb3392351..2ed1676683b07981047fa137a96db86e68052822 100644 (file)
--- a/t/4_app_00_base.t
+++ b/t/4_app_00_base.t
@@ -922,14 +922,15 @@ local $ENV{'REQUEST_METHOD'} = 'POST';
 Foo11->new(form => {step => 'step1'})->navigate;
 ok($Foo::test_stdout eq 'step6_file_print', "Refine Path and set_ready_validate work ($Foo::test_stdout)");
 
 Foo11->new(form => {step => 'step1'})->navigate;
 ok($Foo::test_stdout eq 'step6_file_print', "Refine Path and set_ready_validate work ($Foo::test_stdout)");
 

-Foo11->set_ready_validate(1);
-ok(Foo11->ready_validate, "Is ready to validate");
-Foo11->set_ready_validate(0);
-ok(! Foo11->ready_validate, "Not ready to validate");
-Foo11->set_ready_validate(1);
-ok(Foo11->ready_validate, "Is ready to validate");
-Foo11->set_ready_validate('somestep', 0);
-ok(! Foo11->ready_validate, "Not ready to validate");
+$f = Foo11->new;
+$f->set_ready_validate(1);
+ok($f->ready_validate, "Is ready to validate");
+$f->set_ready_validate(0);
+ok(! $f->ready_validate, "Not ready to validate");
+$f->set_ready_validate(1);
+ok($f->ready_validate, "Is ready to validate");
+$f->set_ready_validate('somestep', 0);
+ok(! $f->ready_validate, "Not ready to validate");

 
 ###----------------------------------------------------------------###
 
 
 ###----------------------------------------------------------------###