From ed00221d27dfab1e82ec2ea040ab4c399a91c545 Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Tue, 26 Feb 2008 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.24 --- Changes | 9 + MANIFEST | 16 + MANIFEST.SKIP | 3 + META.yml | 2 +- README | 4 + lib/CGI/Ex.pm | 8 +- lib/CGI/Ex/App.pm | 280 ++++++------------ lib/CGI/Ex/App.pod | 23 +- lib/CGI/Ex/Auth.pm | 53 ++-- lib/CGI/Ex/Conf.pm | 2 +- lib/CGI/Ex/Die.pm | 2 +- lib/CGI/Ex/Dump.pm | 2 +- lib/CGI/Ex/Fill.pm | 2 +- lib/CGI/Ex/JSONDump.pm | 2 +- lib/CGI/Ex/Template.pm | 2 +- lib/CGI/Ex/Validate.pm | 10 +- lib/CGI/Ex/validate.js | 7 +- samples/app/app1/INSTALL | 7 + samples/app/app1/app1.pl | 19 ++ samples/app/app1/app1.yaml | 15 + samples/app/app1/js.pl | 17 ++ samples/app/app1/lib/App1.pm | 46 +++ samples/app/app1/lib/App1/CustInfo.pm | 71 +++++ samples/app/app1/lib/App1/DoBill.pm | 47 +++ samples/app/app1/lib/App1/PickDomain.pm | 49 +++ .../app/app1/lib/App1/PickDomainAlternate.pm | 35 +++ samples/app/app1/lib/App1/Thankyou.pm | 24 ++ samples/app/app1/tt/cust_info.html | 54 ++++ samples/app/app1/tt/footer.tt | 3 + samples/app/app1/tt/header.tt | 11 + samples/app/app1/tt/pick_domain.html | 15 + .../app/app1/tt/pick_domain_alternate.html | 15 + samples/app/app1/tt/thankyou.html | 8 + t/4_app_00_base.t | 17 +- 34 files changed, 644 insertions(+), 236 deletions(-) create mode 100644 samples/app/app1/INSTALL create mode 100755 samples/app/app1/app1.pl create mode 100644 samples/app/app1/app1.yaml create mode 100755 samples/app/app1/js.pl create mode 100644 samples/app/app1/lib/App1.pm create mode 100644 samples/app/app1/lib/App1/CustInfo.pm create mode 100644 samples/app/app1/lib/App1/DoBill.pm create mode 100644 samples/app/app1/lib/App1/PickDomain.pm create mode 100644 samples/app/app1/lib/App1/PickDomainAlternate.pm create mode 100644 samples/app/app1/lib/App1/Thankyou.pm create mode 100644 samples/app/app1/tt/cust_info.html create mode 100644 samples/app/app1/tt/footer.tt create mode 100644 samples/app/app1/tt/header.tt create mode 100644 samples/app/app1/tt/pick_domain.html create mode 100644 samples/app/app1/tt/pick_domain_alternate.html create mode 100644 samples/app/app1/tt/thankyou.html diff --git a/Changes b/Changes index 60acdaa..daee1c7 100644 --- 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 diff --git a/MANIFEST b/MANIFEST index a9184f9..2ccf8e7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -19,6 +19,22 @@ MANIFEST 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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 70b054a..df427d3 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -11,3 +11,6 @@ blib .cvsignore tmon\.out WrapEx.pm +cover_db +Var.pm +Tutorial.pod diff --git a/META.yml b/META.yml index b314ee3..4c708a0 100644 --- 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 -version: 2.23 +version: 2.24 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/README b/README index 1553dbf..43ec2c2 100644 --- 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) + #!/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 diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index f1842d6..bc44ab4 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.23'; + $VERSION = '2.24'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form @@ -486,7 +486,7 @@ sub print_js { ### 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; @@ -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) + #!/usr/bin/perl + use CGI::Ex; + CGI::Ex->print_js($ENV{'PATH_INFO'}); + =item C<-Eswap_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 cf97e67..e93c896 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -1,10 +1,9 @@ package CGI::Ex::App; -###----------------------------------------------------------------### +###---------------------### # 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); @@ -12,8 +11,7 @@ BEGIN { 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"; @@ -26,6 +24,7 @@ sub new { return $self; } +sub init {} 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; - - 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 ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n"; $self->destroy; - 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"; @@ -71,35 +63,25 @@ sub nav_loop { } 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'}]; - 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 - ### allow for per-step authentication 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) { @@ -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; } - ### 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; - $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); } - ### 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; @@ -140,11 +113,9 @@ sub nav_loop { 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) { @@ -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; @@ -172,9 +142,8 @@ sub path { push @$path, $step; } } - } - - return $self->{'path'}; + $path; + }; } sub run_hook { @@ -187,22 +156,15 @@ sub run_hook { 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'}) { - $hist->{'elapsed'} = time - $hist->{'time'}; + $hist->{'elapsed'} = time - $hist->{'time'}; $hist->{'response'} = $resp; } @@ -213,53 +175,38 @@ sub run_step { 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)) { - ### 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; } - ### 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; - 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_fill = $self->run_hook('hash_fill', $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; - my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill}; 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); } @@ -273,15 +220,11 @@ sub print { sub handle_error { my ($self, $err) = @_; - 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); - 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); - die $err_obj if $err_obj; + croak "$err_obj" if $err_obj; } $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 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 {} @@ -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 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 @@ -447,8 +390,6 @@ sub add_to_hash { $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 @@ -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'}; - 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]; + } 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; } @@ -495,15 +431,11 @@ sub dump_history { 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; } - die "Long Jump\n"; } @@ -514,55 +446,46 @@ sub find_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; - 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; - 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+$/; - ### 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; - $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) = @_; - 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; @@ -696,7 +617,6 @@ sub file_print { 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'); @@ -723,31 +643,26 @@ sub file_val { sub fill_template { my ($self, $step, $outref, $fill) = @_; return if ! $fill || ! scalar keys %$fill; - 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); } -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 { - ### 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, - }; # 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 $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 - 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); } +sub morph_base { my $self = shift; ref($self) } 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; } @@ -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 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) = @_; - $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) = @_; @@ -877,18 +798,17 @@ sub validate { return 1; } +sub validate_when_data { $_[0]->{'validate_when_data'} } + ###---------------------### # 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; - $self->require_auth(1); - return $self->navigate; } @@ -898,10 +818,7 @@ sub require_auth { 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({ @@ -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 $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); } @@ -957,27 +873,21 @@ sub _do_auth { ###---------------------### # 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; - - ### make sure path info looks like /js/CGI/Ex/foo.js 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; } -### 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 { \ "

Denied

You do not have access to the step \"[% forbidden_step %]\"" } -### 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 { \ "

A fatal error occurred

Step: \"[% error_step %]\"
[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" } diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod index 8194920..2967cbe 100644 --- 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) + ->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) @@ -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. +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 @@ -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 -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; @@ -2466,6 +2477,14 @@ path. A validation item of: 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 diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 5e9cbcb..38797d7 100644 --- 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; -$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; - my $template = $self->login_template; + my $file = $self->login_template; ### allow for a hooked override if (my $meth = $self->{'login_print'}) { - $meth->($self, $template, $hash); + $meth->($self, $file, $hash); 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 = ''; - $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; @@ -359,14 +360,17 @@ sub login_print { 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; @@ -892,9 +896,10 @@ __END__ =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), @@ -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. -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. +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 @@ -965,6 +979,7 @@ described separately. secure_hash_keys template_args template_include_path + template_obj text_user text_pass text_save diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 872b113..1288e7b 100644 --- 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); -$VERSION = '2.23'; +$VERSION = '2.24'; $DEFAULT_EXT = 'conf'; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index 75c3003..c6d6984 100644 --- 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 { - $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; diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index 18ecb1e..9025c4f 100644 --- 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; -$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); diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index 0d1a210..1f94d8d 100644 --- 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 { - $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); }; diff --git a/lib/CGI/Ex/JSONDump.pm b/lib/CGI/Ex/JSONDump.pm index c2bafee..c08f496 100644 --- a/lib/CGI/Ex/JSONDump.pm +++ b/lib/CGI/Ex/JSONDump.pm @@ -17,7 +17,7 @@ use strict; use base qw(Exporter); BEGIN { - $VERSION = '2.23'; + $VERSION = '2.24'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 51d6444..97d29bc 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -25,7 +25,7 @@ use vars qw($VERSION $VOBJS ); -$VERSION = '2.23'; +$VERSION = '2.24'; ### 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 f67a4ba..eadc981 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -22,7 +22,7 @@ use vars qw($VERSION @UNSUPPORTED_BROWSERS ); -$VERSION = '2.23'; +$VERSION = '2.24'; $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]+)$//; - - 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') { diff --git a/lib/CGI/Ex/validate.js b/lib/CGI/Ex/validate.js index ad80759..51e68af 100644 --- 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 @@ -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 (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; diff --git a/samples/app/app1/INSTALL b/samples/app/app1/INSTALL new file mode 100644 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 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 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 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 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 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 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 "
\n"; + print "At this point I would do something useful with the form data
\n"; + print "I would probably add the customer and lineitems and bill the order
\n"; + debug $self->form; + print "But for now I will just pretend I'm doing something for 10 seconds
\n"; + + my $max = 10; + for my $i (1 .. $max) { + $r->rflush if $r; + sleep 1; + print "Sleep $i/$max
\n"; + } + + print "
\n"; + # this little progress effect would be better off with something like yui + print "\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 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 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 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 index 0000000..47a52fa --- /dev/null +++ b/samples/app/app1/tt/cust_info.html @@ -0,0 +1,54 @@ +[% PROCESS "header.tt" title => "Account Information" %] + +Congratulations! The test domain [% domain %] is available.
+ +Please enter your account information. +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
[% first_name_error %]
[% last_name_error %]
+ + [% country_error %]
[% password_error %]
[% password2_error %]
+
+ 		 
+ +
+[% 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 index 0000000..cceeff1 --- /dev/null +++ b/samples/app/app1/tt/footer.tt @@ -0,0 +1,3 @@ +
+ + diff --git a/samples/app/app1/tt/header.tt b/samples/app/app1/tt/header.tt new file mode 100644 index 0000000..b24b55d --- /dev/null +++ b/samples/app/app1/tt/header.tt @@ -0,0 +1,11 @@ + + +[% title.html %] + + + +

[% title.html %]

diff --git a/samples/app/app1/tt/pick_domain.html b/samples/app/app1/tt/pick_domain.html new file mode 100644 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 %]) + +
+ + + +
+[% domain_error %] + +
+[% 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 index 0000000..f593d30 --- /dev/null +++ b/samples/app/app1/tt/pick_domain_alternate.html @@ -0,0 +1,15 @@ +[% PROCESS "header.tt" title => "Pick Domain" %] + +We're sorry - the domain [% domain %] is not available.
+Please choose from the following domains... + +
+ +[%- FOR d IN domains %] + [% d.html %]
+[%- END %] +
+ +
+ +[% PROCESS "footer.tt" %] diff --git a/samples/app/app1/tt/thankyou.html b/samples/app/app1/tt/thankyou.html new file mode 100644 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 %].
+To login, we would probably provide a link like "[% login_link.html %]".
+ +[% DUMP %] + +[% PROCESS "footer.tt" %] diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t index 3fe81be..2ed1676 100644 --- 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->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"); ###----------------------------------------------------------------### -- 2.43.0