From: Paul Seamons Date: Sat, 6 Dec 2008 00:00:00 +0000 (+0000) Subject: CGI::Ex 2.27 X-Git-Tag: v2.27 X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=commitdiff_plain;h=febed4ec71f803b083c3e61b82b9464e9bfb0992 CGI::Ex 2.27 --- diff --git a/Changes b/Changes index daee1c7..a14d5fc 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,41 @@ +2.27 + 2008-09-15 + * (App) Fix morph history during errors or other direct morph calls + * (App) Allow for step=foo/bar to look for file foo/bar.html + * (App) Allow for step=foo/bar to use internal name of foo__bar + * (App) Allow for step=foo/bar to morph to package App::Foo::Bar + * (Validate) Added the set_all_hook and clear_all_hook in validate.js + * (Validate) Streamline validate + * (Validate) Added generate_form to Validate + * (App) Added hooks in App to generate_form + * (Validate) Allow for "error" parameter in validation that is the general error message + * (Auth) Allow passing filename in Auth login_header, login_form, login_script and login_footer + * (Auth) Allow verify_token to be easily overridable + * (Auth) Allow passing cookie_domain, cookie_path, cookie_no_expires (force session cookie) in Auth for much more granular control + * (Auth) Allow for passing user without password to verify user matches a previously set cookie + * (App) Remove allow_nested_morph since allow_morph is more than capable of filling this role + * (App) Allow step name to be "jumped" to even if not in the path + * (App) Make jump unmorph if in the middle of lineage, deprecates some early morph cases. + * (Auth) Don't blank out form user field on failure (fixed bug in Auth login_hash_common) + * (App) Cleanup run_hook_as + * (App) Allow path_info_map to have second argument be a code ref that is passed form and matches + * (Validate) validate.js updates to make in sync more with Validate.pm (such as fields and order are synonymous) + * (Validate) Make validation names prettier by default + +2.26 + 2008-07-21 + * (App) Error handling bug again (accept refs in $@ again) + +2.25 + 2008-07-08 + * (Validate) Fix bugs in was_valid checking of Validate + * (JSONDump) Quote more keys in JSONDump + * (App) Allow for passing a coderef instead of the step name to run_hook + * (App) Handle fatal errors more gracefully + * (App) Make morph and unmorph calls be hooks + * (App) Allow allow_morph to return 2 (which requires a morph) + * (App) Add run_hook_as functionality + 2.24 2008-02-26 * Allow for smith.name diff --git a/MANIFEST b/MANIFEST index 2ccf8e7..430c6df 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,6 +13,7 @@ lib/CGI/Ex/sha1.js lib/CGI/Ex/Template.pm lib/CGI/Ex/validate.js lib/CGI/Ex/Validate.pm +lib/CGI/Ex/Validate.pod lib/CGI/Ex/yaml_load.js Makefile.PL MANIFEST diff --git a/META.yml b/META.yml index 4c708a0..f010773 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.24 +version: 2.27 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index bc44ab4..09e5139 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.24'; + $VERSION = '2.27'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form @@ -417,7 +417,7 @@ sub time_calc { return time + ($m->{lc($3)} || 1) * "$1$2"; } else { my @stat = stat $time; - die "Could not find file \"$time\" for time_calc" if $#stat == -1; + die "Could not find file \"$time\" for time_calc. You should pass one of \"now\", time(), \"[+-] \\d+ [smhdwMy]\" or a filename." if $#stat == -1; return $stat[9]; } } @@ -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; diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index e93c896..305fa23 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -2,7 +2,7 @@ package CGI::Ex::App; ###---------------------### # See the perldoc in CGI/Ex/App.pod -# Copyright 2007 - Paul Seamons +# Copyright 2008 - Paul Seamons # Distributed under the Perl Artistic License without warranty use strict; @@ -11,7 +11,7 @@ BEGIN { eval { use Time::HiRes qw(time) }; eval { use Scalar::Util }; } -our $VERSION = '2.24'; +our $VERSION = '2.27'; sub new { my $class = shift || croak "Usage: ".__PACKAGE__."->new"; @@ -45,7 +45,13 @@ sub navigate { local $self->{'_morph_lineage_start_index'} = $#{$self->{'_morph_lineage'} || []}; $self->nav_loop; }; - $self->handle_error($@) if $@ && $@ ne "Long Jump\n"; # catch any errors + my $err = $@; + if ($err && (ref($err) || $err ne "Long Jump\n")) { # catch any errors + die $err if ! $self->can('handle_error'); + if (! eval { $self->handle_error($err); 1 }) { + die "$err\nAdditionally, the following happened while calling handle_error: $@"; + } + } $self->handle_error($@) if ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n"; $self->destroy; @@ -69,8 +75,7 @@ sub nav_loop { my $step = $path->[$self->{'path_i'}]; if ($step !~ /^([^\W0-9]\w*)$/) { $self->stash->{'forbidden_step'} = $step; - $self->replace_path($self->forbidden_step); - next; + $self->goto_step($self->forbidden_step); } $step = $1; # untaint @@ -79,28 +84,19 @@ sub nav_loop { return if (ref($req) ? $req->{$step} : $req) && ! $self->run_hook('get_valid_auth', $step); } - $self->morph($step); # let steps be in external modules + $self->run_hook('morph', $step); # let steps be in external modules - 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) { - croak 'Usage: sub path_info_map { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY'); - my @match = $info =~ $map->[0]; - next if ! @match; - $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map; - last; - } - } + # allow for mapping path_info pieces to form elements + $self->parse_path_info('path_info_map', $self->run_hook('path_info_map', $step)); if ($self->run_hook('run_step', $step)) { - $self->unmorph($step); + $self->run_hook('unmorph', $step); return; } my $is_at_end = $self->{'path_i'} >= $#$path ? 1 : 0; $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->run_hook('unmorph', $step); } return if $self->post_loop($path); @@ -115,20 +111,11 @@ sub path { my $self = shift; 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) { - croak 'Usage: sub path_info_map_base { [[qr{/path_info/(\w+)}, "keyname"]] }' if ! UNIVERSAL::isa($map, 'ARRAY'); - my @match = $info =~ $map->[0]; - next if ! @match; - $self->form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $self->form->{$map->[$_]}} 1 .. $#$map; - last; - } - } + $self->parse_path_info('path_info_map_base', $self->path_info_map_base); # add initial items to the form hash from path_info my $step = $self->form->{$self->step_key}; # make sure the step is valid if (defined $step) { + $step =~ s|^/+||; $step =~ s|/|__|g; if ($step =~ /^_/) { # can't begin with _ $self->stash->{'forbidden_step'} = $step; push @$path, $self->forbidden_step; @@ -146,11 +133,34 @@ sub path { }; } +sub parse_path_info { + my ($self, $type, $maps, $info, $form) = @_; + $info ||= $self->path_info || return; + $form ||= $self->form; + return if ! $maps; + croak "Usage: sub $type { [] }" if ! UNIVERSAL::isa($maps, 'ARRAY'); + foreach my $map (@$maps) { + croak "Usage: sub $type { [[qr{/path_info/(\\w+)}, 'keyname']] }" if ! UNIVERSAL::isa($map, 'ARRAY'); + my @match = $info =~ $map->[0]; + next if ! @match; + if (UNIVERSAL::isa($map->[1], 'CODE')) { + $map->[1]->($form, @match); + } else { + $form->{$map->[$_]} = $match[$_ - 1] foreach grep {! defined $form->{$map->[$_]}} 1 .. $#$map; + } + last; + } +} + sub run_hook { - my $self = shift; - my $hook = shift; - my $step = shift; - my ($code, $found) = @{ $self->find_hook($hook, $step) }; + my ($self, $hook, $step, @args) = @_; + my ($code, $found); + if (ref $hook eq 'CODE') { + $code = $hook; + $hook = $found = 'coderef'; + } else { + ($code, $found) = @{ $self->find_hook($hook, $step) }; + } croak "Could not find a method named ${step}_${hook} or ${hook}" if ! $code; croak "Value for $hook ($found) is not a code ref ($code)" if ! UNIVERSAL::isa($code, 'CODE'); @@ -161,7 +171,7 @@ sub run_hook { } local $self->{'_level'} = 1 + ($self->{'_level'} || 0); - my $resp = $self->$code($step, @_); + my $resp = $self->$code($step, @args); if (! $self->{'no_history'}) { $hist->{'elapsed'} = time - $hist->{'time'}; @@ -171,6 +181,17 @@ sub run_hook { return $resp; } +sub run_hook_as { + my ($self, $hook, $step, $pkg, @args) = @_; + croak "Missing hook" if ! $hook; + croak "Missing step" if ! $step; + croak "Missing package" if ! $pkg; + $self->morph($step, 2, $pkg); + my $resp = $self->run_hook($hook, $step, @args); + $self->unmorph; + return $resp; +} + sub run_step { my $self = shift; my $step = shift; @@ -224,41 +245,43 @@ sub handle_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 }; + eval { + my $step = $self->error_step; + $self->morph($step); # let steps be in external modules + $self->run_hook('run_step', $step) && $self->unmorph($step); + }; die $@ if $@ && $@ ne "Long Jump\n"; } ###---------------------### # read only accessors -sub allow_morph { $_[0]->{'allow_morph'} } -sub allow_nested_morph { $_[0]->{'allow_nested_morph'} } -sub auth_args { $_[0]->{'auth_args'} } -sub charset { $_[0]->{'charset'} || '' } -sub conf_args { $_[0]->{'conf_args'} } -sub conf_die_on_fail { $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} } -sub conf_path { $_[0]->{'conf_path'} || $_[0]->base_dir_abs } -sub conf_validation { $_[0]->{'conf_validation'} } -sub default_step { $_[0]->{'default_step'} || 'main' } -sub error_step { $_[0]->{'error_step'} || '__error' } -sub fill_args { $_[0]->{'fill_args'} } -sub forbidden_step { $_[0]->{'forbidden_step'} || '__forbidden' } -sub form_name { $_[0]->{'form_name'} || 'theform' } -sub history { $_[0]->{'history'} ||= [] } -sub js_step { $_[0]->{'js_step'} || 'js' } -sub login_step { $_[0]->{'login_step'} || '__login' } -sub mimetype { $_[0]->{'mimetype'} || 'text/html' } -sub path_info { $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' } -sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] } -sub recurse_limit { $_[0]->{'recurse_limit'} || 15 } -sub script_name { $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 } -sub stash { $_[0]->{'stash'} ||= {} } -sub step_key { $_[0]->{'step_key'} || 'step' } -sub template_args { $_[0]->{'template_args'} } -sub template_path { $_[0]->{'template_path'} || $_[0]->base_dir_abs } -sub val_args { $_[0]->{'val_args'} } -sub val_path { $_[0]->{'val_path'} || $_[0]->template_path } +sub allow_morph { $_[0]->{'allow_morph'} } +sub auth_args { $_[0]->{'auth_args'} } +sub charset { $_[0]->{'charset'} || '' } +sub conf_args { $_[0]->{'conf_args'} } +sub conf_die_on_fail { $_[0]->{'conf_die_on_fail'} || ! defined $_[0]->{'conf_die_on_fail'} } +sub conf_path { $_[0]->{'conf_path'} || $_[0]->base_dir_abs } +sub conf_validation { $_[0]->{'conf_validation'} } +sub default_step { $_[0]->{'default_step'} || 'main' } +sub error_step { $_[0]->{'error_step'} || '__error' } +sub fill_args { $_[0]->{'fill_args'} } +sub forbidden_step { $_[0]->{'forbidden_step'} || '__forbidden' } +sub form_name { $_[0]->{'form_name'} || 'theform' } +sub history { $_[0]->{'history'} ||= [] } +sub js_step { $_[0]->{'js_step'} || 'js' } +sub login_step { $_[0]->{'login_step'} || '__login' } +sub mimetype { $_[0]->{'mimetype'} || 'text/html' } +sub path_info { $_[0]->{'path_info'} || $ENV{'PATH_INFO'} || '' } +sub path_info_map_base { $_[0]->{'path_info_map_base'} ||[[qr{/(\w+)}, $_[0]->step_key]] } +sub recurse_limit { $_[0]->{'recurse_limit'} || 15 } +sub script_name { $_[0]->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 } +sub stash { $_[0]->{'stash'} ||= {} } +sub step_key { $_[0]->{'step_key'} || 'step' } +sub template_args { $_[0]->{'template_args'} } +sub template_path { $_[0]->{'template_path'} || $_[0]->base_dir_abs } +sub val_args { $_[0]->{'val_args'} } +sub val_path { $_[0]->{'val_path'} || $_[0]->template_path } sub conf_obj { my $self = shift; @@ -422,6 +445,7 @@ sub dump_history { $resp = $1 if $resp =~ /^(.+)\n/; length($resp) > 30 ? substr($resp, 0, 30)." ..." : $resp; }); + $note .= ' - '.$row->{'info'} if defined $row->{'info'}; } push @$dump, $note; } @@ -458,24 +482,32 @@ sub insert_path { else { splice(@$ref, $i + 1, 0, @_) } # insert a path at the current location } -sub jump { +sub jump { shift->goto_step(@_) } + +sub goto_step { 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; + my $path_i = $self->{'path_i'} || 0; 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 --) { + elsif ($i !~ /^-?\d+/) { # look for a step by that name in the current remaining path + my $found; + for (my $j = $path_i; $j < @$path; $j++) { if ($path->[$j] eq $i) { $i = $j - $path_i; + $found = 1; last; } } + if (! $found) { + $self->replace_path($i); + $i = $#$path; + } } croak "Invalid jump index ($i)" if $i !~ /^-?\d+$/; @@ -487,7 +519,10 @@ sub jump { $self->{'jumps'} = ($self->{'jumps'} || 0) + 1; $self->{'path_i'}++; # move along now that the path is updated - $self->nav_loop; # recurse on the path + + my $lin = $self->{'_morph_lineage'} || []; + $self->unmorph if @$lin; + $self->nav_loop; # recurse on the path $self->exit_nav_loop; } @@ -495,70 +530,71 @@ sub js_uri_path { my $self = shift; my $script = $self->script_name; my $js_step = $self->js_step; - return ($self->can('path') == \&CGI::Ex::App::path) + return ($self->can('path') == \&CGI::Ex::App::path + && $self->can('path_info_map_base') == \&CGI::Ex::App::path_info_map_base) ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own) - : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths + : $script .'?'. $self->step_key .'='. $js_step .'&js='; # use one that works with more paths } sub morph { my $self = shift; + my $ref = $self->history->[-1]; + if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'morph') { + push @{ $self->history }, ($ref = {meth => 'morph', found => 'morph', elapsed => 0, step => 'unknown', level => $self->{'_level'}}); + } my $step = shift || return; - my $allow = $self->run_hook('allow_morph', $step) || return; + my $allow = shift || $self->run_hook('allow_morph', $step) || return; + my $new = shift; # optionally allow passing in the package to morph to my $lin = $self->{'_morph_lineage'} ||= []; - my $cur = ref $self; # what are we currently - push @$lin, $cur; # store so subsequent unmorph calls can do the right thing + my $ok = 0; + my $cur = ref $self; - my $hist = {step => $step, meth => 'morph', found => 'morph', time => time, elapsed => 0, response => 0}; - push @{ $self->history }, $hist if ! $self->{'no_history'}; + push @$lin, $cur; # store so subsequent unmorph calls can do the right thing - if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless - $hist->{'found'} .= " (not allowed to morph to that step)"; - return 0; - } + # hash - but no step - record for unbless + if (ref($allow) && ! ($allow = $allow->{$step})) { + $ref->{'info'} = "not allowed to morph to that step"; - ### make sure we haven't already been reblessed - if ($#$lin != 0 # is this the second morph call - && (! ($allow = $self->allow_nested_morph($step)) # not true - || (ref($allow) && ! $allow->{$step}) # hash - but no step - )) { - $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)"; - return 0; # just return - don't die so that we can morph early - } + } elsif (! ($new ||= $self->run_hook('morph_package', $step))) { + $ref->{'info'} = "Missing morph_package for step $step"; + + } elsif ($cur eq $new) { + $ref->{'info'} = "already isa $new"; + $ok = 1; ### if we are not already that package - bless us there - my $new = $self->run_hook('morph_package', $step); - if ($cur ne $new) { + } else { (my $file = "$new.pm") =~ s|::|/|g; - if (UNIVERSAL::can($new, 'can') # check if the package space exists - || eval { require $file }) { # check for a file that holds this package - bless $self, $new; # become that package - $hist->{'found'} .= " (changed $cur to $new)"; + if (UNIVERSAL::can($new, 'fixup_after_morph') # check if the package space exists + || (eval { require $file } # check for a file that holds this package + && UNIVERSAL::can($new, 'fixup_after_morph'))) { + bless $self, $new; # become that package $self->fixup_after_morph($step); + $ref->{'info'} = "changed $cur to $new"; } elsif ($@) { - if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened - $hist->{'found'} .= " (failed from $cur to $new: $1)"; + if ($allow eq '1' && $@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened + $ref->{'info'} = "failed from $cur to $new: $1"; } else { - $hist->{'found'} .= " (failed from $cur to $new: $@)"; - my $err = "Trouble while morphing to $file: $@"; - warn $err; + $ref->{'info'} = "failed from $cur to $new: $@"; + die "Trouble while morphing from $cur to $new: $@"; } + } elsif ($allow ne '1') { + $ref->{'info'} = "package $new doesn't support CGI::Ex::App API"; + die "Found package $new, but $new doesn't support CGI::Ex::App API"; } + $ok = 1; } - $hist->{'response'} = 1; - return 1; + return $ok; } sub replace_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, $#$ref - $i, @_); # replace remaining entries - } + if ($i + 1 > $#$ref) { push @$ref, @_; } + else { splice(@$ref, $i + 1, $#$ref - $i, @_); } # replace remaining entries } sub set_path { @@ -579,25 +615,24 @@ sub step_by_path_index { sub unmorph { my $self = shift; my $step = shift || '_no_step'; + my $ref = $self->history->[-1] || {}; + if (! $ref || ! $ref->{'meth'} || $ref->{'meth'} ne 'unmorph') { + push @{ $self->history }, ($ref = {meth => 'unmorph', found => 'unmorph', elapsed => 0, step => $step, level => $self->{'_level'}}); + } my $lin = $self->{'_morph_lineage'} || return; my $cur = ref $self; - - my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)"; + my $prev = pop(@$lin) || croak "unmorph called more times than morph (current: $cur)"; delete $self->{'_morph_lineage'} if ! @$lin; - my $hist = {step => $step, meth => 'unmorph', found => 'unmorph', time => time, elapsed => 0, response => 0}; - push @{ $self->history }, $hist if ! $self->{'no_history'}; - if ($cur ne $prev) { $self->fixup_before_unmorph($step); bless $self, $prev; - $hist->{'found'} .= " (changed from $cur to $prev)"; + $ref->{'info'} = "changed from $cur to $prev"; } else { - $hist->{'found'} .= " (already isa $cur)"; + $ref->{'info'} = "already isa $cur"; } - $hist->{'response'} = 1; - return $self; + return 1; } ###---------------------### @@ -608,6 +643,7 @@ sub file_print { 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 =~ s|\B__+|/|g; $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/; foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| } @@ -625,6 +661,7 @@ sub file_val { 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 =~ s|\B__+|/|g; $_step =~ s/\.\w+$//; $_step .= '.'. $self->ext_val; @@ -660,6 +697,7 @@ sub hash_base { script_name => $self->script_name, path_info => $self->path_info, js_validation => sub { $copy->run_hook('js_validation', $step, shift) }, + generate_form => sub { $copy->run_hook('generate_form', $step, (ref($_[0]) ? (undef, shift) : shift)) }, form_name => $self->run_hook('form_name', $step), $self->step_key => $step, }; @@ -689,7 +727,6 @@ 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; @@ -697,12 +734,23 @@ sub js_validation { return $self->val_obj->generate_js($hash_val, $form_name, $js_uri); } +sub generate_form { + my ($self, $step) = @_; + my $form_name = $_[2] || $self->run_hook('form_name', $step); + my $args = ref($_[3]) eq 'HASH' ? $_[3] : {}; + my $hash_val = $self->run_hook('hash_validation', $step); + return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val; + local $args->{'js_uri_path'} = $self->js_uri_path; + return $self->val_obj->generate_form($hash_val, $form_name, $args); +} + sub morph_base { my $self = shift; ref($self) } sub morph_package { my ($self, $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 + $new =~ s/\B__+/::/g; # turn Foo::my_nested__step info Foo::my_nested::step + $new =~ s/(?:_+|\b)(\w)/\u$1/g; # turn Foo::my_step_name into Foo::MyStepName return $new; } @@ -829,22 +877,17 @@ sub check_valid_auth { sub get_valid_auth { my $self = shift; - return $self->_do_auth({ login_print => sub { # use CGI::Ex::Auth - but use our formatting and printing my ($auth, $template, $hash) = @_; - my $step = $self->login_step; - my $hash_base = $self->run_hook('hash_base', $step) || {}; - 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); - $self->run_hook('fill_template', $step, \$out, $hash); - $self->run_hook('print_out', $step, \$out); + local $self->{'__login_file_print'} = $template; + local $self->{'__login_hash_common'} = $hash; + return $self->goto_step($self->login_step); } }); } + sub _do_auth { my ($self, $extra) = @_; return $self->auth_data if $self->is_authed; @@ -862,7 +905,6 @@ sub _do_auth { my $obj = $self->auth_obj($args); my $resp = $obj->get_valid_auth; - my $data = $obj->last_auth_data; delete $data->{'real_pass'} if defined $data; # data may be defined but false $self->auth_data($data); # failed authentication may still have auth_data @@ -883,14 +925,22 @@ sub js_run_step { # step that allows for printing javascript libraries that are return 1; } +sub __forbidden_allow_morph { shift->allow_morph(@_) && 1 } 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_hash_common { shift->stash } sub __forbidden_file_print { \ "

Denied

You do not have access to the step \"[% forbidden_step %]\"" } +sub __error_allow_morph { shift->allow_morph(@_) && 1 } sub __error_info_complete { 0 } # step that is used by the default handle_error -sub __error_hash_swap { shift->stash } +sub __error_hash_common { shift->stash } sub __error_file_print { \ "

A fatal error occurred

Step: \"[% error_step %]\"
[% TRY; CONFIG DUMP => {header => 0}; DUMP error; END %]" } +sub __login_require_auth { 0 } +sub __login_allow_morph { shift->allow_morph(@_) && 1 } +sub __login_info_complete { 0 } # step used by default authentication +sub __login_hash_common { shift->{'__login_hash_common'} || {error => "hash_common not set during default __login"} } +sub __login_file_print { shift->{'__login_file_print'} || \ "file_print not set during default __login
[% login_error %]" } + 1; ### See the perldoc in CGI/Ex/App.pod diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod index 2967cbe..536741b 100644 --- a/lib/CGI/Ex/App.pod +++ b/lib/CGI/Ex/App.pod @@ -207,9 +207,8 @@ The nav_loop method will run as follows: ->require_auth (hook) # exits nav_loop if true - ->morph + ->morph (hook) # check ->allow_morph (hook) - # check ->allow_nested_morph # ->morph_package (hook - get the package to bless into) # ->fixup_after_morph if morph_package exists # if no package is found, process continues in current file @@ -223,8 +222,7 @@ The nav_loop method will run as follows: ->next_step (hook) # find next step and add to path ->set_ready_validate(0) (hook) - ->unmorph - # only called if morph worked + ->unmorph (hook) # ->fixup_before_unmorph if blessed to current package # exit loop if ->run_step returned true (page printed) @@ -282,8 +280,8 @@ during the run_step hook. # merge form, base, common, swap, and errors into merged swap ->print (hook - passed current step, merged swap hash, and merged fill) ->file_print (hook - uses base_dir_rel, name_module, name_step, ext_print) - ->swap_template (hook - processes the file with CGI::Ex::Template) - ->template_args (hook - passed to CGI::Ex::Template->new) + ->swap_template (hook - processes the file with Template::Alloy) + ->template_args (hook - passed to Template::Alloy->new) ->fill_template (hook - fills the any forms with CGI::Ex::Fill) ->fill_args (hook - passed to CGI::Ex::Fill::fill) ->print_out (hook - print headers and the content to STDOUT) @@ -529,11 +527,11 @@ filling. See the hash_base, hash_common, hash_form, hash_swap, hash_errors, swap_template, and template_args hooks for more information. -The default template engine used is CGI::Ex::Template which is now a subclass -of Template::Alloy. The default interface used is TT which is the -Template::Toolkit interface. Template::Alloy allows for using TT documents, -HTML::Template documents, HTML::Template::Expr documents, Text::Tmpl documents, -or Velocity (VTL) documents. See the L documentation +The default template engine used is Template::Alloy. The default +interface used is TT which is the Template::Toolkit interface. +Template::Alloy allows for using TT documents, HTML::Template +documents, HTML::Template::Expr documents, Text::Tmpl documents, or +Velocity (VTL) documents. See the L documentation for more information. =head1 ADDING ADDITIONAL FORM FILL VARIABLES @@ -843,7 +841,7 @@ completed (various methods determine the definition of "completed"). This preset type of path can also be automated using the CGI::Path module. Rather than using a preset path, CGI::Ex::App also has methods that allow for dynamic changing of the path, so that each step -can determine which step to do next (see the jump, append_path, +can determine which step to do next (see the goto_step, append_path, insert_path, and replace_path methods). During development it would be nice to see what happened during the @@ -989,16 +987,27 @@ object into another package. Default is false. It is passed a single argument of the current step. For more granularity, if true value is a hash, the step being morphed to must be in the hash. +If the returned value is "1", and the module doesn't exist, then the +App will continue to run blessed into the current package. If there +is an error requiring the module or if the module doesn't exist and +the return value is "2" (true but not 1), then App will die with the +appropriate error. + To enable morphing for all steps, add the following: +(Packages that don't exists won't be morphed to) sub allow_morph { 1 } +To force morphing for all steps add the following: + + sub allow_morph { 2 } + To enable morph on specific steps, do either of the following: sub allow_morph { return { edit => 1, - delete => 1, + delete => 2, # must morph }; } @@ -1006,22 +1015,13 @@ To enable morph on specific steps, do either of the following: sub allow_morph { my ($self, $step) = @_; - return $step =~ /^(edit|delete)$/; + return 1 if $step eq 'edit'; + return 2 if $step eq 'delete'; + return; } See the morph "hook" for more information. -=item allow_nested_morph (method) - -Similar to the allow_morph hook, but allows for one more level of morphing. -This is useful in cases where the base class was morphed early on, or -if a step needs to call a sub-step but morph first. - -See the allow_morph and the morph method for more information. - -Should return a boolean value or hash of allowed steps - just as the -allow_morph method does. - =item append_path (method) Arguments are the steps to append. Can be called any time. Adds more @@ -1284,7 +1284,7 @@ using it on a regular basis. Essentially it is a "goto" that allows for a long jump to the end of all nav_loops (even if they are recursively nested). This effectively short circuits all remaining hooks for the current and remaining steps. It is used to allow the -->jump functionality. If the application has morphed, it will be +->goto_step functionality. If the application has morphed, it will be unmorphed before returning. Also - the post_navigate method will still be called. @@ -1491,6 +1491,63 @@ Full customization of the login process and the login template can be done via the auth_args hash. See the auth_args method and CGI::Ex::Auth perldoc for more information. +=item goto_step (method) + +This method is not normally used but can solve some difficult issues. +It provides for moving to another step at any point during the +nav_loop. Once a goto_step has been called, the entire nav_loop will +be exited (to simply replace a portion of a step, you can simply +run_hook('run_step', 'other_step')). The method goto_step effectively +short circuits the remaining hooks for the current step. It does +increment the recursion counter (which has a limit of ->recurse_limit +- default 15). Normally you would allow the other hooks in the loop +to carry on their normal functions and avoid goto_step. (Essentially, +this hook behaves like a goto method to bypass everything else and +continue at a different location in the path - there are times when it +is necessary or useful to do this). + +The method jump is an alias for this method. + +Goto_step takes a single argument which is the location in the path to +jump to. This argument may be either a step name, the special strings +"FIRST, LAST, CURRENT, PREVIOUS, OR NEXT" or the number of steps to +jump forward (or backward) in the path. The default value, 1, +indicates that CGI::Ex::App should jump to the next step (the default +action for goto_step). A value of 0 would repeat the current step +(watch out for recursion). A value of -1 would jump to the previous +step. The special value of "LAST" will jump to the last step. The +special value of "FIRST" will jump back to the first step. In each of +these cases, the path array returned by ->path is modified to allow +for the jumping (the path is modified so that the path history is not +destroyed - if we were on step 3 and jumped to one, that path would +contain 1, 2, 3, *1, 2, 3, 4, etc and we would be at the *). If a +step name is not currently on the path, it will be replace any remaining +steps of the path. + + # goto previous step (repeat it) + $self->goto_step($self->previous_step); + $self->goto_step('PREVIOUS'); + $self->goto_step(-1); + + # goto next step + $self->goto_step($self->next_step); + $self->goto_step('NEXT'); + $self->goto_step(1); + $self->goto_step; + + # goto current step (repeat) + $self->goto_step($self->current_step); + $self->goto_step('CURRENT'); + $self->goto_step(0); + + # goto last step + $self->goto_step($self->last_step); + $self->goto_step('LAST'); + + # goto first step (repeat it) + $self->goto_step($self->first_step); + $self->goto_step('FIRST'); + =item handle_error (method) If anything dies during execution, handle_error will be called with @@ -1649,76 +1706,24 @@ default "path" handler. =item js_validation (hook) -Requires JSON or YAML. Will return Javascript that is capable of -validating the form. This is done using the capabilities of -CGI::Ex::Validate. This will call the hook hash_validation which will -then be encoded either json or into yaml and placed in a javascript -string. It will also call the hook form_name to determine which html -form to attach the validation to. The method js_uri_path is called to -determine the path to the appropriate validate.js files. If the -method ext_val is htm, then js_validation will return an empty string -as it assumes the htm file will take care of the validation itself. -In order to make use of js_validation, it must be added to the -variables returned by either the hash_base, hash_common, hash_swap or -hash_form hook (see examples of hash_base used in this doc). - -By default it will try and use JSON first and then fail to YAML and -then will fail to returning an html comment that does nothing. +Will return Javascript that is capable of validating the form. This +is done using the capabilities of CGI::Ex::Validate and +CGI::Ex::JSONDump. This will call the hook hash_validation which will +then be encoded into json and placed in a javascript string. It will +also call the hook form_name to determine which html form to attach +the validation to. The method js_uri_path is called to determine the +path to the appropriate validate.js files. In order to make use of +js_validation, it must be added to the variables returned by either +the hash_base (default), hash_common, hash_swap or hash_form hook (see +examples of hash_base used in this doc). =item jump (method) -This method should not normally be used but is fine to use it on a -regular basis. It provides for moving to the next step at any point -during the nav_loop. It effectively short circuits the remaining -hooks for the current step. It does increment the recursion counter -(which has a limit of ->recurse_limit - default 15). It is normally -better to allow the other hooks in the loop to carry on their normal -functions and avoid jumping. (Essentially, this hook behaves like a -goto method to bypass everything else and continue at a different -location in the path - there are times when it is necessary or useful -to do this). - -Jump takes a single argument which is the location in the path to jump -to. This argument may be either a step name, the special strings -"FIRST, LAST, CURRENT, PREVIOUS, OR NEXT" or the number of steps to -jump forward (or backward) in the path. The default value, 1, -indicates that CGI::Ex::App should jump to the next step (the default -action for jump). A value of 0 would repeat the current step (watch -out for recursion). A value of -1 would jump to the previous step. -The special value of "LAST" will jump to the last step. The special -value of "FIRST" will jump back to the first step. In each of these -cases, the path array returned by ->path is modified to allow for the -jumping (the path is modified so that the path history is not destroyed -- if we were on step 3 and jumped to one, that path would contain -1, 2, 3, *1, 2, 3, 4, etc and we would be at the *). - - ### goto previous step - $self->jump($self->previous_step); - $self->jump('PREVIOUS'); - $self->jump(-1); - - ### goto next step - $self->jump($self->next_step); - $self->jump('NEXT'); - $self->jump(1); - $self->jump; - - ### goto current step (repeat) - $self->jump($self->current_step); - $self->jump('CURRENT'); - $self->jump(0); - - ### goto last step - $self->jump($self->last_step); - $self->jump('LAST'); - - ### goto first step - $self->jump($self->first_step); - $self->jump('FIRST'); +Alias for the goto_step method. =item last_step (method) -Returns the last step of the path. Can be used to jump to the last step. +Returns the last step of the path. =item load_conf (method) @@ -1741,9 +1746,9 @@ the step name to allow_morph. The morph call occurs at the beginning of the step loop. A corresponding unmorph call occurs before the loop is exited. An -object can morph several levels deep if allow_nested_morph returns -true. For example, an object running as Foo::Bar that is looping on -the step "my_step" that has allow_morph = 1, will do the following: +object can morph several levels deep. For example, an object running +as Foo::Bar that is looping on the step "my_step" that has allow_morph += 1, will do the following: Call the morph_package hook (which would default to returning Foo::Bar::MyStep in this case) @@ -1761,58 +1766,12 @@ re-blesses the object into the original package. Samples of allowing morph: - sub allow_morph { 1 } + sub allow_morph { 1 } # value of 1 means try to find package, ok if not found sub allow_morph { {edit => 1} } sub allow_morph { my ($self, $step) = @_; return $step eq 'edit' } -It is possible to call morph earlier on in the program. An example of -a useful early use of morph would be as in the following code: - - sub allow_morph { 1 } - - sub pre_navigate { - my $self = shift; - if ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ s|^/(\w+)||) { - my $step = $1; - $self->morph($step); - $ENV{'PATH_INFO'} = "/$step"; - $self->stash->{'base_morphed'} = 1; - } - return 0; - } - - sub post_navigate { - my $self = shift; - $self->unmorph if $self->stash->{'base_morphed'}; - } - -If this code was in a module Base.pm and the cgi running was cgi/base -and called: - - Base->navigate; - -and you created a sub module that inherited Base.pm called -Base/Ball.pm -- you could then access it using cgi/base/ball. You -would be able to pass it steps using either cgi/base/ball/step_name or -cgi/base/ball?step=step_name - Or Base/Ball.pm could implement its -own path. It should be noted that if you do an early morph, it is -suggested to provide a call to unmorph. And if you want to let your -early morphed object morph again - you will need to provide - - sub allow_nested_morph { 1 } - -With allow_nested_morph enabled you could create the file -Base/Ball/StepName.pm which inherits Base/Ball.pm. The Base.pm, with -the custom init and default path method, would automatically morph us -first into a Base::Ball object (during init) and then into a -Base::Ball::StepName object (during the navigation loop). - -Since it is complicated to explain - it may be a bit complicated to -those who will try to follow your code later. CGI::Ex::App provides -many ways to do things, but use the best one for your situation. - =item morph_package (hook) Used by morph. Return the package name to morph into during a morph @@ -1892,11 +1851,8 @@ object has been blessed to allow for any other initilizations. =item next_step (hook and method) -Returns the next step in the path. If there is no next step, it -returns the default_step. - -It can be used as a method to return the next step in the path -to pass to a method such as ->jump. +As a method it returns the next step in the path - if the path +has more steps left. It is also used as a hook by the refine_path hook. If there is no more steps, it will call the next_step hook to try and find a step to @@ -2072,11 +2028,10 @@ List the step previous to this one. Will return '' if there is no previous step Take the information generated by prepared_print, format it using swap_template, fill it using fill_template and print it out using -print_out. Default incarnation uses CGI::Ex::Template (a subclass of -Template::Alloy) which is compatible with Template::Toolkit to do the -swapping. Arguments are: step name (used to call the file_print -hook), swap hashref (passed to call swap_template), and fill hashref -(passed to fill_template). +print_out. Default incarnation uses Template::Alloy which is +compatible with Template::Toolkit to do the swapping. Arguments are: +step name (used to call the file_print hook), swap hashref (passed to +call swap_template), and fill hashref (passed to fill_template). During the print call, the file_print hook is called which should return a filename or a scalar reference to the template content is @@ -2130,11 +2085,11 @@ go to the _edit_success step. =item recurse_limit (method) Default 15. Maximum number of times to allow nav_loop to call itself. -The recurse level will increase every time that ->jump is called, or if +The recurse level will increase every time that ->goto_step is called, or if the end of the nav_loop is reached and the process tries to add the default_step and run it again. -If ->jump is used often - the recurse_limit will be reached more +If ->goto_step is used often - the recurse_limit will be reached more quickly. It is safe to raise this as high as is necessary - so long as it is intentional. @@ -2263,6 +2218,21 @@ run_hook, it is possible to logically override methods on a step by step basis, or override a method for all of the steps, or even to break code out into separate modules. +=item run_hook_as (method) + +Similar to run_hook - but allows for temporarily running a +hook in another package. + + sub blah_morph_package { 'SomeOther::Module' } + my $hash = $self->run_hook_as('hash_swap', 'blah'); # runs as SomeOther::Module + + # OR + + my $hash = $self->run_hook_as('hash_swap', 'SomeOther::Module'); + +Note that the second form will use 'SomeOther::Module' as the step name +which will be somewhat misleading in looking up names. + =item run_step (hook) Runs all of the hooks specific to each step, beginning with pre_step @@ -2337,8 +2307,7 @@ method to look for in the form. Default value is 'step'. =item swap_template (hook) Takes the template and hash of variables prepared in print, and -processes them through the current template engine (default engine is -CGI::Ex::Template a subclass of Template::Alloy). +processes them through the current template engine Template::Alloy. Arguments are the template and the swap hashref. The template can be either a scalar reference to the actual content, or the filename of @@ -2349,7 +2318,7 @@ default). The default method will create a template object by calling the template_args hook and passing the returned hashref to the template_obj method. The default template_obj method returns a -CGI::Ex::Template object, but could easily be swapped to use a +Template::Alloy object, but could easily be swapped to use a Template::Toolkit based object. If a non-Template::Toolkit compatible object is to be used, then the swap_template hook can be overridden to use another templating engine. @@ -2378,8 +2347,8 @@ method as follows: return $t->output; } -As of version 2.13 of CGI::Ex::Template you could also simply do the -following to parse the templates using HTML::Template::Expr syntax. +Uou could also simply do the following to parse the templates using +HTML::Template::Expr syntax. sub template_args { return {SYNTAX => 'hte'}; @@ -2389,12 +2358,12 @@ For a listing of the available syntaxes, see the current L docu =item template_args (hook) -Returns a hashref of args that will be passed to the "new" method of CGI::Ex::Template. +Returns a hashref of args that will be passed to the "new" method of Template::Alloy The method is normally called from the swap_template hook. The swap_template hook will add a value for INCLUDE_PATH which is set equal to template_path, if the INCLUDE_PATH value is not already set. -The returned hashref can contain any arguments that CGI::Ex::Template (a subclass of Template::Alloy) +The returned hashref can contain any arguments that Template::Alloy would understand. sub template_args { @@ -2409,10 +2378,9 @@ See the L documentation for a listing of all possible configura =item template_obj (method) Called from swap_template. It is passed the result of template_args -that have had a default INCLUDE_PATH added via template_path. The default -implementation uses CGI::Ex::Template (a subclass of Template::Alloy) -but can easily be changed to use Template::Toolkit by using code -similar to the following: +that have had a default INCLUDE_PATH added via template_path. The +default implementation uses Template::Alloy but can easily be changed +to use Template::Toolkit by using code similar to the following: use Template; @@ -2587,8 +2555,7 @@ different. Seemingly the most well know of application builders. CGI::Ex::App is different in that it: - * Uses Template::Toolkit compatible CGI::Ex::Template (a - subclass of Template::Alloy) by default. + * Uses Template::Toolkit compatible Template::Alloy by default. CGI::Ex::App can easily use another toolkit by simply overriding the ->swap_template method. CGI::Application uses HTML::Template. @@ -2622,7 +2589,7 @@ There are actually many similarities. One of the nicest things about CGI::Prototype is that it is extremely short (very very short). The ->activate starts the application in the same manner as CGI::Ex::App's ->navigate call. Both use Template::Toolkit as the default template -system (CGI::Ex::App uses CGI::Ex::Template which is TT compatible). +system (CGI::Ex::App uses Template::Alloy which is TT compatible). CGI::Ex::App is differrent in that it: * Offers more hooks into the various phases of each step. diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 38797d7..9abb831 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -17,15 +17,16 @@ use vars qw($VERSION); use MIME::Base64 qw(encode_base64 decode_base64); use Digest::MD5 qw(md5_hex); use CGI::Ex; +use Carp qw(croak); -$VERSION = '2.24'; +$VERSION = '2.27'; ###----------------------------------------------------------------### sub new { - my $class = shift || __PACKAGE__; - my $args = shift || {}; - return bless {%$args}, $class; + my $class = shift || croak "Usage: ".__PACKAGE__."->new"; + my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_}; + return bless {%$self}, $class; } sub get_valid_auth { @@ -33,7 +34,7 @@ sub get_valid_auth { $self = $self->new(@_) if ! ref $self; delete $self->{'_last_auth_data'}; - ### shortcut that will print a js file as needed (such as the md5.js) + # shortcut that will print a js file as needed (such as the md5.js) if ($self->script_name . $self->path_info eq $self->js_uri_path . "/CGI/Ex/md5.js") { $self->cgix->print_js('CGI/Ex/md5.js'); eval { die "Printed Javascript" }; @@ -42,7 +43,7 @@ sub get_valid_auth { my $form = $self->form; - ### allow for logout + # allow for logout if ($form->{$self->key_logout} && ! $self->{'_logout_looking_for_user'}) { local $self->{'_logout_looking_for_user'} = 1; local $self->{'no_set_cookie'} = 1; @@ -65,64 +66,65 @@ sub get_valid_auth { } } - ### look first in form, then in cookies for valid tokens - my $had_form_data; - foreach ([$form, $self->key_user, 1], - [$self->cookies, $self->key_cookie, 0], - ) { - my ($hash, $key, $is_form) = @$_; - next if ! defined $hash->{$key}; - last if ! $is_form && $had_form_data; # if form info was passed in - we must use it only - $had_form_data = 1 if $is_form; - next if ! length $hash->{$key}; - - ### if it looks like a bare username (as in they didn't have javascript) - add in other items - my $data; - if ($is_form && delete $form->{$self->key_loggedout}) { # don't validate the form on a logout - my $key_u = $self->key_user; - $self->new_auth_data({user => delete($form->{$key_u})}); - $had_form_data = 0; - next; - } elsif ($is_form - && $hash->{$key} !~ m|^[^/]+/| # looks like a cram token - && defined $hash->{ $self->key_pass }) { + my $data; + + # look in form first + my $form_user = delete $form->{$self->key_user}; + if (defined $form_user) { + if (delete $form->{$self->key_loggedout}) { # don't validate the form on a logout + $data = $self->new_auth_data({user => $form_user, error => 'Logged out'}); + } elsif (defined $form->{ $self->key_pass }) { $data = $self->verify_token({ token => { - user => delete $hash->{$key}, - test_pass => delete $hash->{ $self->key_pass }, - expires_min => delete($hash->{ $self->key_save }) ? -1 : delete($hash->{ $self->key_expires_min }) || $self->expires_min, + user => $form_user, + test_pass => delete $form->{ $self->key_pass }, + expires_min => delete($form->{ $self->key_save }) ? -1 : delete($form->{ $self->key_expires_min }) || undef, }, from => 'form', - }) || next; - + }); + } elsif (! length $form_user) { + $data = $self->new_auth_data({user => '', error => 'Invalid user'}); } else { - $data = $self->verify_token({token => $hash->{$key}, from => ($is_form ? 'form' : 'cookie')}) || next; - delete $hash->{$key} if $is_form; + $data = $self->verify_token({token => $form_user, from => 'form'}); } + } - ### generate a fresh cookie if they submitted info on plaintext types - if ($is_form - && ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt'))) { - $self->set_cookie({ - key => $self->key_cookie, - val => $self->generate_token($data), - no_expires => ($data->{ $self->key_save } ? 0 : 1), # make it a session cookie unless they ask for saving - }); - - ### always generate a cookie on types that have expiration - } else { - $self->set_cookie({ - key => $self->key_cookie, - val => $self->generate_token($data), - no_expires => 0, - }); + # no valid form data ? look in the cookie + if (! ref($data) # no form + || ($data->error && $data->{'allow_cookie_match'})) { # had form with error - but we can check if form user matches existing cookie + my $cookie = $self->cookies->{$self->key_cookie}; + if (defined($cookie) && length($cookie)) { + my $form_data = $data; + $data = $self->verify_token({token => $cookie, from => 'cookie'}); + if (defined $form_user) { # they had form data + my $user = $self->cleanup_user($form_user); + if (! $data || $user ne $data->{'user'}) { # but the cookie didn't match + $data = $self->{'_last_auth_data'} = $form_data; # restore old form data failure + $data->{'user'} = $user if ! defined $data->{'user'}; + } + } } + } + + # failure + if (! $data) { + return $self->handle_failure({had_form_data => defined($form_user)}); + } - ### successful login - return $self->handle_success({is_form => $is_form}); + # success + my $_key = $self->key_cookie; + my $_val = $self->generate_token($data); + my $use_session = $self->use_session_cookie($_key, $_val); # default false + if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) { + $use_session = 1 if ! defined($use_session) && ! defined($data->{'expires_min'}); } + $self->set_cookie({ + name => $_key, + value => $_val, + expires => ($use_session ? '' : '+20y'), # non-cram cookie types are session cookies unless save was set (thus setting expires_min) + }); - return $self->handle_failure({had_form_data => $had_form_data}); + return $self->handle_success({is_form => ($data->{'from'} eq 'form' ? 1 : 0)}); } sub handle_success { @@ -133,18 +135,18 @@ sub handle_success { } my $form = $self->form; - ### bounce to redirect + # bounce to redirect if (my $redirect = $form->{ $self->key_redirect }) { $self->location_bounce($redirect); eval { die "Success login - bouncing to redirect" }; return; - ### if they have cookies we are done + # if they have cookies we are done } elsif (scalar(keys %{$self->cookies}) || $self->no_cookie_verify) { $self->success_hook; return $self; - ### need to verify cookies are set-able + # need to verify cookies are set-able } elsif ($args->{'is_form'}) { $form->{$self->key_verify} = $self->server_time; my $url = $self->script_name . $self->path_info . "?". $self->cgix->make_form($form); @@ -179,11 +181,11 @@ sub handle_failure { } my $form = $self->form; - ### make sure the cookie is gone + # make sure the cookie is gone my $key_c = $self->key_cookie; - $self->delete_cookie({key => $key_c}) if $self->cookies->{$key_c}; + $self->delete_cookie({name => $key_c}) if $self->cookies->{$key_c}; - ### no valid login and we are checking for cookies - see if they have cookies + # no valid login and we are checking for cookies - see if they have cookies if (my $value = delete $form->{$self->key_verify}) { if (abs(time() - $value) < 15) { $self->no_cookies_print; @@ -191,7 +193,7 @@ sub handle_failure { } } - ### oh - you're still here - well then - ask for login credentials + # oh - you're still here - well then - ask for login credentials my $key_r = $self->key_redirect; local $form->{$key_r} = $form->{$key_r} || $self->script_name . $self->path_info . (scalar(keys %$form) ? "?".$self->cgix->make_form($form) : ''); local $form->{'had_form_data'} = $args->{'had_form_data'} || 0; @@ -199,7 +201,7 @@ sub handle_failure { my $data = $self->last_auth_data; eval { die defined($data) ? $data : "Requesting credentials" }; - ### allow for a sleep to help prevent brute force + # allow for a sleep to help prevent brute force sleep($self->failed_sleep) if defined($data) && $data->error ne 'Login expired' && $self->failed_sleep; $self->failure_hook; @@ -226,7 +228,7 @@ sub check_valid_auth { ###----------------------------------------------------------------### -sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME" } +sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || '' } sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' } @@ -254,27 +256,25 @@ sub delete_cookie { my $self = shift; my $args = shift; return $self->{'delete_cookie'}->($self, $args) if $self->{'delete_cookie'}; - my $key = $args->{'key'}; - $self->cgix->set_cookie({ - -name => $key, - -value => '', - -expires => '-10y', - -path => '/', - }); - delete $self->cookies->{$key}; + local $args->{'value'} = ''; + local $args->{'expires'} = '-10y' if ! $self->use_session_cookie($args->{'name'}, ''); + $self->set_cookie($args); + delete $self->cookies->{$args->{'name'}}; } sub set_cookie { my $self = shift; my $args = shift; return $self->{'set_cookie'}->($self, $args) if $self->{'set_cookie'}; - my $key = $args->{'key'}; - my $val = $args->{'val'}; + my $key = $args->{'name'}; + my $val = $args->{'value'}; + my $dom = $args->{'domain'} || $self->cookie_domain; $self->cgix->set_cookie({ -name => $key, -value => $val, - ($args->{'no_expires'} ? () : (-expires => '+20y')), # let the expires time take care of things for types that self expire - -path => '/', + -path => $args->{'path'} || $self->cookie_path($key, $val) || '/', + ($dom ? (-domain => $dom) : ()), + ($args->{'expires'} ? (-expires => $args->{'expires'}): ()), }); $self->cookies->{$key} = $val; } @@ -309,6 +309,9 @@ sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} || sub use_base64 { my $s = shift; $s->{'use_base64'} = 1 if ! defined $s->{'use_base64'}; $s->{'use_base64'} } sub expires_min { my $s = shift; $s->{'expires_min'} = 6 * 60 if ! defined $s->{'expires_min'}; $s->{'expires_min'} } sub failed_sleep { shift->{'failed_sleep'} ||= 0 } +sub cookie_path { shift->{'cookie_path'} } +sub cookie_domain { shift->{'cookie_domain'} } +sub use_session_cookie { shift->{'use_session_cookie'} } sub disable_simple_cram { shift->{'disable_simple_cram'} } sub logout_redirect { @@ -375,7 +378,8 @@ sub template_include_path { $_[0]->{'template_include_path'} || '' } sub login_hash_common { my $self = shift; my $form = $self->form; - my $data = $self->last_auth_data || {}; + my $data = $self->last_auth_data; + $data = {no_data => 1} if ! ref $data; return { %$form, @@ -408,41 +412,46 @@ sub login_hash_common { sub verify_token { my $self = shift; my $args = shift; + if (my $meth = $self->{'verify_token'}) { + return $meth->($self, $args); + } my $token = delete $args->{'token'}; die "Missing token" if ! length $token; my $data = $self->new_auth_data({token => $token, %$args}); my $meth; - ### make sure the token is parsed to usable data + # make sure the token is parsed to usable data if (ref $token) { # token already parsed $data->add_data({%$token, armor => 'none'}); } elsif (my $meth = $self->{'parse_token'}) { if (! $meth->($self, $args)) { $data->error('Invalid custom parsed token') if ! $data->error; # add error if not already added + $data->{'allow_cookie_match'} = 1; return $data; } } else { if (! $self->parse_token($token, $data)) { $data->error('Invalid token') if ! $data->error; # add error if not already added + $data->{'allow_cookie_match'} = 1; return $data; } } - ### verify the user + # verify the user if (! defined($data->{'user'})) { $data->error('Missing user'); - + } elsif (! defined($data->{'user'} = $self->cleanup_user($data->{'user'})) + || ! length($data->{'user'})) { + $data->error('Missing cleaned user'); } elsif (! defined $data->{'test_pass'}) { $data->error('Missing test_pass'); - - } elsif (! $self->verify_user($data->{'user'} = $self->cleanup_user($data->{'user'}))) { + } elsif (! $self->verify_user($data->{'user'})) { $data->error('Invalid user'); - } return $data if $data->error; - ### get the pass + # get the pass my $pass; if (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) { $data->add_data({details => $@}); @@ -459,7 +468,7 @@ sub verify_token { $data->add_data({real_pass => $pass}); # store - to allow generate_token to not need to relookup the pass - ### validate the pass + # validate the pass if ($meth = $self->{'verify_password'}) { if (! $meth->($self, $pass, $data)) { $data->error('Password failed verification') if ! $data->error; @@ -472,7 +481,7 @@ sub verify_token { return $data if $data->error; - ### validate the payload + # validate the payload if ($meth = $self->{'verify_payload'}) { if (! $meth->($self, $data->{'payload'}, $data)) { $data->error('Payload failed custom verification') if ! $data->error; @@ -494,11 +503,11 @@ sub new_auth_data { sub parse_token { my ($self, $token, $data) = @_; my $found; - my $key; - for my $armor ('none', 'base64', 'blowfish') { # try with and without base64 encoding - my $copy = ($armor eq 'none') ? $token - : ($armor eq 'base64') ? eval { local $^W; decode_base64($token) } - : ($key = $self->use_blowfish) ? decrypt_blowfish($token, $key) + my $bkey; + for my $armor ('none', 'base64', 'blowfish') { + my $copy = ($armor eq 'none') ? $token + : ($armor eq 'base64') ? eval { local $^W; decode_base64($token) } + : ($bkey = $self->use_blowfish) ? decrypt_blowfish($token, $bkey) : next; if ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / (.*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) { $data->add_data({ @@ -598,7 +607,7 @@ sub generate_token { my $self = shift; my $data = shift || $self->last_auth_data; die "Can't generate a token off of a failed auth" if ! $data; - + die "Can't generate a token for a user which contains a \"/\"" if $data->{'user'} =~ m{/}; my $token; ### do kinds that require staying plaintext @@ -725,58 +734,48 @@ sub login_template { my $self = shift; return $self->{'login_template'} if $self->{'login_template'}; - my $text = "" - . $self->login_header - . $self->login_form - . $self->login_script - . $self->login_footer; + my $text = join '', + map {ref $_ ? $$_ : /\[%/ ? $_ : $_ ? "[% TRY; PROCESS '$_'; CATCH %][% END %]\n" : ''} + $self->login_header, $self->login_form, $self->login_script, $self->login_footer; return \$text; } -sub login_header { - return shift->{'login_header'} || q { - [%~ TRY ; PROCESS 'login_header.tt' ; CATCH %][% END ~%] - }; -} - -sub login_footer { - return shift->{'login_footer'} || q { - [%~ TRY ; PROCESS 'login_footer.tt' ; CATCH %][% END ~%] - }; -} +sub login_header { shift->{'login_header'} || 'login_header.tt' } +sub login_footer { shift->{'login_footer'} || 'login_footer.tt' } sub login_form { - return shift->{'login_form'} || q { - + my $self = shift; + return $self->{'login_form'} if defined $self->{'login_form'}; + return \q{ }; } @@ -788,33 +787,32 @@ sub text_submit { my $self = shift; return defined($self->{'text_submit'}) ? $se sub login_script { my $self = shift; - return $self->{'login_script'} if $self->{'login_script'}; + return $self->{'login_script'} if defined $self->{'login_script'}; return '' if $self->use_plaintext || $self->disable_simple_cram; - return q { -
- -
- - - }; + return \q{
+ +
+ + +}; } ###----------------------------------------------------------------### @@ -905,23 +903,26 @@ For the stored cookie you can choose to use simple cram mechanisms, secure hash cram tokens, auto expiring logins (not cookie based), and Crypt::Blowfish protection. You can also choose to keep passwords plaintext and to use perl's crypt for testing -passwords. +passwords. Or you can completely replace the cookie parsing/generating +and let Auth handle requesting, setting, and storing the cookie. 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. +request (any authenticated area has to verify authentication each time +- unless the verify_token method is completely overridden). 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. +to use https - but even then you need to guard the logged in area +against cross-site javascript exploits. A discussion of all security +issues is far beyond the scope of this documentation. =head1 METHODS @@ -946,6 +947,8 @@ described separately. cgix cleanup_user + cookie_domain + cookie_path cookies expires_min form @@ -989,6 +992,8 @@ described separately. use_blowfish use_crypt use_plaintext + use_session_cookie + verify_token verify_payload verify_user diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 1288e7b..0fd0199 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.24'; +$VERSION = '2.27'; $DEFAULT_EXT = 'conf'; @@ -263,7 +263,8 @@ sub read_handler_json { CORE::read(IN, my $text, -s $file); close IN; require JSON; - return scalar JSON::jsonToObj($text); + my $decode = JSON->VERSION > 1.98 ? 'decode' : 'jsonToObj'; + return scalar JSON->new->$decode($text); } sub read_handler_storable { @@ -545,7 +546,15 @@ sub write_handler_json { my $file = shift; my $ref = shift; require JSON; - my $str = JSON::objToJson($ref, {pretty => 1, indent => 2}); + my $str; + if (JSON->VERSION > 1.98) { + my $j = JSON->new; + $j->canonical(1); + $j->pretty; + $str = $j->encode($ref); + } else { + $str = JSON->new->objToJSon($ref, {pretty => 1, indent => 2}); + } local *OUT; open (OUT, ">$file") || die $!; print OUT $str; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index c6d6984..c3ef904 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.24'; + $VERSION = '2.27'; $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 9025c4f..1ccf507 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.24'; +$VERSION = '2.27'; @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 1f94d8d..2eaffa4 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.24'; + $VERSION = '2.27'; @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 c08f496..07ce9e9 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.24'; + $VERSION = '2.27'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; @@ -75,7 +75,7 @@ sub _dump { return "{}" if ! @keys; return "{$self->{hash_nl}${prefix}$self->{indent}" . join(",$self->{hash_nl}${prefix}$self->{indent}", - map { $self->js_escape($_, "${prefix}$self->{indent}") + map { $self->js_escape($_, "${prefix}$self->{indent}", 1) . $self->{'hash_sep'} . $self->_dump($data->{$_}, "${prefix}$self->{indent}") } @keys) @@ -99,11 +99,11 @@ sub _dump { } sub js_escape { - my ($self, $str, $prefix) = @_; + my ($self, $str, $prefix, $no_num) = @_; return 'null' if ! defined $str; ### allow things that look like numbers to show up as numbers (and those that aren't quite to not) - return $str if $str =~ /^ -? (?: [1-9][0-9]{0,12} | 0) (?: \. \d* [1-9])? $/x; + return $str if ! $no_num && $str =~ /^ -? (?: [1-9][0-9]{0,12} | 0) (?: \. \d* [1-9])? $/x; my $quote = $self->{'single_quote'} ? "'" : '"'; @@ -142,11 +142,11 @@ __END__ use CGI::Ex::JSONDump; - my $js = JSONDump(\%complex_data, {pretty => 0}); + my $js = JSONDump(\%complex_data, {pretty => 1}); ### OR - my $js = CGI::Ex::JSONDump->new({pretty => 0})->dump(\%complex_data); + my $js = CGI::Ex::JSONDump->new({pretty => 1})->dump(\%complex_data); =head1 DESCRIPTION diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 97d29bc..b92ec92 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -25,7 +25,7 @@ use vars qw($VERSION $VOBJS ); -$VERSION = '2.24'; +$VERSION = '2.27'; ### 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 eadc981..184327b 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -1,132 +1,46 @@ package CGI::Ex::Validate; -=head1 NAME - -CGI::Ex::Validate - The "Just Right" form validator with javascript in parallel - -=cut - -###----------------------------------------------------------------### -# Copyright 2007 - Paul Seamons # -# Distributed under the Perl Artistic License without warranty # -###----------------------------------------------------------------### +###---------------------### +# See the perldoc in CGI/Ex/Validate.pod +# Copyright 2008 - Paul Seamons +# Distributed under the Perl Artistic License without warranty use strict; -use vars qw($VERSION - $DEFAULT_EXT - %DEFAULT_OPTIONS - $JS_URI_PATH - $JS_URI_PATH_YAML - $JS_URI_PATH_VALIDATE - $QR_EXTRA - @UNSUPPORTED_BROWSERS - ); - -$VERSION = '2.24'; +use Carp qw(croak); -$DEFAULT_EXT = 'val'; -$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; -@UNSUPPORTED_BROWSERS = (qr/MSIE\s+5.0\d/i); - -###----------------------------------------------------------------### +our $VERSION = '2.27'; +our $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; +our @UNSUPPORTED_BROWSERS = (qr/MSIE\s+5.0\d/i); +our $JS_URI_PATH; +our $JS_URI_PATH_VALIDATE; sub new { - my $class = shift; - my $self = ref($_[0]) ? shift : {@_}; - - $self = {%DEFAULT_OPTIONS, %$self} if scalar keys %DEFAULT_OPTIONS; - - return bless $self, $class; + my $class = shift || croak "Usage: ".__PACKAGE__."->new"; + my $self = ref($_[0]) ? shift : {@_}; + return bless $self, $class; } -###----------------------------------------------------------------### - -sub cgix { - my $self = shift; - return $self->{'cgix'} ||= do { - require CGI::Ex; - CGI::Ex->new; - }; -} +sub cgix { shift->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } } -### the main validation routine sub validate { - my $self = (! ref($_[0])) ? shift->new # $class->validate - : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate - : __PACKAGE__->new; # &validate - my $form = shift || die "Missing form hash"; - my $val_hash = shift || die "Missing validation hash"; - my $what_was_validated = shift; # allow for extra arrayref that stores what was validated - - ### turn the form into a form hash if doesn't look like one already - die "Invalid form hash or cgi object" if ! ref $form; - if (ref $form ne 'HASH') { - local $self->{cgi_object} = $form; - $form = $self->cgix->get_form($form); - } - - ### make sure the validation is a hashref - ### get_validation handle odd types - if (ref $val_hash ne 'HASH') { - $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash; - die "Validation groups must be a hashref" if ref $val_hash ne 'HASH'; - } - - ### parse keys that are group arguments - and those that are keys to validate - my %ARGS; - my @field_keys = grep { /^(?:group|general)\s+(\w+)/ - ? do {$ARGS{$1} = $val_hash->{$_} ; 0} - : 1 } - sort keys %$val_hash; - - ### only validate this group if it is supposed to be checked - return if $ARGS{'validate_if'} && ! $self->check_conditional($form, $ARGS{'validate_if'}); + my $self = (! ref($_[0])) ? shift->new # $class->validate + : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate + : __PACKAGE__->new; # CGI::Ex::Validate::validate + my ($form, $val_hash, $what_was_validated) = @_; - ### Look first for items in 'group fields' or 'group order' - my $fields; - if ($fields = $ARGS{'fields'} || $ARGS{'order'}) { - my $type = $ARGS{'fields'} ? 'group fields' : 'group order'; - die "Validation '$type' must be an arrayref when passed" - if ! UNIVERSAL::isa($fields, 'ARRAY'); - my @temp; - foreach my $field (@$fields) { - die "Non-defined value in '$type'" if ! defined $field; - if (ref $field) { - die "Found nonhashref value in '$type'" if ref($field) ne 'HASH'; - die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'}; - push @temp, $field; - } elsif ($field eq 'OR') { - push @temp, 'OR'; - } else { - die "No element found in '$type' for $field" if ! exists $val_hash->{$field}; - die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH'; - push @temp, { %{ $val_hash->{$field} }, field => $field }; # copy the values to add the key - } - } - $fields = \@temp; + die "Invalid form hash or cgi object" if ! $form || ! ref $form; + $form = $self->cgix->get_form($form) if ref $form ne 'HASH'; - ### limit the keys that need to be searched to those not in fields or order - my %found = map { $_->{'field'} => 1 } @temp; - @field_keys = grep { ! $found{$_} } @field_keys; - } + my ($fields, $ARGS) = $self->get_ordered_fields($val_hash); + return if ! @$fields; - ### add any remaining field_vals from our original hash - ### this is necessary for items that weren't in group fields or group order - foreach my $field (@field_keys) { - die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH'; - if (defined $val_hash->{$field}->{'field'}) { - push @$fields, $val_hash->{$field}; - } else { - push @$fields, { %{$val_hash->{$field}}, field => $field }; - } - } - return if ! $fields; + return if $ARGS->{'validate_if'} && ! $self->check_conditional($form, $ARGS->{'validate_if'}); - ### Finally we have our arrayref of hashrefs that each have their 'field' key - ### now lets do the validation + # Finally we have our arrayref of hashrefs that each have their 'field' key + # now lets do the validation $self->{'was_checked'} = {}; - $self->{'was_valid'} = {}; - $self->{'had_error'} = {}; + $self->{'was_valid'} = {}; + $self->{'had_error'} = {}; my $found = 1; my @errors; my $hold_error; # hold the error for a moment - to allow for an "OR" operation @@ -153,7 +67,7 @@ sub validate { $self->{'was_valid'}->{$field} = 0; } - ### test the error - if errors occur allow for OR - if OR fails use errors from first fail + # test the error - if errors occur allow for OR - if OR fails use errors from first fail if ($err) { $self->{'was_valid'}->{$field} = 0; $self->{'had_error'}->{$field} = 0; @@ -169,27 +83,80 @@ sub validate { } push(@errors, @$hold_error) if $hold_error; # allow for final OR to work - - ### optionally check for unused keys in the form - if ($ARGS{no_extra_fields} || $self->{no_extra_fields}) { - my %keys = map { ($_->{'field'} => 1) } @$fields; # %{ $self->get_validation_keys($val_hash) }; + # optionally check for unused keys in the form + if ($ARGS->{no_extra_fields} || $self->{no_extra_fields}) { + my %keys = map { ($_->{'field'} => 1) } @$fields; foreach my $key (sort keys %$form) { next if $keys{$key}; push @errors, [$key, 'no_extra_fields', {}, undef]; } } - ### return what they want if (@errors) { my @copy = grep {/$QR_EXTRA/o} keys %$self; - @ARGS{@copy} = @{ $self }{@copy}; - unshift @errors, $ARGS{'title'} if $ARGS{'title'}; - my $err_obj = $self->new_error(\@errors, \%ARGS); - die $err_obj if $ARGS{'raise_error'}; + @{ $ARGS }{@copy} = @{ $self }{@copy}; + unshift @errors, $ARGS->{'title'} if $ARGS->{'title'}; + my $err_obj = $self->new_error(\@errors, $ARGS); + die $err_obj if $ARGS->{'raise_error'}; return $err_obj; - } else { - return; } + + return; # success +} + +sub get_ordered_fields { + my ($self, $val_hash) = @_; + + die "Missing validation hash" if ! $val_hash; + if (ref $val_hash ne 'HASH') { + $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash; + die "Validation groups must be a hashref" if ref $val_hash ne 'HASH'; + } + + my %ARGS; + my @field_keys = grep { /^(?:group|general)\s+(\w+)/ + ? do {$ARGS{$1} = $val_hash->{$_} ; 0} + : 1 } sort keys %$val_hash; + + # Look first for items in 'group fields' or 'group order' + my $fields; + if (my $ref = $ARGS{'fields'} || $ARGS{'order'}) { + my $type = $ARGS{'fields'} ? 'group fields' : 'group order'; + die "Validation '$type' must be an arrayref when passed" if ! UNIVERSAL::isa($ref, 'ARRAY'); + foreach my $field (@$ref) { + die "Non-defined value in '$type'" if ! defined $field; + if (ref $field) { + die "Found nonhashref value in '$type'" if ref($field) ne 'HASH'; + die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'}; + push @$fields, $field; + } elsif ($field eq 'OR') { + push @$fields, 'OR'; + } else { + die "No element found in '$type' for $field" if ! exists $val_hash->{$field}; + die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH'; + my $val = $val_hash->{$field}; + $val = {%$val, field => $field} if ! $val->{'field'}; # copy the values to add the key + push @$fields, $val; + } + } + + # limit the keys that need to be searched to those not in fields or order + my %found = map { ref($_) ? ($_->{'field'} => 1) : () } @$fields; + @field_keys = grep { ! $found{$_} } @field_keys; + } + + # add any remaining field_vals from our original hash + # this is necessary for items that weren't in group fields or group order + foreach my $field (@field_keys) { + die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH'; + if (defined $val_hash->{$field}->{'field'}) { + push @$fields, $val_hash->{$field}; + } else { + push @$fields, { %{$val_hash->{$field}}, field => $field }; + } + } + + return ($fields || [], \%ARGS); } sub new_error { @@ -199,653 +166,614 @@ sub new_error { ### allow for optional validation on groups and on individual items sub check_conditional { - my ($self, $form, $ifs, $ifs_match) = @_; - - ### can pass a single hash - or an array ref of hashes - if (! $ifs) { - die "Need reference passed to check_conditional"; - } elsif (! ref($ifs)) { - $ifs = [$ifs]; - } elsif (UNIVERSAL::isa($ifs,'HASH')) { - $ifs = [$ifs]; - } - - local $self->{'_check_conditional'} = 1; - - ### run the if options here - ### multiple items can be passed - all are required unless OR is used to separate - my $found = 1; - foreach (my $i = 0; $i <= $#$ifs; $i ++) { - my $ref = $ifs->[$i]; - if (! ref $ref) { - if ($ref eq 'OR') { - $i ++ if $found; # if found skip the OR altogether - $found = 1; # reset - next; - } else { - if ($ref =~ /^function\s*\(/) { - next; - } elsif ($ref =~ /^(.*?)\s+(was_valid|had_error|was_checked)$/) { - $ref = {field => $1, $2 => 1}; - } elsif ($ref =~ s/^\s*!\s*//) { - $ref = {field => $ref, max_in_set => "0 of $ref"}; - } else { - $ref = {field => $ref, required => 1}; + my ($self, $form, $ifs, $ifs_match) = @_; + die "Need reference passed to check_conditional" if ! $ifs; + $ifs = [$ifs] if ! ref($ifs) || UNIVERSAL::isa($ifs,'HASH'); + + local $self->{'_check_conditional'} = 1; + + # run the if options here + # multiple items can be passed - all are required unless OR is used to separate + my $found = 1; + foreach (my $i = 0; $i <= $#$ifs; $i ++) { + my $ref = $ifs->[$i]; + if (! ref $ref) { + if ($ref eq 'OR') { + $i ++ if $found; # if found skip the OR altogether + $found = 1; # reset + next; + } else { + if ($ref =~ /^function\s*\(/) { + next; + } elsif ($ref =~ /^(.*?)\s+(was_valid|had_error|was_checked)$/) { + $ref = {field => $1, $2 => 1}; + } elsif ($ref =~ s/^\s*!\s*//) { + $ref = {field => $ref, max_in_set => "0 of $ref"}; + } else { + $ref = {field => $ref, required => 1}; + } + } } - } - } - last if ! $found; + last if ! $found; - ### get the field - allow for custom variables based upon a match - my $field = $ref->{'field'} || die "Missing field key during validate_if (possibly used a reference to a main hash *foo -> &foo)"; - $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + # get the field - allow for custom variables based upon a match + my $field = $ref->{'field'} || die "Missing field key during validate_if (possibly used a reference to a main hash *foo -> &foo)"; + $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; - my $errs = $self->validate_buddy($form, $field, $ref); - $found = 0 if $errs; - } - return $found; + my $errs = $self->validate_buddy($form, $field, $ref); + $found = 0 if $errs; + } + return $found; } ### this is where the main checking goes on sub validate_buddy { - my $self = shift; - my ($form, $field, $field_val, $ifs_match) = @_; - - local $self->{'_recurse'} = ($self->{'_recurse'} || 0) + 1; - die "Max dependency level reached 10" if $self->{'_recurse'} > 10; - - my @errors = (); - my $types = [sort keys %$field_val]; - - ### allow for not running some tests in the cgi - if ($field_val->{'exclude_cgi'}) { - delete $field_val->{'was_validated'}; - return 0; - } - - ### allow for field names that contain regular expressions - if ($field =~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) { - my ($not,$pat,$opt) = ($1,$3,$4); - $opt =~ tr/g//d; - die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/; - foreach my $_field (sort keys %$form) { - next if ($not && $_field =~ m/(?$opt:$pat)/) || (! $not && $_field !~ m/(?$opt:$pat)/); - my @match = (undef, $1, $2, $3, $4, $5); # limit to the matches - my $errs = $self->validate_buddy($form, $_field, $field_val, \@match); - push @errors, @$errs if $errs; + my ($self, $form, $field, $field_val, $ifs_match) = @_; + local $self->{'_recurse'} = ($self->{'_recurse'} || 0) + 1; + die "Max dependency level reached 10" if $self->{'_recurse'} > 10; + my @errors; + + if ($field_val->{'exclude_cgi'}) { + delete $field_val->{'was_validated'}; + return 0; } - return @errors ? \@errors : 0; - } - if ($field_val->{was_valid} && ! $self->{'_was_valid'}->{$field}) { return [[$field, 'was_valid', $field_val, $ifs_match]]; } - if ($field_val->{had_error} && ! $self->{'_had_error'}->{$field}) { return [[$field, 'had_error', $field_val, $ifs_match]]; } - if ($field_val->{was_checked} && ! $self->{'_was_checked'}->{$field}) { return [[$field, 'was_checked', $field_val, $ifs_match]]; } + # allow for field names that contain regular expressions + if ($field =~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) { + my ($not,$pat,$opt) = ($1,$3,$4); + $opt =~ tr/g//d; + die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/; + foreach my $_field (sort keys %$form) { + next if ($not && $_field =~ m/(?$opt:$pat)/) || (! $not && $_field !~ m/(?$opt:$pat)/); + my @match = (undef, $1, $2, $3, $4, $5); # limit to the matches + my $errs = $self->validate_buddy($form, $_field, $field_val, \@match); + push @errors, @$errs if $errs; + } + return @errors ? \@errors : 0; + } - my $values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $form->{$field} : [$form->{$field}]; - my $n_values = $#$values + 1; + if ($field_val->{'was_valid'} && ! $self->{'was_valid'}->{$field}) { return [[$field, 'was_valid', $field_val, $ifs_match]]; } + if ($field_val->{'had_error'} && ! $self->{'had_error'}->{$field}) { return [[$field, 'had_error', $field_val, $ifs_match]]; } + if ($field_val->{'was_checked'} && ! $self->{'was_checked'}->{$field}) { return [[$field, 'was_checked', $field_val, $ifs_match]]; } - ### allow for default value - if (exists $field_val->{'default'}) { - if ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length($values->[0])))) { - $form->{$field} = $values->[0] = $field_val->{'default'}; - } - } - - ### allow for a few form modifiers - my $modified = 0; - foreach my $value (@$values) { - next if ! defined $value; - if (! $field_val->{'do_not_trim'}) { # whitespace - $value =~ s/^\s+//; - $value =~ s/\s+$//; - $modified = 1; - } - if ($field_val->{'trim_control_chars'}) { - $value =~ y/\t/ /; - $value =~ y/\x00-\x1F//d; - $modified = 1; - } - if ($field_val->{'to_upper_case'}) { # uppercase - $value = uc($value); - $modified = 1; - } elsif ($field_val->{'to_lower_case'}) { # lowercase - $value = lc($value); - $modified = 1; + my $values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $form->{$field} : [$form->{$field}]; + my $n_values = @$values; + + # allow for default value + if (exists $field_val->{'default'}) { + if ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length($values->[0])))) { + $form->{$field} = $values->[0] = $field_val->{'default'}; + } } - } - # allow for inline specified modifications (ie s/foo/bar/) - foreach my $type (grep {/^replace_?\d*$/} @$types) { - my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} - : [split(/\s*\|\|\s*/,$field_val->{$type})]; - foreach my $rx (@$ref) { - if ($rx !~ m/^\s*s([^\s\w])(.+)\1(.*)\1([eigsmx]*)$/s) { - die "Not sure how to parse that replace ($rx)"; - } - my ($pat, $swap, $opt) = ($2, $3, $4); - die "The e option cannot be used in swap on field $field" if $opt =~ /e/; - my $global = $opt =~ s/g//g; - $swap =~ s/\\n/\n/g; - if ($global) { - foreach my $value (@$values) { - $value =~ s{(?$opt:$pat)}{ - my @match = (undef, $1, $2, $3, $4, $5, $6); # limit on the number of matches - my $copy = $swap; - $copy =~ s/\$(\d+)/defined($match[$1]) ? $match[$1] : ""/ge; - $modified = 1; - $copy; # return of the swap - }eg; + + # allow for a few form modifiers + my $modified = 0; + foreach my $value (@$values) { + next if ! defined $value; + if (! $field_val->{'do_not_trim'}) { # whitespace + $modified = 1 if $value =~ s/( ^\s+ | \s+$ )//xg; } - }else{ - foreach my $value (@$values) { - next if ! defined $value; - $value =~ s{(?$opt:$pat)}{ - my @match = (undef, $1, $2, $3, $4, $5, $6); # limit on the number of matches - my $copy = $swap; - $copy =~ s/\$(\d+)/defined($match[$1]) ? $match[$1] : ""/ge; + if ($field_val->{'trim_control_chars'}) { + $modified = 1 if $value =~ y/\t/ /; + $modified = 1 if $value =~ y/\x00-\x1F//d; + } + if ($field_val->{'to_upper_case'}) { # uppercase + $value = uc $value; + $modified = 1; + } elsif ($field_val->{'to_lower_case'}) { # lowercase + $value = lc $value; $modified = 1; - $copy; # return of the swap - }e; } - } } - } - ### put them back into the form if we have modified it - if ($modified) { - if ($n_values == 1) { - $form->{$field} = $values->[0]; - $self->{cgi_object}->param(-name => $field, -value => $values->[0]) - if $self->{cgi_object}; - } else { - ### values in @{ $form->{$field} } were modified directly - $self->{cgi_object}->param(-name => $field, -value => $values) - if $self->{cgi_object}; - } - } - - ### only continue if a validate_if is not present or passes test - my $needs_val = 0; - my $n_vif = 0; - foreach my $type (grep {/^validate_if_?\d*$/} @$types) { - $n_vif ++; - my $ifs = $field_val->{$type}; - my $ret = $self->check_conditional($form, $ifs, $ifs_match); - $needs_val ++ if $ret; - } - if (! $needs_val && $n_vif) { - delete $field_val->{'was_validated'}; - return 0; - } - - ### check for simple existence - ### optionally check only if another condition is met - my $is_required = $field_val->{'required'} ? 'required' : ''; - if (! $is_required) { - foreach my $type (grep {/^required_if_?\d*$/} @$types) { - my $ifs = $field_val->{$type}; - next if ! $self->check_conditional($form, $ifs, $ifs_match); - $is_required = $type; - last; + + my %types; + foreach (sort keys %$field_val) { + push @{$types{$1}}, $_ if /^ (compare|custom|equals|match|max_in_set|min_in_set|replace|required_if|sql|type|validate_if) _?\d* $/x; } - } - if ($is_required - && ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length $values->[0])))) { - return [] if $self->{'_check_conditional'}; - return [[$field, $is_required, $field_val, $ifs_match]]; - } - - ### min values check - my $n = exists($field_val->{'min_values'}) ? $field_val->{'min_values'} || 0 : 0; - if ($n_values < $n) { - return [] if $self->{'_check_conditional'}; - return [[$field, 'min_values', $field_val, $ifs_match]]; - } - - ### max values check - $field_val->{'max_values'} = 1 if ! exists $field_val->{'max_values'}; - $n = $field_val->{'max_values'} || 0; - if ($n_values > $n) { - return [] if $self->{'_check_conditional'}; - return [[$field, 'max_values', $field_val, $ifs_match]]; - } - - ### max_in_set and min_in_set checks - my @min = grep {/^min_in_set_?\d*$/} @$types; - my @max = grep {/^max_in_set_?\d*$/} @$types; - foreach ([min => \@min], - [max => \@max]) { - my ($minmax, $keys) = @$_; - foreach my $type (@$keys) { - $field_val->{$type} =~ m/^\s*(\d+)(?i:\s*of)?\s+(.+)\s*$/ - || die "Invalid in_set check $field_val->{$type}"; - my $n = $1; - foreach my $_field (split /[\s,]+/, $2) { - my $ref = UNIVERSAL::isa($form->{$_field},'ARRAY') ? $form->{$_field} : [$form->{$_field}]; - foreach my $_value (@$ref) { - $n -- if defined($_value) && length($_value); + + # allow for inline specified modifications (ie s/foo/bar/) + if ($types{'replace'}) { foreach my $type (@{ $types{'replace'} }) { + my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} + : [split(/\s*\|\|\s*/,$field_val->{$type})]; + foreach my $rx (@$ref) { + if ($rx !~ m/^\s*s([^\s\w])(.+)\1(.*)\1([eigsmx]*)$/s) { + die "Not sure how to parse that replace ($rx)"; + } + my ($pat, $swap, $opt) = ($2, $3, $4); + die "The e option cannot be used in swap on field $field" if $opt =~ /e/; + my $global = $opt =~ s/g//g; + $swap =~ s/\\n/\n/g; + my $expand = sub { # code similar to Template::Alloy::VMethod::vmethod_replace + my ($text, $start, $end) = @_; + my $copy = $swap; + $copy =~ s{ \\(\\|\$) | \$ (\d+) }{ + $1 ? $1 + : ($2 > $#$start || $2 == 0) ? '' + : substr($text, $start->[$2], $end->[$2] - $start->[$2]); + }exg; + $modified = 1; + $copy; + }; + foreach my $value (@$values) { + if ($global) { $value =~ s{(?$opt:$pat)}{ $expand->($value, [@-], [@+]) }eg } + else { $value =~ s{(?$opt:$pat)}{ $expand->($value, [@-], [@+]) }e } + } } - } - if ( ($minmax eq 'min' && $n > 0) - || ($minmax eq 'max' && $n < 0)) { - return [] if $self->{'_check_conditional'}; - return [[$field, $type, $field_val, $ifs_match]]; - } - } - } - - ### at this point @errors should still be empty - my $content_checked; # allow later for possible untainting (only happens if content was checked) - - ### loop on values of field - foreach my $value (@$values) { - - ### allow for enum types - if (exists $field_val->{'enum'}) { - my $ref = ref($field_val->{'enum'}) ? $field_val->{'enum'} : [split(/\s*\|\|\s*/,$field_val->{'enum'})]; - my $found = 0; - foreach (@$ref) { - $found = 1 if defined($value) && $_ eq $value; - } - if (! $found) { - return [] if $self->{'_check_conditional'}; - push @errors, [$field, 'enum', $field_val, $ifs_match]; - } - $content_checked = 1; + } } + $form->{$field} = $values->[0] if $modified && $n_values == 1; # put them back into the form if we have modified it + + # only continue if a validate_if is not present or passes test + my $needs_val = 0; + my $n_vif = 0; + if ($types{'validate_if'}) { foreach my $type (@{ $types{'validate_if'} }) { + $n_vif++; + my $ifs = $field_val->{$type}; + my $ret = $self->check_conditional($form, $ifs, $ifs_match); + $needs_val++ if $ret; + } } + if (! $needs_val && $n_vif) { + delete $field_val->{'was_validated'}; + return 0; } - ### field equality test - foreach my $type (grep {/^equals_?\d*$/} @$types) { - my $field2 = $field_val->{$type}; - my $not = ($field2 =~ s/^!\s*//) ? 1 : 0; - my $success = 0; - if ($field2 =~ m/^([\"\'])(.*)\1$/) { - my $test = $2; - $success = (defined($value) && $value eq $test); - } elsif (exists($form->{$field2}) && defined($form->{$field2})) { - $success = (defined($value) && $value eq $form->{$field2}); - } elsif (! defined($value)) { - $success = 1; # occurs if they are both undefined - } - if ($not ? $success : ! $success) { - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; - } - $content_checked = 1; + # check for simple existence + # optionally check only if another condition is met + my $is_required = $field_val->{'required'} ? 'required' : ''; + if (! $is_required) { + if ($types{'required_if'}) { foreach my $type (@{ $types{'required_if'} }) { + my $ifs = $field_val->{$type}; + next if ! $self->check_conditional($form, $ifs, $ifs_match); + $is_required = $type; + last; + } } } - - ### length min check - if (exists $field_val->{'min_len'}) { - my $n = $field_val->{'min_len'}; - if (! defined($value) || length($value) < $n) { + if ($is_required + && ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length $values->[0])))) { return [] if $self->{'_check_conditional'}; - push @errors, [$field, 'min_len', $field_val, $ifs_match]; - } + return [[$field, $is_required, $field_val, $ifs_match]]; } - ### length max check - if (exists $field_val->{'max_len'}) { - my $n = $field_val->{'max_len'}; - if (defined($value) && length($value) > $n) { + my $n = exists($field_val->{'min_values'}) ? $field_val->{'min_values'} || 0 : 0; + if ($n_values < $n) { return [] if $self->{'_check_conditional'}; - push @errors, [$field, 'max_len', $field_val, $ifs_match]; - } + return [[$field, 'min_values', $field_val, $ifs_match]]; } - ### now do match types - foreach my $type (grep {/^match_?\d*$/} @$types) { - my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} - : UNIVERSAL::isa($field_val->{$type}, 'Regexp') ? [$field_val->{$type}] - : [split(/\s*\|\|\s*/,$field_val->{$type})]; - foreach my $rx (@$ref) { - if (UNIVERSAL::isa($rx,'Regexp')) { - if (! defined($value) || $value !~ $rx) { - push @errors, [$field, $type, $field_val, $ifs_match]; - } - } else { - if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) { - die "Not sure how to parse that match ($rx)"; - } - my ($not,$pat,$opt) = ($1,$3,$4); - $opt =~ tr/g//d; - die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/; - if ( ( $not && ( defined($value) && $value =~ m/(?$opt:$pat)/)) - || (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/)) - ) { - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; - } + $field_val->{'max_values'} = 1 if ! exists $field_val->{'max_values'}; + $n = $field_val->{'max_values'} || 0; + if ($n_values > $n) { + return [] if $self->{'_check_conditional'}; + return [[$field, 'max_values', $field_val, $ifs_match]]; + } + + foreach ([min => $types{'min_in_set'}], + [max => $types{'max_in_set'}]) { + my $keys = $_->[1] || next; + my $minmax = $_->[0]; + foreach my $type (@$keys) { + $field_val->{$type} =~ m/^\s*(\d+)(?i:\s*of)?\s+(.+)\s*$/ + || die "Invalid ${minmax}_in_set check $field_val->{$type}"; + my $n = $1; + foreach my $_field (split /[\s,]+/, $2) { + my $ref = UNIVERSAL::isa($form->{$_field},'ARRAY') ? $form->{$_field} : [$form->{$_field}]; + foreach my $_value (@$ref) { + $n -- if defined($_value) && length($_value); + } + } + if ( ($minmax eq 'min' && $n > 0) + || ($minmax eq 'max' && $n < 0)) { + return [] if $self->{'_check_conditional'}; + return [[$field, $type, $field_val, $ifs_match]]; + } } - } - $content_checked = 1; } - ### allow for comparison checks - foreach my $type (grep {/^compare_?\d*$/} @$types) { - my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} - : [split(/\s*\|\|\s*/,$field_val->{$type})]; - foreach my $comp (@$ref) { - next if ! $comp; - my $test = 0; - if ($comp =~ /^\s*(>|<|[>' ) { $test = ($val > $2) } - elsif ($1 eq '<' ) { $test = ($val < $2) } - elsif ($1 eq '>=') { $test = ($val >= $2) } - elsif ($1 eq '<=') { $test = ($val <= $2) } - elsif ($1 eq '!=') { $test = ($val != $2) } - elsif ($1 eq '==') { $test = ($val == $2) } - - } elsif ($comp =~ /^\s*(eq|ne|gt|ge|lt|le)\s+(.+?)\s*$/) { - my $val = defined($value) ? $value : ''; - my ($op, $value2) = ($1, $2); - $value2 =~ s/^([\"\'])(.*)\1$/$2/; - if ($op eq 'gt') { $test = ($val gt $value2) } - elsif ($op eq 'lt') { $test = ($val lt $value2) } - elsif ($op eq 'ge') { $test = ($val ge $value2) } - elsif ($op eq 'le') { $test = ($val le $value2) } - elsif ($op eq 'ne') { $test = ($val ne $value2) } - elsif ($op eq 'eq') { $test = ($val eq $value2) } + # at this point @errors should still be empty + my $content_checked; # allow later for possible untainting (only happens if content was checked) - } else { - die "Not sure how to compare \"$comp\""; + foreach my $value (@$values) { + + if (exists $field_val->{'enum'}) { + my $ref = ref($field_val->{'enum'}) ? $field_val->{'enum'} : [split(/\s*\|\|\s*/,$field_val->{'enum'})]; + my $found = 0; + foreach (@$ref) { + $found = 1 if defined($value) && $_ eq $value; + } + if (! $found) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, 'enum', $field_val, $ifs_match]; + } + $content_checked = 1; } - if (! $test) { - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; + + # field equals another field + if ($types{'equals'}) { foreach my $type (@{ $types{'equals'} }) { + my $field2 = $field_val->{$type}; + my $not = ($field2 =~ s/^!\s*//) ? 1 : 0; + my $success = 0; + if ($field2 =~ m/^([\"\'])(.*)\1$/) { + my $test = $2; + $success = (defined($value) && $value eq $test); + } elsif (exists($form->{$field2}) && defined($form->{$field2})) { + $success = (defined($value) && $value eq $form->{$field2}); + } elsif (! defined($value)) { + $success = 1; # occurs if they are both undefined + } + if ($not ? $success : ! $success) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + } + $content_checked = 1; + } } + + if (exists $field_val->{'min_len'}) { + my $n = $field_val->{'min_len'}; + if (! defined($value) || length($value) < $n) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, 'min_len', $field_val, $ifs_match]; + } } - } - $content_checked = 1; - } - ### server side sql type - foreach my $type (grep {/^sql_?\d*$/} @$types) { - my $db_type = $field_val->{"${type}_db_type"}; - my $dbh = ($db_type) ? $self->{dbhs}->{$db_type} : $self->{dbh}; - if (! $dbh) { - die "Missing dbh for $type type on field $field" . ($db_type ? " and db_type $db_type" : ""); - } elsif (UNIVERSAL::isa($dbh,'CODE')) { - $dbh = &$dbh($field, $self) || die "SQL Coderef did not return a dbh"; - } - my $sql = $field_val->{$type}; - my @args = ($value) x $sql =~ tr/?//; - my $return = $dbh->selectrow_array($sql, {}, @args); # is this right - copied from O::FORMS - $field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"}; - if ( (! $return && $field_val->{"${type}_error_if"}) - || ($return && ! $field_val->{"${type}_error_if"}) ) { - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; - } - $content_checked = 1; - } + if (exists $field_val->{'max_len'}) { + my $n = $field_val->{'max_len'}; + if (defined($value) && length($value) > $n) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, 'max_len', $field_val, $ifs_match]; + } + } - ### server side custom type - foreach my $type (grep {/^custom_?\d*$/} @$types) { - my $check = $field_val->{$type}; - next if UNIVERSAL::isa($check, 'CODE') ? &$check($field, $value, $field_val, $type) : $check; - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; - $content_checked = 1; - } + # now do match types + if ($types{'match'}) { foreach my $type (@{ $types{'match'} }) { + my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} + : UNIVERSAL::isa($field_val->{$type}, 'Regexp') ? [$field_val->{$type}] + : [split(/\s*\|\|\s*/,$field_val->{$type})]; + foreach my $rx (@$ref) { + if (UNIVERSAL::isa($rx,'Regexp')) { + if (! defined($value) || $value !~ $rx) { + push @errors, [$field, $type, $field_val, $ifs_match]; + } + } else { + if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) { + die "Not sure how to parse that match ($rx)"; + } + my ($not, $pat, $opt) = ($1, $3, $4); + $opt =~ tr/g//d; + die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/; + if ( ( $not && ( defined($value) && $value =~ m/(?$opt:$pat)/)) + || (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/)) ) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + } + } + } + $content_checked = 1; + } } + + # allow for comparison checks + if ($types{'compare'}) { foreach my $type (@{ $types{'compare'} }) { + my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type} + : [split(/\s*\|\|\s*/,$field_val->{$type})]; + foreach my $comp (@$ref) { + next if ! $comp; + my $test = 0; + if ($comp =~ /^\s*(>|<|[>' ) { $test = ($val > $2) } + elsif ($1 eq '<' ) { $test = ($val < $2) } + elsif ($1 eq '>=') { $test = ($val >= $2) } + elsif ($1 eq '<=') { $test = ($val <= $2) } + elsif ($1 eq '!=') { $test = ($val != $2) } + elsif ($1 eq '==') { $test = ($val == $2) } + + } elsif ($comp =~ /^\s*(eq|ne|gt|ge|lt|le)\s+(.+?)\s*$/) { + my $val = defined($value) ? $value : ''; + my ($op, $value2) = ($1, $2); + $value2 =~ s/^([\"\'])(.*)\1$/$2/; + if ($op eq 'gt') { $test = ($val gt $value2) } + elsif ($op eq 'lt') { $test = ($val lt $value2) } + elsif ($op eq 'ge') { $test = ($val ge $value2) } + elsif ($op eq 'le') { $test = ($val le $value2) } + elsif ($op eq 'ne') { $test = ($val ne $value2) } + elsif ($op eq 'eq') { $test = ($val eq $value2) } + + } else { + die "Not sure how to compare \"$comp\""; + } + if (! $test) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + } + } + $content_checked = 1; + } } + + # server side sql type + if ($types{'sql'}) { foreach my $type (@{ $types{'sql'} }) { + my $db_type = $field_val->{"${type}_db_type"}; + my $dbh = ($db_type) ? $self->{dbhs}->{$db_type} : $self->{dbh}; + if (! $dbh) { + die "Missing dbh for $type type on field $field" . ($db_type ? " and db_type $db_type" : ""); + } elsif (UNIVERSAL::isa($dbh,'CODE')) { + $dbh = &$dbh($field, $self) || die "SQL Coderef did not return a dbh"; + } + my $sql = $field_val->{$type}; + my @args = ($value) x $sql =~ tr/?//; + my $return = $dbh->selectrow_array($sql, {}, @args); # is this right - copied from O::FORMS + $field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"}; + if ( (! $return && $field_val->{"${type}_error_if"}) + || ($return && ! $field_val->{"${type}_error_if"}) ) { + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + } + $content_checked = 1; + } } - ### do specific type checks - foreach my $type (grep {/^type_?\d*$/} @$types) { - if (! $self->check_type($value,$field_val->{'type'},$field,$form)){ - return [] if $self->{'_check_conditional'}; - push @errors, [$field, $type, $field_val, $ifs_match]; - } - $content_checked = 1; + # server side custom type + if ($types{'custom'}) { foreach my $type (@{ $types{'custom'} }) { + my $check = $field_val->{$type}; + next if UNIVERSAL::isa($check, 'CODE') ? &$check($field, $value, $field_val, $type) : $check; + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + $content_checked = 1; + } } + + # do specific type checks + if ($types{'type'}) { foreach my $type (@{ $types{'type'} }) { + if (! $self->check_type($value,$field_val->{'type'},$field,$form)){ + return [] if $self->{'_check_conditional'}; + push @errors, [$field, $type, $field_val, $ifs_match]; + } + $content_checked = 1; + } } } - } - ### allow for the data to be "untainted" - ### this is only allowable if the user ran some other check for the datatype - if ($field_val->{'untaint'} && $#errors == -1) { - if (! $content_checked) { - push @errors, [$field, 'untaint', $field_val, $ifs_match]; - } else { - ### generic untainter - assuming the other required content_checks did good validation - $_ = /(.*)/ ? $1 : die "Couldn't match?" foreach @$values; - if ($n_values == 1) { - $form->{$field} = $values->[0]; - $self->{cgi_object}->param(-name => $field, -value => $values->[0]) - if $self->{cgi_object}; - } else { - ### values in @{ $form->{$field} } were modified directly - $self->{cgi_object}->param(-name => $field, -value => $values) - if $self->{cgi_object}; - } + # allow for the data to be "untainted" + # this is only allowable if the user ran some other check for the datatype + if ($field_val->{'untaint'} && $#errors == -1) { + if (! $content_checked) { + push @errors, [$field, 'untaint', $field_val, $ifs_match]; + } else { + # generic untainter - assuming the other required content_checks did good validation + $_ = /(.*)/ ? $1 : die "Couldn't match?" foreach @$values; + if ($n_values == 1) { + $form->{$field} = $values->[0]; + } + } } - } - ### all done - time to return - return @errors ? \@errors : 0; + # all done - time to return + return @errors ? \@errors : 0; } -###----------------------------------------------------------------### +###---------------------### ### used to validate specific types sub check_type { - my $self = shift; - my $value = shift; - my $type = uc(shift); - - ### do valid email address for our system - if ($type eq 'EMAIL') { - return 0 if ! $value; - my($local_p,$dom) = ($value =~ /^(.+)\@(.+?)$/) ? ($1,$2) : return 0; - - return 0 if length($local_p) > 60; - return 0 if length($dom) > 100; - return 0 if ! $self->check_type($dom,'DOMAIN') && ! $self->check_type($dom,'IP'); - return 0 if ! $self->check_type($local_p,'LOCAL_PART'); - - ### the "username" portion of an email address - } elsif ($type eq 'LOCAL_PART') { - return 0 if ! defined($value) || ! length($value); - return 0 if $value =~ m/[^a-z0-9.\-!&+]/; - return 0 if $value =~ m/^[\.\-]/; - return 0 if $value =~ m/[\.\-\&]$/; - return 0 if $value =~ m/(\.\-|\-\.|\.\.)/; - - ### standard IP address - } elsif ($type eq 'IP') { - return 0 if ! $value; - return (4 == grep {!/\D/ && $_ < 256} split /\./, $value, 4); - - ### domain name - including tld and subdomains (which are all domains) - } elsif ($type eq 'DOMAIN') { - return 0 if ! $value; - return 0 if $value =~ m/[^a-z0-9.\-]/; - return 0 if $value =~ m/^[\.\-]/; - return 0 if $value =~ m/(\.\-|\-\.|\.\.)/; - return 0 if length($value) > 255; - return 0 if $value !~ s/\.([a-z]+)$//; - 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') { - return 0 if ! $value; - $value =~ s|^https?://([^/]+)||i || return 0; - my $dom = $1; - return 0 if ! $self->check_type($dom,'DOMAIN') && ! $self->check_type($dom,'IP'); - return 0 if $value && ! $self->check_type($value,'URI'); - - ### validate a uri - the path portion of a request - } elsif ($type eq 'URI') { - return 0 if ! $value; - return 0 if $value =~ m/\s+/; - - } elsif ($type eq 'CC') { - return 0 if ! $value; - ### validate the number - return 0 if $value =~ /[^\d\-\ ]/ - || length($value) > 16 - || length($value) < 13; - - ### simple mod10 check - $value =~ s/\D//g; - my $sum = 0; - my $switch = 0; - foreach my $digit ( reverse split //, $value ){ - $switch = 1 if ++ $switch > 2; - my $y = $digit * $switch; - $y -= 9 if $y > 9; - $sum += $y; - } - return 0 if $sum % 10; + my ($self, $value, $type) = @_; + + if ($type eq 'email') { + return 0 if ! $value; + my ($local_p,$dom) = ($value =~ /^(.+)\@(.+?)$/) ? ($1,$2) : return 0; + return 0 if length($local_p) > 60; + return 0 if length($dom) > 100; + return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip'); + return 0 if ! $self->check_type($local_p,'local_part'); + + # the "username" portion of an email address - sort of arbitrary + } elsif ($type eq 'local_part') { + return 0 if ! defined($value) || ! length($value); + return 0 if $value =~ m/[^A-Za-z0-9_.\-\^=?\#!&+]/ + || $value =~ m/^[\.\-]/ + || $value =~ m/[\.\-\&]$/ + || $value =~ m/(\.\-|\-\.|\.\.)/; + + # standard IP address + } elsif ($type eq 'ip') { + return 0 if ! $value; + return (4 == grep {!/\D/ && $_ < 256} split /\./, $value, 4); + + # domain name - including tld and subdomains (which are all domains) + } elsif ($type eq 'domain') { + return 0 if ! $value || length($value) > 255; + return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)+ [a-z]{1,63}$/ix + || $value =~ m/(\.\-|\-\.|\.\.)/; + + # validate a url + } elsif ($type eq 'url') { + return 0 if ! $value; + $value =~ s|^https?://([^/]+)||i || return 0; + my $dom = $1; + return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip'); + return 0 if $value && ! $self->check_type($value,'uri'); + + # validate a uri - the path portion of a request + } elsif ($type eq 'URI') { + return 0 if ! $value; + return 0 if $value =~ m/\s+/; + + } elsif ($type eq 'CC') { + return 0 if ! $value; + return 0 if $value =~ /[^\d\-\ ]/; + $value =~ s/\D//g; + return 0 if length($value) > 16 || length($value) < 13; + + # simple mod10 check + my $sum = 0; + my $switch = 0; + foreach my $digit (reverse split //, $value) { + $switch = 1 if ++$switch > 2; + my $y = $digit * $switch; + $y -= 9 if $y > 9; + $sum += $y; + } + return 0 if $sum % 10; - } + } - return 1; + return 1; } -###----------------------------------------------------------------### +###---------------------### sub get_validation { - my $self = shift; - my $val = shift; + my ($self, $val) = @_; require CGI::Ex::Conf; - return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => $DEFAULT_EXT}); + return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => 'val'}); } ### returns all keys from all groups - even if group has validate_if sub get_validation_keys { - my $self = shift; - my $val_hash = shift; - my $form = shift; # with optional form - will only return keys in validated groups - - ### turn the form into a form hash if doesn't look like one already - if ($form) { - die "Invalid form hash or cgi object" if ! ref $form; - if (ref $form ne 'HASH') { - local $self->{cgi_object} = $form; - $form = $self->cgix->get_form($form); - } - } - - ### make sure the validation is a hashref - ### get_validation handle odd types - if (ref $val_hash ne 'HASH') { - $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash; - die "Validation groups must be a hashref" if ref $val_hash ne 'HASH'; - } - - ### parse keys that are group arguments - and those that are keys to validate - my %ARGS; - my @field_keys = grep { /^(?:group|general)\s+(\w+)/ - ? do {$ARGS{$1} = $val_hash->{$_} ; 0} - : 1 } - sort keys %$val_hash; - - ### only validate this group if it is supposed to be checked - return if $form && $ARGS{'validate_if'} && ! $self->check_conditional($form, $ARGS{'validate_if'}); - - ### Look first for items in 'group fields' or 'group order' - my %keys; - if (my $fields = $ARGS{'fields'} || $ARGS{'order'}) { - my $type = $ARGS{'fields'} ? 'group fields' : 'group order'; - die "Validation '$type' must be an arrayref when passed" - if ! UNIVERSAL::isa($fields, 'ARRAY'); - foreach my $field (@$fields) { - die "Non-defined value in '$type'" if ! defined $field; - if (ref $field) { - die "Found nonhashref value in '$type'" if ref($field) ne 'HASH'; - die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'}; - $keys{$field->{'field'}} = $field->{'name'} || 1; - } elsif ($field eq 'OR') { - } else { - die "No element found in '$type' for $field" if ! exists $val_hash->{$field}; - die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH'; - $keys{$field} = $val_hash->{$field}->{'name'} || 1; - } + my ($self, $val_hash, $form) = @_; # with optional form - will only return keys in validated groups + + if ($form) { + die "Invalid form hash or cgi object" if ! ref $form; + $form = $self->cgix->get_form($form) if ref $form ne 'HASH'; } - } - - ### add any remaining field_vals from our original hash - ### this is necessary for items that weren't in group fields or group order - foreach my $field (@field_keys) { - next if $keys{$field}; - die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH'; - if (defined $val_hash->{$field}->{'field'}) { - $keys{$val_hash->{$field}->{'field'}} = $val_hash->{$field}->{'name'} || 1; - } else { - $keys{$field} = $val_hash->{$field}->{'name'} || 1; - } - } - - return \%keys; + + my ($fields, $ARGS) = $self->get_ordered_fields($val_hash); + return {} if ! @$fields; + return {} if $form && $ARGS->{'validate_if'} && ! $self->check_conditional($form, $ARGS->{'validate_if'}); + return {map { $_->{'field'} = $_->{'name'} || 1 } @$fields}; } -###----------------------------------------------------------------### +###---------------------### -### spit out a chunk that will do the validation sub generate_js { - ### allow for some browsers to not receive the validation js return "" if $ENV{'HTTP_USER_AGENT'} && grep {$ENV{'HTTP_USER_AGENT'} =~ $_} @UNSUPPORTED_BROWSERS; - my $self = shift; - my $val_hash = shift || die "Missing validation"; - my $form_name = shift || die "Missing form name"; - my $js_uri_path = shift || $JS_URI_PATH; - $val_hash = $self->get_validation($val_hash); + my $self = shift; + my $val_hash = shift || croak "Missing validation hash"; + if (ref $val_hash ne 'HASH') { + $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash; + croak "Validation groups must be a hashref" if ref $val_hash ne 'HASH'; + } - ### store any extra items from self - my %EXTRA = (); - $EXTRA{"general $_"} = $self->{$_} for grep {/$QR_EXTRA/o} keys %$self; # add 'general' to be used in javascript + my ($args, $form_name, $js_uri_path); + croak "Missing args or form_name" if ! $_[0]; + if (ref($_[0]) eq 'HASH') { + $args = shift; + } else { + ($args, $form_name, $js_uri_path) = ({}, @_); + } + + $form_name ||= $args->{'form_name'} || croak 'Missing form_name'; + $js_uri_path ||= $args->{'js_uri_path'}; my $js_uri_path_validate = $JS_URI_PATH_VALIDATE || do { - die "Missing \$js_uri_path" if ! $js_uri_path; + croak 'Missing js_uri_path' if ! $js_uri_path; "$js_uri_path/CGI/Ex/validate.js"; }; - if (! $self->{'no_jsondump'} && eval { require CGI::Ex::JSONDump }) { - my $json = CGI::Ex::JSONDump->new({pretty => 1})->dump($val_hash); - return qq{ - -}; - - } elsif (! $self->{'no_json'} && eval { require JSON }) { - my $json = JSON->new(pretty => 1)->objToJson($val_hash); - - return qq{ + require CGI::Ex::JSONDump; + my $json = CGI::Ex::JSONDump->new({pretty => 1})->dump($val_hash); + return qq{ }; +} - } elsif (eval { require YAML }) { - - my $str = YAML::Dump((scalar keys %EXTRA) ? (\%EXTRA) : () , $val_hash); - $str =~ s/(?get_ordered_fields($val_hash); + $args = {%{ $ARGS->{'form_args'} || {}}, %{ $args || {} }}; + + my $cols = ($args->{'no_inline_error'} || ! $args->{'columns'} || $args->{'columns'} != 3) ? 2 : 3; + $args->{'div'} ||= "
\n"; + $args->{'open'} ||= "
\n"; + $args->{'form_name'} ||= $form_name || 'the_form_'.int(rand * 1000); + $args->{'action'} ||= ''; + $args->{'method'} ||= 'POST'; + $args->{'submit'} ||= "{'submit_name'} || 'Submit')."\">"; + $args->{'header'} ||= "\n"; + $args->{'header'} .= " \n" if $args->{'title'}; + $args->{'footer'} ||= " \n
\$title
\$submit
\n"; + $args->{'row_template'} ||= " \n" + ." \$name\n" + ." \$input" + . ($cols == 2 + ? ($args->{'no_inline_error'} ? '' : "
[% \$field_error %]\n") + : "\n [% \$field_error %]\n") + ." \n"; + + my $js = ! defined($args->{'use_js_validation'}) || $args->{'use_js_validation'}; + + $args->{'css'} = ".odd { background: #eee }\n" + . ".form_div { width: 40em; }\n" + . ".form_div td { padding:.5ex;}\n" + . ".form_div label { width: 10em }\n" + . ".form_div .error { color: darkred }\n" + . "table { border-spacing: 0px }\n" + . ".submit_row { text-align: right }\n" + if ! defined $args->{'css'}; + + my $txt = ($args->{'css'} ? "\n" : '') . $args->{'div'} . $args->{'open'} . $args->{'header'}; + s/\$(form_name|title|method|action|submit|extra_form_attrs)/$args->{$1}/g foreach $txt, $args->{'footer'}; + my $n = 0; + foreach my $field (@$fields) { + my $input; + my $type = $field->{'htype'} ? $field->{'htype'} : $field->{'field'} =~ /^pass(?:|wd|word|\d+|_\w+)$/i ? 'password' : 'text'; + if ($type eq 'hidden') { + $txt .= "$input\n"; + next; + } elsif ($type eq 'textarea' || $field->{'rows'} || $field->{'cols'}) { + my $r = $field->{'rows'} ? " rows=\"$field->{'rows'}\"" : ''; + my $c = $field->{'cols'} ? " cols=\"$field->{'cols'}\"" : ''; + my $w = $field->{'wrap'} ? " wrap=\"$field->{'wrap'}\"" : ''; + $input = ""; + } elsif ($type eq 'radio' || $type eq 'checkbox') { + my $e = $field->{'enum'} || []; + my $l = $field->{'label'} || $e; + my $I = @$e > @$l ? $#$e : $#$l; + for (my $i = 0; $i <= $I; $i++) { + my $_e = $e->[$i]; + $_e =~ s/\"/"/g; + $input .= "
{'field'}\" id=\"$field->{'field'}_$i\" value=\"$_e\">" + .(defined($l->[$i]) ? $l->[$i] : '')."
\n"; + } + } elsif ($type eq 'select' || $field->{'enum'} || $field->{'label'}) { + $input = "\n"; + } else { + my $s = $field->{'size'} ? " size=\"$field->{'size'}\"" : ''; + my $m = $field->{'maxlength'} || $field->{'max_len'}; $m = $m ? " maxlength=\"$m\"" : ''; + $input = "{'field'}\" id=\"$field->{'field'}\"$s$m value=\"\" />"; + } - ### return the string - return qq{ - - -}; - } else { - return ''; - } + $n++; + my $copy = $args->{'row_template'}; + my $name = $field->{'field'}; + $name = $field->{'name'} || do { $name =~ tr/_/ /; $name =~ s/\b(\w)/\u$1/g; $name }; + $name = ""; + $copy =~ s/\$field/$field->{'field'}/g; + $copy =~ s/\$name/$name/g; + $copy =~ s/\$input/$input/g; + $copy =~ s/\$oddeven/$n % 2 ? 'odd' : 'even'/eg; + $txt .= $copy; + } + $txt .= $args->{'footer'} . ($args->{'close'} || "
\n") . ($args->{'div_close'} || "
\n"); + if ($js) { + local @{ $val_hash }{('general form_args', 'group form_args')}; + delete @{ $val_hash }{('general form_args', 'group form_args')}; + $txt .= $self->generate_js($val_hash, $args); + } + return $txt; } -###----------------------------------------------------------------### +###---------------------### ### How to handle errors package CGI::Ex::Validate::Error; @@ -861,1401 +789,225 @@ sub new { } sub as_string { - my $self = shift; - my $extra = $self->{extra} || {}; - my $extra2 = shift || {}; + my $self = shift; + my $extra = $self->{extra} || {}; + my $extra2 = shift || {}; - ### allow for formatting - my $join = defined($extra2->{as_string_join}) ? $extra2->{as_string_join} + # allow for formatting + my $join = defined($extra2->{as_string_join}) ? $extra2->{as_string_join} : defined($extra->{as_string_join}) ? $extra->{as_string_join} : "\n"; - my $header = defined($extra2->{as_string_header}) ? $extra2->{as_string_header} + my $header = defined($extra2->{as_string_header}) ? $extra2->{as_string_header} : defined($extra->{as_string_header}) ? $extra->{as_string_header} : ""; - my $footer = defined($extra2->{as_string_footer}) ? $extra2->{as_string_footer} + my $footer = defined($extra2->{as_string_footer}) ? $extra2->{as_string_footer} : defined($extra->{as_string_footer}) ? $extra->{as_string_footer} : ""; - return $header . join($join, @{ $self->as_array($extra2) }) . $footer; + return $header . join($join, @{ $self->as_array($extra2) }) . $footer; } -### return an array of applicable errors sub as_array { - my $self = shift; - my $errors = $self->{errors} || die "Missing errors"; - my $extra = $self->{extra} || {}; - my $extra2 = shift || {}; + my $self = shift; + my $errors = $self->{errors} || die "Missing errors"; + my $extra = $self->{extra} || {}; + my $extra2 = shift || {}; - my $title = defined($extra2->{as_array_title}) ? $extra2->{as_array_title} + my $title = defined($extra2->{as_array_title}) ? $extra2->{as_array_title} : defined($extra->{as_array_title}) ? $extra->{as_array_title} : "Please correct the following items:"; - ### if there are heading items then we may end up needing a prefix - my $has_headings; - if ($title) { - $has_headings = 1; - } else { - foreach (@$errors) { - next if ref; - $has_headings = 1; - last; + # if there are heading items then we may end up needing a prefix + my $has_headings; + if ($title) { + $has_headings = 1; + } else { + foreach (@$errors) { + next if ref; + $has_headings = 1; + last; + } } - } - my $prefix = defined($extra2->{as_array_prefix}) ? $extra2->{as_array_prefix} + my $prefix = defined($extra2->{as_array_prefix}) ? $extra2->{as_array_prefix} : defined($extra->{as_array_prefix}) ? $extra->{as_array_prefix} : $has_headings ? ' ' : ''; - ### get the array ready - my @array = (); - push @array, $title if length $title; + # get the array ready + my @array = (); + push @array, $title if length $title; - ### add the errors - my %found = (); - foreach my $err (@$errors) { - if (! ref $err) { - push @array, $err; - %found = (); - } else { - my $text = $self->get_error_text($err); - next if $found{$text}; - $found{$text} = 1; - push @array, "$prefix$text"; + # add the errors + my %found = (); + foreach my $err (@$errors) { + if (! ref $err) { + push @array, $err; + %found = (); + } else { + my $text = $self->get_error_text($err); + next if $found{$text}; + $found{$text} = 1; + push @array, "$prefix$text"; + } } - } - return \@array; + return \@array; } -### return a hash of applicable errors sub as_hash { - my $self = shift; - my $errors = $self->{errors} || die "Missing errors"; - my $extra = $self->{extra} || {}; - my $extra2 = shift || {}; + my $self = shift; + my $errors = $self->{errors} || die "Missing errors"; + my $extra = $self->{extra} || {}; + my $extra2 = shift || {}; - my $suffix = defined($extra2->{as_hash_suffix}) ? $extra2->{as_hash_suffix} + my $suffix = defined($extra2->{as_hash_suffix}) ? $extra2->{as_hash_suffix} : defined($extra->{as_hash_suffix}) ? $extra->{as_hash_suffix} : '_error'; - my $join = defined($extra2->{as_hash_join}) ? $extra2->{as_hash_join} + my $join = defined($extra2->{as_hash_join}) ? $extra2->{as_hash_join} : defined($extra->{as_hash_join}) ? $extra->{as_hash_join} : '
'; - ### now add to the hash - my %found = (); - my %return = (); - foreach my $err (@$errors) { - next if ! ref $err; + my %found; + my %return; + foreach my $err (@$errors) { + next if ! ref $err; - my ($field, $type, $field_val, $ifs_match) = @$err; - die "Missing field name" if ! $field; - if ($field_val->{delegate_error}) { - $field = $field_val->{delegate_error}; - $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + my ($field, $type, $field_val, $ifs_match) = @$err; + die "Missing field name" if ! $field; + if ($field_val->{delegate_error}) { + $field = $field_val->{delegate_error}; + $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + } + + my $text = $self->get_error_text($err); + next if $found{$field}->{$text}; + $found{$field}->{$text} = 1; + + $field .= $suffix; + push @{ $return{$field} }, $text; } - my $text = $self->get_error_text($err); - next if $found{$field}->{$text}; - $found{$field}->{$text} = 1; - - $field .= $suffix; - $return{$field} ||= []; - $return{$field} = [$return{$field}] if ! ref($return{$field}); - push @{ $return{$field} }, $text; - } - - ### allow for elements returned as - if ($join) { - my $header = defined($extra2->{as_hash_header}) ? $extra2->{as_hash_header} - : defined($extra->{as_hash_header}) ? $extra->{as_hash_header} : ""; - my $footer = defined($extra2->{as_hash_footer}) ? $extra2->{as_hash_footer} - : defined($extra->{as_hash_footer}) ? $extra->{as_hash_footer} : ""; - foreach my $key (keys %return) { - $return{$key} = $header . join($join,@{ $return{$key} }) . $footer; + if ($join) { + my $header = defined($extra2->{as_hash_header}) ? $extra2->{as_hash_header} + : defined($extra->{as_hash_header}) ? $extra->{as_hash_header} : ""; + my $footer = defined($extra2->{as_hash_footer}) ? $extra2->{as_hash_footer} + : defined($extra->{as_hash_footer}) ? $extra->{as_hash_footer} : ""; + foreach my $key (keys %return) { + $return{$key} = $header . join($join,@{ $return{$key} }) . $footer; + } } - } - return \%return; + return \%return; } ### return a user friendly error message sub get_error_text { - my $self = shift; - my $err = shift; - my $extra = $self->{extra} || {}; - my ($field, $type, $field_val, $ifs_match) = @$err; - my $dig = ($type =~ s/(_?\d+)$//) ? $1 : ''; - my $type_lc = lc($type); - - ### allow for delegated field names - only used for defaults - if ($field_val->{delegate_error}) { - $field = $field_val->{delegate_error}; - $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; - } - - ### the the name of this thing - my $name = $field_val->{'name'} || "The field $field"; - $name =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; - - ### type can look like "required" or "required2" or "required100023" - ### allow for fallback from required100023_error through required_error - my @possible_error_keys = ("${type}_error"); - unshift @possible_error_keys, "${type}${dig}_error" if length($dig); - - ### look in the passed hash or self first - my $return; - foreach my $key (@possible_error_keys){ - $return = $field_val->{$key} || $extra->{$key} || next; - $return =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; - $return =~ s/\$field/$field/g; - $return =~ s/\$name/$name/g; - if (my $value = $field_val->{"$type$dig"}) { - $return =~ s/\$value/$value/g if ! ref $value; + my $self = shift; + my $err = shift; + my $extra = $self->{extra} || {}; + my ($field, $type, $field_val, $ifs_match) = @$err; + my $dig = ($type =~ s/(_?\d+)$//) ? $1 : ''; + my $type_lc = lc($type); + + # allow for delegated field names - only used for defaults + if ($field_val->{delegate_error}) { + $field = $field_val->{delegate_error}; + $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + } + + # the the name of this thing + my $name = $field_val->{'name'}; + $name = "The field $field" if ! $name && ($field =~ /\W/ || ($field =~ /\d/ && $field =~ /\D/)); + if (! $name) { + $name = $field; + $name =~ tr/_/ /; + $name =~ s/\b(\w)/\u$1/g; + } + $name =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + + # type can look like "required" or "required2" or "required100023" + # allow for fallback from required100023_error through required_error + + # look in the passed hash or self first + my $return; + foreach my $key ((length($dig) ? "${type}${dig}_error" : ()), "${type}_error", 'error') { + $return = $field_val->{$key} || $extra->{$key} || next; + $return =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + $return =~ s/\$field/$field/g; + $return =~ s/\$name/$name/g; + if (my $value = $field_val->{"$type$dig"}) { + $return =~ s/\$value/$value/g if ! ref $value; + } + last; } - last; - } - ### set default messages - if (! $return) { - if ($type eq 'required' || $type eq 'required_if') { - $return = "$name is required."; + # set default messages + if (! $return) { + if ($type eq 'required' || $type eq 'required_if') { + $return = "$name is required."; - } elsif ($type eq 'min_values') { - my $n = $field_val->{"min_values${dig}"}; - my $values = ($n == 1) ? 'value' : 'values'; - $return = "$name had less than $n $values."; + } elsif ($type eq 'min_values') { + my $n = $field_val->{"min_values${dig}"}; + my $values = ($n == 1) ? 'value' : 'values'; + $return = "$name had less than $n $values."; - } elsif ($type eq 'max_values') { - my $n = $field_val->{"max_values${dig}"}; - my $values = ($n == 1) ? 'value' : 'values'; - $return = "$name had more than $n $values."; + } elsif ($type eq 'max_values') { + my $n = $field_val->{"max_values${dig}"}; + my $values = ($n == 1) ? 'value' : 'values'; + $return = "$name had more than $n $values."; - } elsif ($type eq 'enum') { - $return = "$name is not in the given list."; + } elsif ($type eq 'enum') { + $return = "$name is not in the given list."; - } elsif ($type eq 'equals') { - my $field2 = $field_val->{"equals${dig}"}; - my $name2 = $field_val->{"equals${dig}_name"} || "the field $field2"; - $name2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; - $return = "$name did not equal $name2."; + } elsif ($type eq 'equals') { + my $field2 = $field_val->{"equals${dig}"}; + my $name2 = $field_val->{"equals${dig}_name"} || "the field $field2"; + $name2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match; + $return = "$name did not equal $name2."; - } elsif ($type eq 'min_len') { - my $n = $field_val->{"min_len${dig}"}; - my $char = ($n == 1) ? 'character' : 'characters'; - $return = "$name was less than $n $char."; + } elsif ($type eq 'min_len') { + my $n = $field_val->{"min_len${dig}"}; + my $char = ($n == 1) ? 'character' : 'characters'; + $return = "$name was less than $n $char."; - } elsif ($type eq 'max_len') { - my $n = $field_val->{"max_len${dig}"}; - my $char = ($n == 1) ? 'character' : 'characters'; - $return = "$name was more than $n $char."; + } elsif ($type eq 'max_len') { + my $n = $field_val->{"max_len${dig}"}; + my $char = ($n == 1) ? 'character' : 'characters'; + $return = "$name was more than $n $char."; - } elsif ($type eq 'max_in_set') { - my $set = $field_val->{"max_in_set${dig}"}; - $return = "Too many fields were chosen from the set ($set)"; + } elsif ($type eq 'max_in_set') { + my $set = $field_val->{"max_in_set${dig}"}; + $return = "Too many fields were chosen from the set ($set)"; - } elsif ($type eq 'min_in_set') { - my $set = $field_val->{"min_in_set${dig}"}; - $return = "Not enough fields were chosen from the set ($set)"; + } elsif ($type eq 'min_in_set') { + my $set = $field_val->{"min_in_set${dig}"}; + $return = "Not enough fields were chosen from the set ($set)"; - } elsif ($type eq 'match') { - $return = "$name contains invalid characters."; + } elsif ($type eq 'match') { + $return = "$name contains invalid characters."; - } elsif ($type eq 'compare') { - $return = "$name did not fit comparison."; + } elsif ($type eq 'compare') { + $return = "$name did not fit comparison."; - } elsif ($type eq 'sql') { - $return = "$name did not match sql test."; + } elsif ($type eq 'sql') { + $return = "$name did not match sql test."; - } elsif ($type eq 'custom') { - $return = "$name did not match custom test."; + } elsif ($type eq 'custom') { + $return = "$name did not match custom test."; - } elsif ($type eq 'type') { - my $_type = $field_val->{"type${dig}"}; - $return = "$name did not match type $_type."; + } elsif ($type eq 'type') { + my $_type = $field_val->{"type${dig}"}; + $return = "$name did not match type $_type."; - } elsif ($type eq 'untaint') { - $return = "$name cannot be untainted without one of the following checks: enum, equals, match, compare, sql, type, custom"; + } elsif ($type eq 'untaint') { + $return = "$name cannot be untainted without one of the following checks: enum, equals, match, compare, sql, type, custom"; - } elsif ($type eq 'no_extra_fields') { - $return = "$name should not be passed to validate."; + } elsif ($type eq 'no_extra_fields') { + $return = "$name should not be passed to validate."; + } } - } - die "Missing error on field $field for type $type$dig" if ! $return; - return $return; + die "Missing error on field $field for type $type$dig" if ! $return; + return $return; } -###----------------------------------------------------------------### - 1; - -__END__ - -=head1 SYNOPSIS - - use CGI::Ex::Validate; - - ### THE SHORT - - my $errobj = CGI::Ex::Validate->new->validate($form, $val_hash); - - ### THE LONG - - my $form = CGI->new; - # OR # - my $form = CGI::Ex->new; # OR CGI::Ex->get_form; - # OR # - my $form = {key1 => 'val1', key2 => 'val2'}; - - - ### simplest - my $val_hash = { - username => { - required => 1, - max_len => 30, - field => 'username', - # field is optional in this case - will use key name - }, - email => { - required => 1, - max_len => 100, - type => 'email', - }, - email2 => { - equals => 'email', - }, - }; - - ### ordered (only onevent submit needs order) - my $val_hash = { - 'group order' => [qw(username email email2)], - username => {required => 1, max_len => 30}, - email => ..., - email2 => ..., - }; - - ### ordered again - my $val_hash = { - 'group fields' => [{ - field => 'username', # field is not optional in this case - required => 1, - max_len => 30, - }, { - field => 'email', - required => 1, - max_len => 100, - }, { - field => 'email2', - equals => 'email', - }], - }; - - - my $vob = CGI::Ex::Validate->new; - my $errobj = $vob->validate($form, $val_hash); - - # OR # - # import config using any type CGI::Ex::Conf supports - my $errobj = $vob->validate($form, "/somefile/somewhere.val"); - - if ($errobj) { - my $error_heading = $errobj->as_string; # OR "$errobj"; - my $error_list = $errobj->as_array; # ordered list of what when wrong - my $error_hash = $errobj->as_hash; # hash of arrayrefs of errors - } else { - # the form passed validation - } - - ### will add an error for any form key not found in $val_hash - my $vob = CGI::Ex::Validate->new({no_extra_keys => 1}); - my $errobj = $vob->validate($form, $val_hash); - - - my $js_uri_path = '/js/'; # static or dynamic URI path to find CGI/Ex/validate.js - my $form_name = "the_form"; # name of the form to attach javascript to - my $javascript = $vob->generate_js($val_hash, $form_name, $js_uri_path); - - -=head1 DESCRIPTION - -CGI::Ex::Validate is one of many validation modules. It aims to have -all of the basic data validation functions, avoid adding all of the -millions of possible types, while still giving the capability for the -developer to add their own types for the rare cases that the basic -ones don't suffice. Generally anything more than basic validation -probably needs programmatic or data based validation. - -CGI::Ex::Validate also has full support for providing the same -validation in javascript. It provides methods for attaching the -javascript to existing forms. This ability is tightly integrated into -CGI::Ex::App, but it should be easy to add validation just about -anywhere using any type of controller. - -As opposed to other kitchen sync validation modules, CGI::Ex::Validate -offers the simple types of validation, and makes it easy to add your -own custom types. Asside from custom and custom_js, all validation -markup is declarative. - -=head1 METHODS - -=over 4 - -=item C - -Used to instantiate the object. Arguments are either a hash, or hashref, -or nothing at all. Keys of the hash become the keys of the object. - -=item C - -Given a filename or YAML string will return perl hash. If more than one -group is contained in the file, it will return an arrayref of hashrefs. - - my $ref = $self->get_validation($file); - -=item C - -Given a filename or YAML string or a validation hashref, will return all -of the possible keys found in the validation hash. This can be used to -check to see if extra items have been passed to validate. If a second -argument contains a form hash is passed, get_validation_keys will only -return the keys of groups that were validated. - - my $key_hashref = $self->get_validation_keys($val_hash); - -The values of the hash are the names of the fields. - -=item C - -Arguments are a form hashref or cgi object, a validation hashref or -filename, and an optional what_was_validated arrayref (discussed -further later on). If a CGI object is passed, CGI::Ex::get_form will -be called on that object to turn it into a hashref. If a filename is -given for the validation, get_validation will be called on that -filename. If the what_was_validated_arrayref is passed - it will be -populated (pushed) with the field hashes that were actually validated -(anything that was skipped because of validate_if will not be in the -array). - -If the form passes validation, validate will return undef. If it -fails validation, it will return a CGI::Ex::Validate::Error object. -If the 'raise_error' option has been set, validate will die -with a CGI::Ex::validate::Error object as the value. - - my $err_obj = $self->validate($form, $val_hash); - - # OR # - - $self->{raise_error} = 1; # can also be listed in the val_hash - eval { $self->validate($form, $val_hash) }; - if ($@) { my $err_obj = $@; } - -=item C - -Works with CGI::Ex::JSONDump, but can also work with JSON or YAML -if desired (see L or L). - -Takes a validation hash, a form name, and an optional javascript uri -path and returns Javascript that can be embedded on a page and will -perform identical validations as the server side. The form name must be -the name of the form that the validation will act upon - the name is -used to register an onsubmit function. The javascript uri path is -used to embed the locations of javascript source files included -with the CGI::Ex distribution. - -The javascript uri path is highly dependent upon the server -configuration and therefore must be configured manually. It may be -passed to generate_js, or it may be specified in $JS_URI_PATH. There -are two files included with this module that are needed - -CGI/Ex/yaml_load.js and CGI/Ex/validate.js. When generating the js -code, generate_js will look in $JS_URI_PATH_YAML and -$JS_URI_PATH_VALIDATE. If either of these are not set, generate_js -will default to "$JS_URI_PATH/CGI/Ex/yaml_load.js" and -"$JS_URI_PATH/CGI/Ex/validate.js" (Note: yaml_load is only needed -if the flags no_jsondump and no_json have been set). - - $self->generate_js($val_hash, 'my_form', "/cgi-bin/js") - - # would generate something like the following... - - - ... more js follows ... - - $CGI::Ex::Validate::JS_URI_PATH = "/stock/js"; - $self->generate_js($val_hash, 'my_form') - - # would generate something like the following... - - - ... more js follows ... - -Referencing yaml_load.js and validate.js can be done in any of -several ways. They can be copied to or symlinked to a fixed location -in the server's html directory. They can also be printed out by a cgi. -The method C<-Eprint_js> has been provided in CGI::Ex for printing -js files found in the perl hierarchy. See L for more details. -The $JS_URI_PATH of "/cgi-bin/js" could contain the following: - - #!/usr/bin/perl -w - - use strict; - use CGI::Ex; - - ### path_info should contain something like /CGI/Ex/validate.js - my $info = $ENV{PATH_INFO} || ''; - die "Invalid path" if $info !~ m|^(/\w+)+.js$|; - $info =~ s|^/+||; - - CGI::Ex->new->print_js($info); - exit; - -The print_js method in CGI::Ex is designed to cache the javascript in -the browser. - -=item C<-Ecgix> - -Returns a CGI::Ex object. Used internally if a CGI object is -passed to validate rather than a straight form hash. - -=back - -=head1 VALIDATION HASH - -The validation hash may be passed as a hashref or as a filename, or as -a YAML document string. Experience has shown it to be better -programming to pass in a hashref. If the validation "hash" is a -filename or a YAML string, it will be translated into a hash using -CGI::Ex::Conf. - -Keys matching the regex m/^(general|group)\s+(\w+)$/ such as "group -onevent" are reserved and are counted as GROUP OPTIONS. Other keys -(if any, should be field names that need validation). - -If the GROUP OPTION 'group validate_if' is set, the validation will -only be validated if the conditions of the validate_if are met. If -'group validate_if' is not specified, then the validation will -proceed. See the validate_if VALIDATION type for more information. - -Each of the items listed in the validation will be validated. The -validation order is determined in one of three ways: - -=over 4 - -=item Specify 'group fields' arrayref. - - # order will be (username, password, 'm/\w+_foo/', somethingelse) - { - 'group title' => "User Information", - 'group fields' => [ - {field => 'username', required => 1}, - {field => 'password', required => 1}, - {field => 'm/\w+_foo/', required => 1}, - ], - somethingelse => {required => 1}, - } - -=item Specify 'group order' arrayref. - - # order will be (username, password, 'm/\w+_foo/', somethingelse) - { - 'group title' => "User Information", - 'group order' => [qw(username password), 'm/\w+_foo/'], - username => {required => 1}, - password => {required => 1}, - 'm/\w+_foo/' => {required => 1}, - somethingelse => {required => 1}, - } - -=item Do nothing - use sorted order. - - # order will be ('m/\w+_foo/', password, somethingelse, username) - { - 'group title' => "User Information", - username => {required => 1}, - password => {required => 1}, - 'm/\w+_foo/' => {required => 1}, - somethingelse => {required => 1}, - } - -=back - -Optionally the 'group fields' or the 'group order' may contain the -word 'OR' as a special keyword. If the item preceding 'OR' fails -validation the item after 'OR' will be tested instead. If the item -preceding 'OR' passes validation the item after 'OR' will not be -tested. - - 'group order' => [qw(zip OR postalcode state OR region)], - -At this time, only "group onevent" submit works with this option. Using -OR is deprecated. Instead you should use min_in_set or max_in_set. - - 'zip' => { - max_in_set: '1 of zip, postalcode', - }, - 'state' => { - max_in_set: '1 of state, region', - }, - -Each individual field validation hashref will operate on the field contained -in the 'field' key. This key may also be a regular expression in the -form of 'm/somepattern/'. If a regular expression is used, all keys -matching that pattern will be validated. If the field key is -not specified, the key from the top level hash will be used. - - foobar => { # "foobar" is not used as key because field is specified - field => 'real_key_name', - required => 1, - }, - real_key_name2 => { - required => 1, - }, - -Each of the individual field validation hashrefs should contain the -types listed in VALIDATION TYPES. - -=head1 VALIDATION TYPES - -This section lists the available validation types. Multiple instances -of the same type may be used for some validation types by adding a -number to the type (ie match, match2, match232). Multiple instances -are validated in sorted order. Types that allow multiple values are: -compare, custom, custom_js, equals, enum, match, required_if, sql, -type, validate_if, and replace (replace is a MODIFICATION TYPE). - -=over 4 - -=item C - -Allows for custom comparisons. Available types are ->, <, >=, <=, !=, ==, gt, lt, ge, le, ne, and eq. Comparisons -also work in the JS. - - { - field => 'my_number', - match => 'm/^\d+$/', - compare1 => '> 100', - compare2 => '< 255', - compare3 => '!= 150', - } - -=item C - -Custom value - not available in JS. Allows for extra programming types. -May be either a boolean value predetermined before calling validate, or may be -a coderef that will be called during validation. If coderef is called, it will -be passed the field name, the form value for that name, and a reference to the -field validation hash. If the custom type returns false the element fails -validation and an error is added. - - { - field => 'username', - custom => sub { - my ($key, $val, $type, $field_val_hash) = @_; - # do something here - return 0; - }, - } - -=item C - -Custom value - only available in JS. Allows for extra programming types. -May be a javascript function (if fully declared in javascript), a string containing -a javascript function (that will be eval'ed into a real function), -a boolean value pre-determined before calling validate, or may be -section of javascript that will be eval'ed (the last value of -the eval'ed javascript will determine if validation passed). A false response indicates -the value did not pass validation. A true response indicates that it did. See -the samples/validate_js_0_tests.html page for a sample of usages. - - { - field => 'date', - required => 1, - match => 'm|^\d\d\d\d/\d\d/\d\d$|', - match_error => 'Please enter date in YYYY/MM/DD format', - custom_js => "function (args) { - var t=new Date(); - var y=t.getYear()+1900; - var m=t.getMonth() + 1; - var d=t.getDate(); - if (m<10) m = '0'+m; - if (d<10) d = '0'+d; - (args.value > ''+y+'/'+m+'/'+d) ? 1 : 0; - }", - custom_js_error => 'The date was not greater than today.', - } - -=item C - -Allows for checking whether an item matches a set of options. In perl -the value may be passed as an arrayref. In the conf or in perl the -value may be passed of the options joined with ||. - - { - field => 'password_type', - enum => 'plaintext||crypt||md5', # OR enum => [qw(plaintext crypt md5)], - } - -=item C - -Allows for comparison of two form elements. Can have an optional !. - - { - field => 'password', - equals => 'password_verify', - }, - { - field => 'domain1', - equals => '!domain2', # make sure the fields are not the same - } - -=item C - -Typically used by a validate_if. Allows for checking if this item has had -an error. - - { - field => 'alt_password', - validate_if => {field => 'password', had_error => 1}, - } - -This is basically the opposite of was_valid. - -=item C - -Allows for regular expression comparison. Multiple matches may -be concatenated with ||. Available in JS. - - { - field => 'my_ip', - match => 'm/^\d{1,3}(\.\d{1,3})3$/', - match_2 => '!/^0\./ || !/^192\./', - } - -=item C and C - -Somewhat like min_values and max_values except that you specify the -fields that participate in the count. Also - entries that are not -defined or do not have length are not counted. An optional "of" can -be placed after the number for human readability. - - min_in_set => "2 of foo bar baz", - # two of the fields foo, bar or baz must be set - # same as - min_in_set => "2 foo bar baz", - # same as - min_in_set => "2 OF foo bar baz", - - validate_if => {field => 'whatever', max_in_set => '0 of whatever'}, - # only run validation if there were zero occurrences of whatever - -=item C - -Allows for check on the length of fields - - { - field => 'site', - min_len => 4, - max_len => 100, - } - -=item C and C - -Allows for specifying the maximum number of form elements passed. -max_values defaults to 1 (You must explicitly set it higher -to allow more than one item by any given name). - -=item C - -Requires the form field to have some value. If the field is not present, -no other checks will be run. - -=item C - -Requires the form field if the condition is satisfied. The conditions -available are the same as for validate_if. This is somewhat the same -as saying: - - validate_if => 'some_condition', - required => 1 - - required_if => 'some_condition', - -If a regex is used for the field name, the required_if -field will have any match patterns swapped in. - - { - field => 'm/^(\w+)_pass/', - required_if => '$1_user', - } - -This example would require the "foobar_pass" field to be set -if the "foobar_user" field was passed. - -=item C - -SQL query based - not available in JS. The database handle will be looked -for in the value $self->{dbhs}->{foo} if sql_db_type is set to 'foo', -otherwise it will default to $self->{dbh}. If $self->{dbhs}->{foo} or -$self->{dbh} is a coderef - they will be called and should return a dbh. - - { - field => 'username', - sql => 'SELECT COUNT(*) FROM users WHERE username = ?', - sql_error_if => 1, # default is 1 - set to 0 to negate result - # sql_db_type => 'foo', # will look for a dbh under $self->{dbhs}->{foo} - } - -=item C - -Allows for more strict type checking. Currently supported types -include CC (credit card), EMAIL, DOMAIN, IP, URL. Other types will be -added upon request provided we can add a perl and a javascript -version. - - { - field => 'credit_card', - type => 'CC', - } - -=item C - -If validate_if is specified, the field will only be validated -if the conditions are met. Works in JS. - - validate_if => {field => 'name', required => 1, max_len => 30} - # Will only validate if the field "name" is present and is less than 30 chars. - - validate_if => 'name', - # SAME as - validate_if => {field => 'name', required => 1}, - - validate_if => '! name', - # SAME as - validate_if => {field => 'name', max_in_set => '0 of name'}, - - validate_if => 'name was_valid', - # SAME as - validate_if => {field => 'name', was_valid => 1}, - - validate_if => {field => 'country', compare => "eq US"}, - # only if country's value is equal to US - - validate_if => {field => 'country', compare => "ne US"}, - # if country doesn't equal US - - validate_if => {field => 'password', match => 'm/^md5\([a-z0-9]{20}\)$/'}, - # if password looks like md5(12345678901234567890) - - { - field => 'm/^(\w+)_pass/', - validate_if => '$1_user', - required => 1, - } - # will validate foo_pass only if foo_user was present. - -The validate_if may also contain an arrayref of validation items. So that -multiple checks can be run. They will be run in order. validate_if will -return true only if all options returned true. - - validate_if => ['email', 'phone', 'fax'] - -Optionally, if validate_if is an arrayref, it may contain the word -'OR' as a special keyword. If the item preceding 'OR' fails validation -the item after 'OR' will be tested instead. If the item preceding 'OR' -passes validation the item after 'OR' will not be tested. - - validate_if => [qw(zip OR postalcode)], - -=item C - -Typically used by a validate_if. Allows for checking if this item has successfully -been validated. - - { - field => 'password2', - validate_if => {field => 'password', was_valid => 1}, - } - -This is basically the opposite of was_valid. - -=back - -=head1 SPECIAL VALIDATION TYPES - -=over 4 - -=item C - -Specify which field to work on. Key may be a regex in the form 'm/\w+_user/'. -This key is required if 'group fields' is used or if validate_if or required_if -are used. It can optionally be used with other types to specify a different form -element to operate on. On errors, if a non-default error is found, $field -will be swapped with the value found in field. - -The field name may also be a regular expression in the -form of 'm/somepattern/'. If a regular expression is used, all keys -matching that pattern will be validated. - -=item C - -Name to use for errors. If a name is not specified, default errors will use -"The field $field" as the name. If a non-default error is found, $name -will be swapped with this name. - -=item C - -This option allows for any errors generated on a field to delegate to -a different field. If the field name was a regex, any patterns will -be swapped into the delegate_error value. This option is generally only -useful with the as_hash method of the error object (for inline errors). - - { - field => 'zip', - match => 'm/^\d{5}/', - }, - { - field => 'zip_plus4', - match => 'm/^\d{4}/', - delegate_error => 'zip', - }, - { - field => 'm/^(id_[\d+])_user$/', - delegate_error => '$1', - }, - -=item C - -This allows the cgi to do checking while keeping the checks from -being run in JavaScript - - { - field => 'cgi_var', - required => 1, - exclude_js => 1, - } - -=item C - -This allows the js to do checking while keeping the checks from -being run in the cgi - - { - field => 'js_var', - required => 1, - exclude_cgi => 1, - } - -=item C - -Only functions in javascript. Will mark set the form element to -disabled if validate_if fails. It will mark it as enabled if -validate_if is successful. This item should normally only be used -when onevent includes "change" or "blur". - -=back - -=head1 MODIFYING VALIDATION TYPES - -The following types will modify the form value before it is processed. -They work in both the perl and in javascript as well. The javascript -version changes the actual value in the form on appropriate form types. - -=over 4 - -=item C - -By default, validate will trim leading and trailing whitespace -from submitted values. Set do_not_trim to 1 to allow it to -not trim. - - {field => 'foo', do_not_trim => 1} - -=item C - -Off by default. If set to true, removes characters in the -\x00 to \x31 range (Tabs are translated to a single space). - - {field => 'foo', trim_control_chars => 1} - -=item C - -Pass a swap pattern to change the actual value of the form. -Any perl regex can be passed but it is suggested that javascript -compatible regexes are used to make generate_js possible. - - {field => 'foo', replace => 's/(\d{3})(\d{3})(\d{3})/($1) $2-$3/'} - -=item C - -Set item to default value if there is no existing value (undefined -or zero length string). - - {field => 'country', default => 'EN'} - -=item C and C - -Do what they say they do. - -=item C - -Requires that the validated field has been also checked with -an enum, equals, match, compare, custom, or type check. If the -field has been checked and there are no errors - the field is "untainted." - -This is for use in conjunction with perl's -T switch. - -=item C - -Clears the form field should a validation error occur. Only supported -on the Javascript side (no affect on the server side). - -=back - -=head1 ERROR OBJECT - -Failed validation results in an error an error object created via the -new_error method. The default error class is CGI::Ex::Validate::Error. - -The error object has several methods for determining what the errors were. - -=over 4 - -=item C - -Returns an array or arrayref (depending on scalar context) of errors that -occurred in the order that they occurred. Individual groups may have a heading -and the entire validation will have a heading (the default heading can be changed -via the 'as_array_title' group option). Each error that occurred is a separate -item and are pre-pended with 'as_array_prefix' (which is a group option - default -is ' '). The as_array_ options may also be set via a hashref passed to as_array. -as_array_title defaults to 'Please correct the following items:'. - - ### if this returns the following - my $array = $err_obj->as_array; - # $array looks like - # ['Please correct the following items:', ' error1', ' error2'] - - ### then this would return the following - my $array = $err_obj->as_array({ - as_array_prefix => ' - ', - as_array_title => 'Something went wrong:', - }); - # $array looks like - # ['Something went wrong:', ' - error1', ' - error2'] - -=item C - -Returns values of as_array joined with a newline. This method is used as -the stringification for the error object. Values of as_array are joined with -'as_string_join' which defaults to "\n". If 'as_string_header' is set, it will -be pre-pended onto the error string. If 'as_string_footer' is set, it will be -appended onto the error string. - - ### if this returns the following - my $string = $err_obj->as_string; - # $string looks like - # "Please correct the following items:\n error1\n error2" - - ### then this would return the following - my $string = $err_obj->as_string({ - as_array_prefix => ' - ', - as_array_title => 'Something went wrong:', - as_string_join => '
', - as_string_header => '', - as_string_footer => '', - }); - # $string looks like - # 'Something went wrong:
- error1
- error2
' - -=item C - -Returns a hash or hashref (depending on scalar context) of errors that -occurred. Each key is the field name of the form that failed -validation with 'as_hash_suffix' added on as a suffix. as_hash_suffix -is available as a group option and may also be passed in via a -hashref as the only argument to as_hash. The default value is -'_error'. The values of the hash are arrayrefs of errors that -occurred to that form element. - -By default as_hash will return the values of the hash as arrayrefs (a -list of the errors that occurred to that key). It is possible to also -return the values as strings. Three options are available for -formatting: 'as_hash_header' which will be pre-pended onto the error -string, 'as_hash_footer' which will be appended, and 'as_hash_join' -which will be used to join the arrayref. The only argument required -to force the stringification is 'as_hash_join'. - - ### if this returns the following - my $hash = $err_obj->as_hash; - # $hash looks like - # {key1_error => ['error1', 'error2']} - - ### then this would return the following - my $hash = $err_obj->as_hash({ - as_hash_suffix => '_foo', - as_hash_join => '
', - as_hash_header => '' - as_hash_footer => '' - }); - # $hash looks like - # {key1_foo => 'error1
error2
'} - -=back - -=head1 GROUP OPTIONS - -Any key in a validation hash matching the pattern -m/^(group|general)\s+(\w+)$/ is considered a group option (the reason -that either group or general may be used is that CGI::Ex::Validate -used to have the concept of validation groups - these were not -commonly used so support has been deprecated as of the 2.10 release). -Group options will also be looked for in the Validate object ($self) -and can be set when instantiating the object ($self->{raise_error} is -equivalent to $valhash->{'group raise_error'}). - -Options may also be set globally before calling validate by -populating the %DEFAULT_OPTIONS global hash. However, only the options -set properly in the $valhash will be passed to the javascript. - -=over 4 - -=item C - -Used as a group section heading when as_array or as_string is called -by the error object. - - 'group title' => 'Title of errors', - -=item C<order> - -Order in which to validate key/value pairs of group. - - 'group order' => [qw(user pass email OR phone)], - -=item C<fields> - -Arrayref of validation items to validate. - - 'group fields' => [{ - field => 'field1', - required => 1, - }, { - field => 'field2', - required => 1, - }], - -=item C<validate_if> - -If specified - the entire hashref will only be validated if -the "if" conditions are met. - - 'group validate_if => {field => 'email', required => 1}, - -This group would only validate all fields if the email field -was present. - -=item C<raise_error> - -If raise_error is true, any call to validate that fails validation -will die with an error object as the value. - -=item C<no_extra_fields> - -If no_extra_fields is true, validate will add errors for any field found -in form that does not have a field_val hashref in the validation hash. -Default is false. If no_extra_fields is set to 'used', it will check for -any keys that were not in a group that was validated. - -An important exception to this is that field_val hashrefs or field names listed -in a validate_if or required_if statement will not be included. You must -have an explicit entry for each key. - -=item C<\w+_error> - -These items allow for an override of the default errors. - - 'group required_error' => '$name is really required', - 'group max_len_error' => '$name must be shorter than $value characters', - # OR # - my $self = CGI::Ex::Validate->new({ - max_len_error => '$name must be shorter than $value characters', - }); - -=item C<as_array_title> - -Used as the section title for all errors that occur, when as_array -or as_string is called by the error object. - -=item C<as_array_prefix> - -Used as prefix to individual errors that occur, when as_array -or as_string is called by the error object. Each individual error -will be prefixed with this string. Headings will not be prefixed. -Default is ' '. - -=item C<as_string_join> - -When as_string is called, the values from as_array will be joined with -as_string_join. Default value is "\n". - -=item C<as_string_header> - -If set, will be pre-pended onto the string when as_string is called. - -=item C<as_string_footer> - -If set, will be pre-pended onto the string when as_string is called. - -=item C<as_hash_suffix> - -Added on to key names during the call to as_hash. Default is '_error'. - -=item C<as_hash_join> - -By default, as_hash will return hashref values that are errors joined with -the default as_hash_join value of <br />. It can also return values that are -arrayrefs of the errors. This can be done by setting as_hash_join to a non-true value -(for example '') - -=item C<as_hash_header> - -If as_hash_join has been set to a true value, as_hash_header may be set to -a string that will be pre-pended on to the error string. - -=item C<as_hash_footer> - -If as_hash_join has been set to a true value, as_hash_footer may be set to -a string that will be postpended on to the error string. - -=item C<onevent> - -Defaults to {submit => 1}. This controls when the javascript validation -will take place. May be passed any or all or load, submit, change, or blur. -Multiple events may be passed in the hash. - - 'group onevent' => {submit => 1, change => 1}', - -A comma separated string of types may also be passed: - - 'group onevent' => 'submit,change,blur,load', - -Currently, change and blur will not work for dynamically matched -field names such as 'm/\w+/'. Support will be added. - -=item C<set_hook> - -Defaults document.validate_set_hook which defaults to nothing. If -"group set_hook" or document.validate_set_hook are set to a function, -they will be passed the key name of a form element that had a -validation error and the error that will be set. If a true value is -returned, then validate will not also the inline error. If no value -or false is returned (default) the validate will continue setting the -inline error. This gives full control over setting inline -errors. samples/validate_js_2_onchange.html has a good example of -using these hooks. - - 'group set_hook' => "function (args) { - alert("Setting error to field "+args.key); - }", - -The args parameter includes key, value, val_hash, and form. - -The document.validate_set_hook option is probably the better option to use, -as it helps to separate display functionality out into your html templates -rather than storing too much html logic in your CGI. - -=item C<clear_hook> - -Similar to set_hook, but called when inline error is cleared. Its -corresponding default is document.validate_clear_hook. The clear hook -is also sampled in samples/validate_js_2_onchange.html - - 'group clear_hook' => "function (args) { - alert("Clear error on field "+args.key); - }", - -The args parameter includes key, val_hash, form, and was_valid. - -=item C<no_inline> - -If set to true, the javascript validation will not attempt to generate -inline errors when the only "group onevent" type is "submit". Default -is true. Inline errors are independent of confirm and alert errors. - - 'group no_inline' => 1, - -=item C<no_confirm> - -If set to true, the javascript validation will try to use an alert -instead of a confirm to inform the user of errors when one of the -"group onevent" types is "submit". Alert and confirm are independent -or inline errors. Default is false. - - 'group no_confirm' => 1, - -=item C<no_alert> - -If set to true, the javascript validation will not show an alert box -when errors occur. Default is false. This option only comes into -play if no_confirm is also set. This option is only in effect if -"group onevent" includes "submit". This option is independent of -inline errors. Although it is possible to turn off all errors by -setting no_inline, no_confirm, and no_alert all to 1, it is suggested -that at least one of the error reporting facilities is left on. - - 'group no_alert' => 1, - -=back - -=head1 JAVASCRIPT - -CGI::Ex::Validate provides for having duplicate validation on the -client side as on the server side. Errors can be shown in any -combination of inline and confirm, inline and alert, inline only, -confirm only, alert only, and none. These combinations are controlled -by the group options no_inline, no_confirm, and no_alert. -Javascript validation can be generated for a page using the -C<-E<gt>generate_js> Method of CGI::Ex::Validate. It is also possible -to store the validation inline with the html. This can be done by -giving each of the elements to be validated an attribute called -"validation", or by setting a global javascript variable called -"document.validation" or "var validation". An html file containing this -validation will be read in using CGI::Ex::Conf::read_handler_html. - -All inline html validation must be written in yaml. - -It is anticipated that the html will contain something like one of the -following examples: - - <script src="/cgi-bin/js/CGI/Ex/validate.js"></script> - <script> - document.validation = { - 'group no_confirm': 1, - 'group no_alert': 1, - 'group onevent': 'change,blur,submit', - 'group order': ['username', 'password'], - username: { - required: 1, - max_len: 20 - }, - password: { - required: 1, - max_len: 30 - } - }; - if (document.check_form) document.check_form('my_form_name'); - </script> - -Prior to the realization of JSON, YAML was part of the method -for introducing validation into the script. - - <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script> - <script src="/cgi-bin/js/CGI/Ex/validate.js"></script> - <script> - // \n\ allows all browsers to view this as a single string - document.validation = "\n\ - general no_confirm: 1\n\ - general no_alert: 1\n\ - group order: [username, password]\n\ - username:\n\ - required: 1\n\ - max_len: 20\n\ - password:\n\ - required: 1\n\ - max_len: 30\n\ - "; - if (document.check_form) document.check_form('my_form_name'); - </script> - -Alternately, CGI/Ex/validate.js can parse the YAML from html -form element attributes: - - <form name="my_form_name"> - - Username: <input type=text size=20 name=username validation=" - required: 1 - max_len: 20 - "><br> - <span class=error id=username_error>[% username_error %]</span><br> - - Password: <input type=text size=20 name=password validation=" - required: 1 - max_len: 30 - "><br> - <span class=error id=password_error>[% password_error %]</span><br> - - <input type=submit> - - </form> - - <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script> - <script src="/cgi-bin/js/CGI/Ex/validate.js"></script> - <script> - if (document.check_form) document.check_form('my_form_name'); - </script> - -The read_handler_html from CGI::Ex::Conf will find the YAML types -of validation. The JSON type is what would be generated by default -when the validation is specified in Perl. - -If inline errors are enabled (default), each error that occurs will attempt -to find an html element with its name as the id. For example, if -the field "username" failed validation and created a "username_error", -the javascript would set the html of <span id="username_error"></span> -to the error message. - -It is suggested to use something like the following so that you can -have inline javascript validation as well as report validation errors -from the server side as well. - - <span class=error id=password_error>[% password_error %]</span><br> - -If the javascript fails for some reason, the form should still be able -to submit as normal (fail gracefully). - -Additionally, there are two hooks that are called when ever an inline -error is set or cleared. The following hooks are used in -samples/validate_js_2_onchange.html to highlight the row and set an icon. - - document.validate_set_hook = function (args) { - document.getElementById(args.key+'_img').innerHTML - = '<span style="font-weight:bold;color:red">!</span>'; - document.getElementById(args.key+'_row').style.background - = '#ffdddd'; - }; - - document.validate_clear_hook = function (args) { - if (args.was_valid) { - document.getElementById(args.key+'_img').innerHTML - = '<span style="font-weight:bold;color:green">+</span>'; - document.getElementById(args.key+'_row').style.background - = '#ddffdd'; - } else { - document.getElementById(args.key+'_img').innerHTML = ''; - document.getElementById(args.key+'_row').style.background = '#fff'; - } - }; - -These hooks can also be set as "group clear_hook" and "group set_hook" -which are defined further above. - -If the confirm option is used ("group onevent" includes submit and -"group no_confirm" is false), the errors will be displayed to the -user. If they choose OK they will be able to try and fix the errors. -If they choose cancel, the form will submit anyway and will rely on -the server to do the validation. This is for fail safety to make sure -that if the javascript didn't validate correctly, the user can still -submit the data. - -=head1 THANKS - -Thanks to Eamon Daly for providing bug fixes for bugs in validate.js -caused by HTML::Prototype. - -=head1 LICENSE - -This module may be distributed under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Seamons <paul at seamons dot com> - -=cut +### See the perldoc in CGI/Ex/Validate.pod diff --git a/lib/CGI/Ex/Validate.pod b/lib/CGI/Ex/Validate.pod new file mode 100644 index 0000000..b7bce19 --- /dev/null +++ b/lib/CGI/Ex/Validate.pod @@ -0,0 +1,1120 @@ +=head1 NAME + +CGI::Ex::Validate - The "Just Right" form validator with javascript in parallel + +=head1 SYNOPSIS + +use CGI::Ex::Validate; + + # THE SHORT + + my $errobj = CGI::Ex::Validate->new->validate($form, $val_hash); + + # THE LONG + + my $form = CGI->new; + # OR # + my $form = CGI::Ex->new; # OR CGI::Ex->get_form; + # OR # + my $form = {key1 => 'val1', key2 => 'val2'}; + + + # simplest + my $val_hash = { + 'group order' => [qw(username email email2)], + username => { + required => 1, + max_len => 30, + field => 'username', + # field is optional in this case - will use key name + }, + email => { + required => 1, + max_len => 100, + type => 'email', + }, + email2 => { + equals => 'email', + }, + }; + + # ordered + my $val_hash = { + 'group order' => [{ + field => 'username', # field is not optional in this case + required => 1, + max_len => 30, + }, { + field => 'email', + required => 1, + max_len => 100, + }, { + field => 'email2', + equals => 'email', + }], + }; + + + my $vob = CGI::Ex::Validate->new; + my $errobj = $vob->validate($form, $val_hash); + if ($errobj) { + # get errors back in any of several useful ways + my $error_heading = $errobj->as_string; # OR "$errobj"; + my $error_list = $errobj->as_array; # ordered list of what when wrong + my $error_hash = $errobj->as_hash; # hash of arrayrefs of errors + } else { + # the form passed validation + } + + + my $js_uri_path = '/js/'; # static or dynamic URI path to find CGI/Ex/validate.js + my $form_name = "the_form"; # name of the form to attach javascript to + + # generate javascript to validate an existing form + my $javascript = $vob->generate_js($val_hash, { + form_name => $form_name, + js_uri_path => $js_uri_path, + }); + + # OR let Validate create the form and javascript for you + my $form = $vob->generate_form($val_hash, { + form_name => $form_name, # will use a random name if not passed + js_uri_path => $js_uri_path, + }); + + +=head1 DESCRIPTION + +CGI::Ex::Validate is one of many validation modules. It aims to have +all of the basic data validation functions, avoid adding all of +the millions of possible types, while still giving the capability +for the developer to add their own types for the rare cases that +the basic ones don't suffice. Generally anything more than basic +validation probably needs programmatic or data based validation. + +CGI::Ex::Validate also has full support for providing the same +validation in javascript. It provides methods for attaching the +javascript to existing forms. This ability is tightly integrated into +CGI::Ex::App, but it should be easy to add validation just about +anywhere using any type of controller. + +As opposed to other kitchen sync validation modules, CGI::Ex::Validate +offers the simple types of validation, and makes it easy to add your +own custom types. Asside from custom and custom_js, all validation +markup is declarative. + +=head1 METHODS + +=over 4 + +=item C<new> + +Used to instantiate the object. Arguments are either a hash, or hashref, +or nothing at all. Keys of the hash become the keys of the object. + +=item C<get_validation> + +Uses CGI::Ex::Conf::conf_read to read in the hash. conf_read will all passing +a filename or YAML string or a hashref. + +=item C<get_validation_keys> + +Takes the validation hashref returned from get_validation. Will return all +of the possible keys found in the validation hashref. This can be used to +check to see if extra items have been passed to validate. If a second +argument contains a form hash is passed, get_validation_keys will only +return the keys of groups that were validated. + + my $key_hashref = $self->get_validation_keys($val_hash); + +The keys of the hash are the names of the fields. + +=item C<validate> + +Arguments are a form hashref or cgi object, a validation hashref or +filename, and an optional what_was_validated arrayref (discussed +further later on). If a CGI object is passed, CGI::Ex::get_form will +be called on that object to turn it into a hashref. If a filename is +given for the validation, get_validation will be called on that +filename. If the what_was_validated_arrayref is passed - it will be +populated (pushed) with the field hashes that were actually validated +(anything that was skipped because of validate_if will not be in the +array). + +If the form passes validation, validate will return undef. If it +fails validation, it will return a CGI::Ex::Validate::Error object. +If the 'raise_error' option has been set, validate will die with a +CGI::Ex::validate::Error object as the value. + + my $err_obj = $self->validate($form, $val_hash); + + # OR # + + $self->{raise_error} = 1; # can also be listed in the val_hash + eval { $self->validate($form, $val_hash) }; + if ($@) { my $err_obj = $@; } + +=item C<generate_form> + +Takes a validation hash, and additional arguments and generates an HTML form suitable +for inclusion in a web based application. + + my $html = $self->generate_form($val_hash, { + form_name => 'my_form', + js_uri_path => '/cgi-bin/js', # will be used by generate_js + }); + +=item C<generate_js> + +Works with CGI::Ex::JSONDump. + +Takes a validation hash, a form name, and an optional javascript uri +path and returns Javascript that can be embedded on a page and will +perform identical validations as the server side. The form name must be +the name of the form that the validation will act upon - the name is +used to register an onsubmit function. The javascript uri path is +used to embed the locations of javascript source files included +with the CGI::Ex distribution. + +The javascript uri path is highly dependent upon the server +configuration and therefore must be configured manually. It may be +passed to generate_js, or it may be specified in $JS_URI_PATH. +There is one file included with this module that is needed - +CGI/Ex/validate.js. When generating the js code, generate_js will +look in $JS_URI_PATH_VALIDATE. If this is not set, +generate_js will use "$JS_URI_PATH/CGI/Ex/validate.js". + + my $js = $self->generate_js($val_hash, 'my_form', "/cgi-bin/js") + # OR + my $js = $self->generate_js($val_hash, { + form_name => 'my_form', + js_uri_path => '/cgi-bin/js', + }); + + # would generate something like the following... + + <script src="/cgi-bin/js/CGI/Ex/validate.js"></script> + ... more js follows ... + + $CGI::Ex::Validate::JS_URI_PATH = "/stock/js"; + $self->generate_js($val_hash, 'my_form') + + # would generate something like the following... + + <script src="/stock/js/CGI/Ex/validate.js"></script> + ... more js follows ... + +Referencing validate.js can be done in any of +several ways. It can be copied to or symlinked to a fixed location +in the server's html directory. It can also be printed out by a cgi. +The method C<-E<gt>print_js> has been provided in CGI::Ex for printing +js files found in the perl hierarchy. See L<CGI::Ex> for more details. +The $JS_URI_PATH of "/cgi-bin/js" could contain the following: + + #!/usr/bin/perl -w + + use strict; + use CGI::Ex; + + # path_info should contain something like /CGI/Ex/validate.js + my $info = $ENV{PATH_INFO} || ''; + die "Invalid path" if $info !~ m|^(/\w+)+.js$|; + $info =~ s|^/+||; + + CGI::Ex->new->print_js($info); + exit; + +The print_js method in CGI::Ex is designed to cache the javascript in +the browser. + +=item C<-E<gt>cgix> + +Returns a CGI::Ex object. Used internally if a CGI object is +passed to validate rather than a straight form hash. + +=back + +=head1 VALIDATION HASH + +The validation hash may be passed as a hashref or as a filename, or as +a YAML document string. Experience has shown it to be better +programming to pass in a hashref. If the validation "hash" is a +filename or a YAML string, it will be translated into a hash using +CGI::Ex::Conf. + +Keys matching the regex m/^group \s+ (\w+)$/x such as "group +onevent" are reserved and are counted as GROUP OPTIONS. Other keys +(if any, should be field names that need validation). + +If the GROUP OPTION 'group validate_if' is set, the validation will +only be validated if the conditions of the validate_if are met. If +'group validate_if' is not specified, then the validation will +proceed. See the validate_if VALIDATION type for more information. + +Each of the items listed in the validation will be validated. The +validation order is determined the following ways: + +=over 4 + +=item Specify 'group order' arrayref with hashrefs. + + # order will be (username, password, 'm/\w+_foo/', somethingelse) + { + 'group title' => "User Information", + 'group order' => [ + {field => 'username', required => 1}, + {field => 'password', required => 1}, + {field => 'm/\w+_foo/', required => 1}, + ], + somethingelse => {required => 1}, + } + +=item Specify 'group order' arrayref with field key names. + + # order will be (username, password, 'm/\w+_foo/', somethingelse) + { + 'group title' => "User Information", + 'group order' => [qw(username password), 'm/\w+_foo/'], + username => {required => 1}, + password => {required => 1}, + 'm/\w+_foo/' => {required => 1}, + somethingelse => {required => 1}, + } + +=item Do nothing - use sorted order. + + # order will be ('m/\w+_foo/', password, somethingelse, username) + { + 'group title' => "User Information", + username => {required => 1}, + password => {required => 1}, + 'm/\w+_foo/' => {required => 1}, + somethingelse => {required => 1}, + } + +=back + +Optionally the 'group order' may contain the word 'OR' as a special +keyword. If the item preceding 'OR' fails validation the item after +'OR' will be tested instead. If the item preceding 'OR' passes +validation the item after 'OR' will not be tested. + + 'group order' => [qw(zip OR postalcode state OR region)], + +At this time, only "group onevent" submit works with this option. +Using OR is not needed if testing for one or more values -- instead you +should use min_in_set or max_in_set (OR is still useful for other cases). + + 'zip' => { + max_in_set: '1 of zip, postalcode', + }, + 'state' => { + max_in_set: '1 of state, region', + }, + +Each individual field validation hashref will operate on the field contained +in the 'field' key. This key may also be a regular expression in the +form of 'm/somepattern/'. If a regular expression is used, all keys +matching that pattern will be validated. If the field key is +not specified, the key from the top level hash will be used. + + foobar => { # "foobar" is not used as key because field is specified + field => 'real_key_name', + required => 1, + }, + real_key_name2 => { + required => 1, + }, + +Each of the individual field validation hashrefs should contain the +types listed in VALIDATION TYPES. + +=head1 VALIDATION TYPES + +This section lists the available validation types. Multiple instances +of the same type may be used for some validation types by adding a +number to the type (ie match, match2, match232). Multiple instances +are validated in sorted order. Types that allow multiple values are: +compare, custom, custom_js, equals, enum, match, required_if, sql, +type, validate_if, and replace (replace is a MODIFICATION TYPE). + +=over 4 + +=item C<compare> + +Allows for custom comparisons. Available types are +>, <, >=, <=, !=, ==, gt, lt, ge, le, ne, and eq. Comparisons +also work in the JS. + + { + field => 'my_number', + match => 'm/^\d+$/', + compare1 => '> 100', + compare2 => '< 255', + compare3 => '!= 150', + } + +=item C<custom> + +Custom value - not available in JS. Allows for extra programming types. +May be either a boolean value predetermined before calling validate, or may be +a coderef that will be called during validation. If coderef is called, it will +be passed the field name, the form value for that name, and a reference to the +field validation hash. If the custom type returns false the element fails +validation and an error is added. + + { + field => 'username', + custom => sub { + my ($key, $val, $type, $field_val_hash) = @_; + # do something here + return 0; + }, + } + +=item C<custom_js> + +Custom value - only available in JS. Allows for extra programming types. +May be a javascript function (if fully declared in javascript), a string containing +a javascript function (that will be eval'ed into a real function), +a boolean value pre-determined before calling validate, or may be +section of javascript that will be eval'ed (the last value of +the eval'ed javascript will determine if validation passed). A false response indicates +the value did not pass validation. A true response indicates that it did. See +the samples/validate_js_0_tests.html page for a sample of usages. + + { + field => 'date', + required => 1, + match => 'm|^\d\d\d\d/\d\d/\d\d$|', + match_error => 'Please enter date in YYYY/MM/DD format', + custom_js => "function (args) { + var t=new Date(); + var y=t.getYear()+1900; + var m=t.getMonth() + 1; + var d=t.getDate(); + if (m<10) m = '0'+m; + if (d<10) d = '0'+d; + (args.value > ''+y+'/'+m+'/'+d) ? 1 : 0; + }", + custom_js_error => 'The date was not greater than today.', + } + +=item C<enum> + +Allows for checking whether an item matches a set of options. In perl +the value may be passed as an arrayref. In the conf or in perl the +value may be passed of the options joined with ||. + + { + field => 'password_type', + enum => 'plaintext||crypt||md5', # OR enum => [qw(plaintext crypt md5)], + } + +=item C<equals> + +Allows for comparison of two form elements. Can have an optional !. + + { + field => 'password', + equals => 'password_verify', + }, + { + field => 'domain1', + equals => '!domain2', # make sure the fields are not the same + } + +=item C<had_error> + +Typically used by a validate_if. Allows for checking if this item has had +an error. + + { + field => 'alt_password', + validate_if => {field => 'password', had_error => 1}, + } + +This is basically the opposite of was_valid. + +=item C<match> + +Allows for regular expression comparison. Multiple matches may +be concatenated with ||. Available in JS. + + { + field => 'my_ip', + match => 'm/^\d{1,3}(\.\d{1,3})3$/', + match_2 => '!/^0\./ || !/^192\./', + } + +=item C<max_in_set> and C<min_in_set> + +Somewhat like min_values and max_values except that you specify the +fields that participate in the count. Also - entries that are not +defined or do not have length are not counted. An optional "of" can +be placed after the number for human readability. + + min_in_set => "2 of foo bar baz", + # two of the fields foo, bar or baz must be set + # same as + min_in_set => "2 foo bar baz", + # same as + min_in_set => "2 OF foo bar baz", + + validate_if => {field => 'whatever', max_in_set => '0 of whatever'}, + # only run validation if there were zero occurrences of whatever + +=item C<max_len and min_len> + +Allows for check on the length of fields + + { + field => 'site', + min_len => 4, + max_len => 100, + } + +=item C<max_values> and C<min_values> + +Allows for specifying the maximum number of form elements passed. +max_values defaults to 1 (You must explicitly set it higher +to allow more than one item by any given name). + +=item C<required> + +Requires the form field to have some value. If the field is not present, +no other checks will be run. + +=item C<required_if> + +Requires the form field if the condition is satisfied. The conditions +available are the same as for validate_if. This is somewhat the same +as saying: + + validate_if => 'some_condition', + required => 1 + + required_if => 'some_condition', + +If a regex is used for the field name, the required_if +field will have any match patterns swapped in. + + { + field => 'm/^(\w+)_pass/', + required_if => '$1_user', + } + +This example would require the "foobar_pass" field to be set +if the "foobar_user" field was passed. + +=item C<sql> + +SQL query based - not available in JS. The database handle will be looked +for in the value $self->{dbhs}->{foo} if sql_db_type is set to 'foo', +otherwise it will default to $self->{dbh}. If $self->{dbhs}->{foo} or +$self->{dbh} is a coderef - they will be called and should return a dbh. + + { + field => 'username', + sql => 'SELECT COUNT(*) FROM users WHERE username = ?', + sql_error_if => 1, # default is 1 - set to 0 to negate result + # sql_db_type => 'foo', # will look for a dbh under $self->{dbhs}->{foo} + } + +=item C<type> + +Allows for more strict type checking. Currently supported types +include CC (credit card), EMAIL, DOMAIN, IP, URL. Other types will be +added upon request provided we can add a perl and a javascript +version. + + { + field => 'credit_card', + type => 'CC', + } + +=item C<validate_if> + +If validate_if is specified, the field will only be validated +if the conditions are met. Works in JS. + + validate_if => {field => 'name', required => 1, max_len => 30} + # Will only validate if the field "name" is present and is less than 30 chars. + + validate_if => 'name', + # SAME as + validate_if => {field => 'name', required => 1}, + + validate_if => '! name', + # SAME as + validate_if => {field => 'name', max_in_set => '0 of name'}, + + validate_if => 'name was_valid', + # SAME as + validate_if => {field => 'name', was_valid => 1}, + + validate_if => {field => 'country', compare => "eq US"}, + # only if country's value is equal to US + + validate_if => {field => 'country', compare => "ne US"}, + # if country doesn't equal US + + validate_if => {field => 'password', match => 'm/^md5\([a-z0-9]{20}\)$/'}, + # if password looks like md5(12345678901234567890) + + { + field => 'm/^(\w+)_pass/', + validate_if => '$1_user', + required => 1, + } + # will validate foo_pass only if foo_user was present. + +The validate_if may also contain an arrayref of validation items. So that +multiple checks can be run. They will be run in order. validate_if will +return true only if all options returned true. + + validate_if => ['email', 'phone', 'fax'] + +Optionally, if validate_if is an arrayref, it may contain the word +'OR' as a special keyword. If the item preceding 'OR' fails validation +the item after 'OR' will be tested instead. If the item preceding 'OR' +passes validation the item after 'OR' will not be tested. + + validate_if => [qw(zip OR postalcode)], + +=item C<was_valid> + +Typically used by a validate_if. Allows for checking if this item has successfully +been validated. + + { + field => 'password2', + validate_if => {field => 'password', was_valid => 1}, + } + +This is basically the opposite of had_error. + +=back + +=head1 SPECIAL VALIDATION TYPES + +=over 4 + +=item C<field> + +Specify which field to work on. Key may be a regex in the form +'m/\w+_user/'. This key is required in a hashref passed to 'group +order'. It can optionally be used with other types to specify a +different form element to operate on. On errors, if a non-default +error is found, $field will be swapped with the value found in field. + +The field name may also be a regular expression in the +form of 'm/somepattern/'. If a regular expression is used, all keys +matching that pattern will be validated. + +=item C<name> + +Name to use for errors. If a name is not specified, default errors will use +"The field $field" as the name. If a non-default error is found, $name +will be swapped with this name. + +=item C<delegate_error> + +This option allows for any errors generated on a field to delegate to +a different field. If the field name was a regex, any patterns will +be swapped into the delegate_error value. This option is generally only +useful with the as_hash method of the error object (for inline errors). + + { + field => 'zip', + match => 'm/^\d{5}/', + }, + { + field => 'zip_plus4', + match => 'm/^\d{4}/', + delegate_error => 'zip', + }, + { + field => 'm/^(id_[\d+])_user$/', + delegate_error => '$1', + }, + +=item C<exclude_js> + +This allows the cgi to do checking while keeping the checks from +being run in JavaScript + + { + field => 'cgi_var', + required => 1, + exclude_js => 1, + } + +=item C<exclude_cgi> + +This allows the js to do checking while keeping the checks from +being run in the cgi + + { + field => 'js_var', + required => 1, + exclude_cgi => 1, + } + +=item C<vif_disable> + +Only functions in javascript. Will mark set the form element to +disabled if validate_if fails. It will mark it as enabled if +validate_if is successful. This item should normally only be used +when onevent includes "change" or "blur". + +=back + +=head1 MODIFYING VALIDATION TYPES + +The following types will modify the form value before it is processed. +They work in both the perl and in javascript as well. The javascript +version changes the actual value in the form on appropriate form types. + +=over 4 + +=item C<do_not_trim> + +By default, validate will trim leading and trailing whitespace +from submitted values. Set do_not_trim to 1 to allow it to +not trim. + + {field => 'foo', do_not_trim => 1} + +=item C<trim_control_chars> + +Off by default. If set to true, removes characters in the +\x00 to \x31 range (Tabs are translated to a single space). + + {field => 'foo', trim_control_chars => 1} + +=item C<replace> + +Pass a swap pattern to change the actual value of the form. +Any perl regex can be passed but it is suggested that javascript +compatible regexes are used to make generate_js possible. + + {field => 'foo', replace => 's/(\d{3})(\d{3})(\d{3})/($1) $2-$3/'} + +=item C<default> + +Set item to default value if there is no existing value (undefined +or zero length string). + + {field => 'country', default => 'EN'} + +=item C<to_upper_case> and C<to_lower_case> + +Do what they say they do. + +=item C<untaint> + +Requires that the validated field has been also checked with +an enum, equals, match, compare, custom, or type check. If the +field has been checked and there are no errors - the field is "untainted." + +This is for use in conjunction with perl's -T switch. + +=item C<clear_on_error> + +Clears the form field should a validation error occur. Only supported +on the Javascript side (no affect on the server side). + +=back + +=head1 ERROR OBJECT + +Failed validation results in an error an error object created via the +new_error method. The default error class is CGI::Ex::Validate::Error. + +The error object has several methods for determining what the errors were. + +=over 4 + +=item C<as_array> + +Returns an array or arrayref (depending on scalar context) of errors that +occurred in the order that they occurred. Individual groups may have a heading +and the entire validation will have a heading (the default heading can be changed +via the 'as_array_title' group option). Each error that occurred is a separate +item and are pre-pended with 'as_array_prefix' (which is a group option - default +is ' '). The as_array_ options may also be set via a hashref passed to as_array. +as_array_title defaults to 'Please correct the following items:'. + + # if this returns the following + my $array = $err_obj->as_array; + # $array looks like + # ['Please correct the following items:', ' error1', ' error2'] + + # then this would return the following + my $array = $err_obj->as_array({ + as_array_prefix => ' - ', + as_array_title => 'Something went wrong:', + }); + # $array looks like + # ['Something went wrong:', ' - error1', ' - error2'] + +=item C<as_string> + +Returns values of as_array joined with a newline. This method is used as +the stringification for the error object. Values of as_array are joined with +'as_string_join' which defaults to "\n". If 'as_string_header' is set, it will +be pre-pended onto the error string. If 'as_string_footer' is set, it will be +appended onto the error string. + + # if this returns the following + my $string = $err_obj->as_string; + # $string looks like + # "Please correct the following items:\n error1\n error2" + + # then this would return the following + my $string = $err_obj->as_string({ + as_array_prefix => ' - ', + as_array_title => 'Something went wrong:', + as_string_join => '<br />', + as_string_header => '<span class="error">', + as_string_footer => '</span>', + }); + # $string looks like + # '<span class="error">Something went wrong:<br /> - error1<br /> - error2</span>' + +=item C<as_hash> + +Returns a hash or hashref (depending on scalar context) of errors that +occurred. Each key is the field name of the form that failed +validation with 'as_hash_suffix' added on as a suffix. as_hash_suffix +is available as a group option and may also be passed in via a +hashref as the only argument to as_hash. The default value is +'_error'. The values of the hash are arrayrefs of errors that +occurred to that form element. + +By default as_hash will return the values of the hash as arrayrefs (a +list of the errors that occurred to that key). It is possible to also +return the values as strings. Three options are available for +formatting: 'as_hash_header' which will be pre-pended onto the error +string, 'as_hash_footer' which will be appended, and 'as_hash_join' +which will be used to join the arrayref. The only argument required +to force the stringification is 'as_hash_join'. + + # if this returns the following + my $hash = $err_obj->as_hash; + # $hash looks like + # {key1_error => ['error1', 'error2']} + + # then this would return the following + my $hash = $err_obj->as_hash({ + as_hash_suffix => '_foo', + as_hash_join => '<br />', + as_hash_header => '<span class="error">' + as_hash_footer => '</span>' + }); + # $hash looks like + # {key1_foo => '<span class="error">error1<br />error2</span>'} + +=back + +=head1 GROUP OPTIONS + +Any key in a validation hash matching the pattern +m/^group \s+ (\w+)$/x is considered a group option (the reason +that either group or general may be used is that CGI::Ex::Validate +used to have the concept of validation groups - these were not +commonly used so support has been removed as of the 2.10 release). +(the old name of 'general' vs 'group' is still supported but deprecated) + +=over 4 + +=item C<title> + +Used as a group section heading when as_array or as_string is called +by the error object. + + 'group title' => 'Title of errors', + +=item C<order> + +Order in which to validate key/value pairs of group. + + 'group order' => [qw(user pass email OR phone)], + + # OR + + 'group order' => [{ + field => 'field1', + required => 1, + }, { + field => 'field2', + required => 1, + }], + +=item C<fields> + +Alias for 'group order'. + +=item C<validate_if> + +If specified - the entire hashref will only be validated if +the "if" conditions are met. + + 'group validate_if => {field => 'email', required => 1}, + +This group would only validate all fields if the email field +was present. + +=item C<raise_error> + +If raise_error is true, any call to validate that fails validation +will die with an error object as the value. + +=item C<no_extra_fields> + +If no_extra_fields is true, validate will add errors for any field found +in form that does not have a field_val hashref in the validation hash. +Default is false. If no_extra_fields is set to 'used', it will check for +any keys that were not in a group that was validated. + +An important exception to this is that field_val hashrefs or field names listed +in a validate_if or required_if statement will not be included. You must +have an explicit entry for each key. + +=item C<\w+_error> + +These items allow for an override of the default errors. + + 'group required_error' => '$name is really required', + 'group max_len_error' => '$name must be shorter than $value characters', + # OR # + my $self = CGI::Ex::Validate->new({ + max_len_error => '$name must be shorter than $value characters', + }); + +=item C<as_array_title> + +Used as the section title for all errors that occur, when as_array +or as_string is called by the error object. + +=item C<as_array_prefix> + +Used as prefix to individual errors that occur, when as_array +or as_string is called by the error object. Each individual error +will be prefixed with this string. Headings will not be prefixed. +Default is ' '. + +=item C<as_string_join> + +When as_string is called, the values from as_array will be joined with +as_string_join. Default value is "\n". + +=item C<as_string_header> + +If set, will be pre-pended onto the string when as_string is called. + +=item C<as_string_footer> + +If set, will be pre-pended onto the string when as_string is called. + +=item C<as_hash_suffix> + +Added on to key names during the call to as_hash. Default is '_error'. + +=item C<as_hash_join> + +By default, as_hash will return hashref values that are errors joined with +the default as_hash_join value of <br />. It can also return values that are +arrayrefs of the errors. This can be done by setting as_hash_join to a non-true value +(for example '') + +=item C<as_hash_header> + +If as_hash_join has been set to a true value, as_hash_header may be set to +a string that will be pre-pended on to the error string. + +=item C<as_hash_footer> + +If as_hash_join has been set to a true value, as_hash_footer may be set to +a string that will be postpended on to the error string. + +=item C<onevent> + +Defaults to {submit => 1}. This controls when the javascript validation +will take place. May be passed any or all or load, submit, change, or blur. +Multiple events may be passed in the hash. + + 'group onevent' => {submit => 1, change => 1}', + +A comma separated string of types may also be passed: + + 'group onevent' => 'submit,change,blur,load', + +Currently, change and blur will not work for dynamically matched +field names such as 'm/\w+/'. Support will be added. + +=item C<set_hook> + +Defaults document.validate_set_hook which defaults to nothing. If +"group set_hook" or document.validate_set_hook are set to a function, +they will be passed the key name of a form element that had a +validation error and the error that will be set. If a true value is +returned, then validate will not also the inline error. If no value +or false is returned (default) the validate will continue setting the +inline error. This gives full control over setting inline +errors. samples/validate_js_2_onchange.html has a good example of +using these hooks. + + 'group set_hook' => "function (args) { + alert("Setting error to field "+args.key); + }", + +The args parameter includes key, value, val_hash, and form. + +The document.validate_set_hook option is probably the better option to use, +as it helps to separate display functionality out into your html templates +rather than storing too much html logic in your CGI. + +=item C<clear_hook> + +Similar to set_hook, but called when inline error is cleared. Its +corresponding default is document.validate_clear_hook. The clear hook +is also sampled in samples/validate_js_2_onchange.html + + 'group clear_hook' => "function (args) { + alert("Clear error on field "+args.key); + }", + +The args parameter includes key, val_hash, form, and was_valid. + +=item C<no_inline> + +If set to true, the javascript validation will not attempt to generate +inline errors when the only "group onevent" type is "submit". Default +is true. Inline errors are independent of confirm and alert errors. + + 'group no_inline' => 1, + +=item C<no_confirm> + +If set to true, the javascript validation will try to use an alert +instead of a confirm to inform the user of errors when one of the +"group onevent" types is "submit". Alert and confirm are independent +or inline errors. Default is false. + + 'group no_confirm' => 1, + +=item C<no_alert> + +If set to true, the javascript validation will not show an alert box +when errors occur. Default is false. This option only comes into +play if no_confirm is also set. This option is only in effect if +"group onevent" includes "submit". This option is independent of +inline errors. Although it is possible to turn off all errors by +setting no_inline, no_confirm, and no_alert all to 1, it is suggested +that at least one of the error reporting facilities is left on. + + 'group no_alert' => 1, + +=back + +=head1 JAVASCRIPT + +CGI::Ex::Validate provides for having duplicate validation on the +client side as on the server side. Errors can be shown in any +combination of inline and confirm, inline and alert, inline only, +confirm only, alert only, and none. These combinations are controlled +by the group options no_inline, no_confirm, and no_alert. +Javascript validation can be generated for a page using the +C<-E<gt>generate_js> method of CGI::Ex::Validate. + +(Note: It is also possible to store the validation inline with the +html as YAML and have it read in using the HTML conf handler - but +this feature has been deprecated - see the included html samples for +how to do this). + +Generate JS will create something similar to the following (based on your validation): + + <script src="/cgi-bin/js/CGI/Ex/validate.js"></script> + <script> + document.validation = { + 'group no_confirm': 1, + 'group no_alert': 1, + 'group onevent': 'change,blur,submit', + 'group order': ['username', 'password'], + username: { + required: 1, + max_len: 20 + }, + password: { + required: 1, + max_len: 30 + } + }; + if (document.check_form) document.check_form('my_form_name'); + </script> + +If inline errors are enabled (default), each error that occurs will attempt +to find an html element with its name as the id. For example, if +the field "username" failed validation and created a "username_error", +the javascript would set the html of <span id="username_error"></span> +to the error message. + +It is suggested to use something like the following so that you can +have inline javascript validation as well as report validation errors +from the server side as well. + + <span class=error id=password_error>[% password_error %]</span><br> + +If the javascript fails for some reason, the form should still be able +to submit as normal (fail gracefully). + +Additionally, there are two hooks that are called when ever an inline +error is set or cleared. The following hooks are used in +samples/validate_js_2_onchange.html to highlight the row and set an icon. + + document.validate_set_hook = function (args) { + document.getElementById(args.key+'_img').innerHTML + = '<span style="font-weight:bold;color:red">!</span>'; + document.getElementById(args.key+'_row').style.background + = '#ffdddd'; +}; + +document.validate_clear_hook = function (args) { + if (args.was_valid) { + document.getElementById(args.key+'_img').innerHTML + = '<span style="font-weight:bold;color:green">+</span>'; + document.getElementById(args.key+'_row').style.background + = '#ddffdd'; + } else { + document.getElementById(args.key+'_img').innerHTML = ''; + document.getElementById(args.key+'_row').style.background = '#fff'; + } +}; + +These hooks can also be set as "group clear_hook" and "group set_hook" + which are defined further above. + + If the confirm option is used ("group onevent" includes submit and + "group no_confirm" is false), the errors will be displayed to the + user. If they choose OK they will be able to try and fix the errors. + If they choose cancel, the form will submit anyway and will rely on + the server to do the validation. This is for fail safety to make sure + that if the javascript didn't validate correctly, the user can still +submit the data. + +=head1 THANKS + +Thanks to Eamon Daly for providing bug fixes for bugs in validate.js +caused by HTML::Prototype. + +=head1 LICENSE + +This module may be distributed under the same terms as Perl itself. + +=head1 AUTHOR + +Paul Seamons <paul at seamons dot com> + +=cut diff --git a/lib/CGI/Ex/validate.js b/lib/CGI/Ex/validate.js index 51e68af..388f673 100644 --- a/lib/CGI/Ex/validate.js +++ b/lib/CGI/Ex/validate.js @@ -1,4 +1,4 @@ -// Copyright 2007 - Paul Seamons - $Revision: 1.74 $ +// Copyright 2008 - Paul Seamons - $Revision: 1.81 $ // Distributed under the Perl Artistic License without warranty // See perldoc CGI::Ex::Validate for usage @@ -18,65 +18,63 @@ function ValidateError (errors, extra) { function v_error (err) { alert (err); return 1 } -function v_clean_val_hash (val_hash) { +function v_get_ordered_fields (val_hash) { if (typeof(val_hash) != 'object') return {error: v_error("Validation must be an associative array (hash)")}; - var order = []; + var ARGS = {}; + var field_keys = []; + var m; for (var key in val_hash) { if (key == 'extend') continue; // Protoype Array() - if (key.match(/^general\s/)) { - var new_key = key.replace(/^general\s+/, 'group '); - val_hash[new_key] = val_hash[key]; - delete(val_hash[key]); - key = new_key; + if (m = key.match(/^(general|group)\s+(\w+)/)) { + ARGS[m[2]] = val_hash[key]; + continue; } - order.push(key); + field_keys.push(key); } - order = order.sort(); + field_keys = field_keys.sort(); - var f = val_hash['group set_hook']; - if (f && typeof(f) == 'string') eval("val_hash['group set_hook'] = "+f); - f = val_hash['group clear_hook']; - if (f && typeof(f) == 'string') eval("val_hash['group clear_hook'] = "+f); + var f = ARGS.set_hook; if (f && typeof(f) == 'string') eval("ARGS.set_hook = "+f); + f = ARGS.clear_hook; if (f && typeof(f) == 'string') eval("ARGS.clear_hook = "+f); + f = ARGS.set_all_hook; if (f && typeof(f) == 'string') eval("ARGS.set_all_hook = "+f); + f = ARGS.clear_all_hook; if (f && typeof(f) == 'string') eval("ARGS.clear_all_hook = "+f); - if (f = val_hash['group validate_if']) { + if (f = ARGS.validate_if) { if (typeof(f) == 'string' || ! f.length) f = [f]; var deps = v_clean_cond(f); } - var fields = val_hash['group fields']; - if (fields) { - if (typeof(fields) != 'object' || ! fields.length) + var fields = []; + var ref; + if (ref = ARGS.fields || ARGS['order']) { + if (typeof(ref) != 'object' || ! ref.length) return {error:v_error("'group fields' must be a non-empty array")}; - } else { - fields = []; - var _order = (val_hash['group order']) ? val_hash['group order'] : order; - if (typeof(_order) != 'object' || ! _order.length) - return {error:v_error("'group order' must be a non-empty array")}; - for (var i = 0; i < _order.length; i++) { - var field = _order[i]; - if (field.match(/^group\s/)) continue; - var field_val = val_hash[field]; - if (! field_val) { - if (field == 'OR') field_val = 'OR'; - else return {error:v_error('No element found in group for '+field)}; + for (var i = 0; i < ref.length; i++) { + var field = ref[i]; + if (typeof(field) == 'object') { + if (! field.field) return {error:v_error("Missing field key in validation")}; + fields.push(field); + } else if (field == 'OR') { + fields.push('OR'); + } else { + var field_val = val_hash[field]; + if (! field_val) return {error:v_error('No element found in group for '+field)}; + if (typeof(field_val) == 'object' && ! field_val['field']) field_val['field'] = field; + fields.push(field_val); } - if (typeof(field_val) == 'object' && ! field_val['field']) field_val['field'] = field; - fields.push(field_val); } } var found = {}; for (var i = 0; i < fields.length; i++) { var field_val = fields[i]; - var field = field_val.field; - if (! field) return {error:v_error("Missing field key in validation")}; - found[field] = 1; + if (typeof(field_val) != 'object') continue; + found[field_val.field] = 1; } - for (var i = 0; i < order.length; i++) { - var field = order[i]; - if (found[field] || field.match(/^group\s/)) continue; + for (var i = 0; i < field_keys.length; i++) { + var field = field_keys[i]; + if (found[field]) continue; var field_val = val_hash[field]; if (typeof(field_val) != 'object' || field_val.length) return {error:v_error('Found a non-hash value on field '+field)}; if (! field_val.field) field_val.field = field; @@ -89,7 +87,7 @@ function v_clean_val_hash (val_hash) { val_hash['group was_valid'] = {}; val_hash['group had_error'] = {}; - return {'fields':fields, 'order':order}; + return {'fields':fields, 'args':ARGS}; } function v_clean_field_val (field_val, N_level) { @@ -158,9 +156,8 @@ function v_clean_cond (ifs, N_level, ifs_match) { } function v_validate (form, val_hash) { - var clean = v_clean_val_hash(val_hash); + var clean = v_get_ordered_fields(val_hash); if (clean.error) return; - var order = clean.order; var fields = clean.fields; var ERRORS = []; @@ -210,12 +207,9 @@ function v_validate (form, val_hash) { for (var j = 0; j < errors.length; j++) ERRORS.push(errors[j]); } - var m; - for (var j = 0; j < order.length; j++) { - var field = order[j]; - if (! (m = field.match(/^group\s+(\w+)$/))) continue; - if (errors.length == 0 || m[1].match(/^(field|order|title|validate_if)$/)) continue; - EXTRA[m[1]] = val_hash[field]; + for (var field in clean.args) { + if (errors.length == 0 || field.match(/^(field|order|title|validate_if)$/)) continue; + EXTRA[field] = clean.args[field]; } if (ERRORS.length) return new ValidateError(ERRORS, EXTRA); @@ -533,7 +527,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[1].match(/^([a-z0-9\-]{1,62}\.)+$/)) return 0; + if (! m[1].match(/^([a-z0-9\-]{1,63}\.)+$/)) return 0; } else if (type == 'URL') { if (! value) return 0; @@ -665,7 +659,11 @@ function v_get_error_text (err, extra1, extra2) { }); } - var name = field_val.name || "The field " +field; + var name = field_val.name; + if (! name && (field.match(/\W/) || (field.match(/\d/) && field.match(/\D/)))) { + name = "The field " +field; + } + if (! name) name = field.replace(/_/g, ' ').replace(/\b(\w)/g, function(all,str){return str.toUpperCase()}); name = name.replace(/\$(\d+)/g, function (all, N) { if (typeof(ifs_match) != 'object' || typeof(ifs_match[N]) == 'undefined') return '' @@ -676,6 +674,7 @@ function v_get_error_text (err, extra1, extra2) { if (! msg) { if (dig.length) msg = field_val[type + dig + '_error']; if (! msg) msg = field_val[type + '_error']; + if (! msg) msg = field_val['error']; } if (msg) { msg = msg.replace(/\$(\d+)/g, function (all, N) { @@ -826,7 +825,14 @@ document.validate = function (form, val_hash) { } var err_obj = v_validate(form, val_hash); - if (! err_obj) return true; + if (! err_obj) { + var f = val_hash['group clear_all_hook'] || document.validate_clear_all_hook; + if (f) f(); + return true; + } + + var f = val_hash['group set_all_hook'] || document.validate_set_all_hook; + if (f) f(err_obj); var field = err_obj.first_field(); if (field && form[field]) { @@ -930,7 +936,7 @@ document.check_form = function (form, val_hash) { val_hash['group onevent'] = types; if (types.change || types.blur) { - var clean = v_clean_val_hash(val_hash); + var clean = v_get_ordered_fields(val_hash); if (clean.error) return clean.error; var h = {}; _add = function (k, v) { if (! h[k]) h[k] = []; h[k].push(v) }; diff --git a/samples/benchmark/bench_jsondump.pl b/samples/benchmark/bench_jsondump.pl index 38c1594..bb6e2e6 100755 --- a/samples/benchmark/bench_jsondump.pl +++ b/samples/benchmark/bench_jsondump.pl @@ -1,27 +1,30 @@ #!/usr/bin/perl -w +# As of JSON switch to 2.0 and new JSON interface # Benchmark: running cejd, json, zejd for at least 2 CPU seconds... -# cejd: 4 wallclock secs ( 2.18 usr + 0.00 sys = 2.18 CPU) @ 7045.87/s (n=15360) -# json: 3 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 6634.26/s (n=14330) -# zejd: 3 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 6634.26/s (n=14330) -# Rate zejd json cejd -# zejd 6634/s -- 0% -6% -# json 6634/s 0% -- -6% -# cejd 7046/s 6% 6% -- +# cejd: 3 wallclock secs ( 2.17 usr + 0.00 sys = 2.17 CPU) @ 7078.34/s (n=15360) +# json: 3 wallclock secs ( 2.24 usr + 0.00 sys = 2.24 CPU) @ 8723.21/s (n=19540) +# zejd: 3 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 7111.11/s (n=15360) +# Rate cejd zejd json +# cejd 7078/s -- -0% -19% +# zejd 7111/s 0% -- -18% +# json 8723/s 23% 23% -- # # Benchmark: running cejd, json for at least 2 CPU seconds... -# cejd: 3 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 5690.20/s (n=11608) -# json: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 5291.75/s (n=10901) -# Rate json cejd -# json 5292/s -- -7% -# cejd 5690/s 8% -- +# cejd: 3 wallclock secs ( 2.08 usr + 0.00 sys = 2.08 CPU) @ 5800.48/s (n=12065) +# json: 2 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 7206.57/s (n=15350) +# Rate cejd json +# cejd 5800/s -- -20% +# json 7207/s 24% -- # # Benchmark: running cejd, json for at least 2 CPU seconds... -# cejd: 4 wallclock secs ( 2.21 usr + 0.00 sys = 2.21 CPU) @ 24320.81/s (n=53749) -# json: 3 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 10048.13/s (n=21503) +# cejd: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 30656.31/s (n=63152) +# json: 2 wallclock secs ( 2.08 usr + 0.00 sys = 2.08 CPU) @ 24666.35/s (n=51306) # Rate json cejd -# json 10048/s -- -59% -# cejd 24321/s 142% -- +# json 24666/s -- -20% +# cejd 30656/s 24% -- + + use strict; @@ -29,8 +32,10 @@ use Benchmark qw(cmpthese timethese); use JSON; use CGI::Ex::JSONDump; -my $json = JSON->new(pretty => 0, keysort => 0); -my $cejd = CGI::Ex::JSONDump->new({pretty => 0, no_sort => 1}); +my $json = JSON->new; +$json->canonical(1); +#$json->pretty; +my $cejd = CGI::Ex::JSONDump->new; my $data = { @@ -41,18 +46,20 @@ my $data = { six => undef, }; -print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "JSON\n--------------------\n". $json->encode($data)."\n----------------------------\n"; print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; cmpthese timethese(-2, { - json => sub { my $a = $json->objToJson($data) }, + json => sub { my $a = $json->encode($data) }, cejd => sub { my $a = $cejd->dump($data) }, zejd => sub { my $a = $cejd->dump($data) }, }); ###----------------------------------------------------------------### -$json = JSON->new(pretty => 1, keysort => 1); +$json = JSON->new; +$json->canonical(1); +$json->pretty; $cejd = CGI::Ex::JSONDump->new({pretty => 1}); $data = { @@ -64,25 +71,27 @@ $data = { seven => undef, }; -print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "JSON\n--------------------\n". $json->encode($data)."\n----------------------------\n"; print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; cmpthese timethese(-2, { - json => sub { my $a = $json->objToJson($data) }, + json => sub { my $a = $json->encode($data) }, cejd => sub { my $a = $cejd->dump($data) }, }); ###----------------------------------------------------------------### -$json = JSON->new(pretty => 1); -$cejd = CGI::Ex::JSONDump->new({pretty => 1}); +$json = JSON->new; +$json->canonical(1); +$json->pretty; +$cejd = CGI::Ex::JSONDump->new({pretty => 1, no_tag_splitting => 1}); $data = ["foo\n<script>\nThis is sort of \"odd\"\n</script>"]; -print "JSON\n--------------------\n". $json->objToJson($data)."\n----------------------------\n"; +print "JSON\n--------------------\n". $json->encode($data)."\n----------------------------\n"; print "CEJD\n--------------------\n". $cejd->dump($data) ."\n----------------------------\n"; cmpthese timethese(-2, { - json => sub { my $a = $json->objToJson($data) }, + json => sub { my $a = $json->encode($data) }, cejd => sub { my $a = $cejd->dump($data) }, }); diff --git a/samples/benchmark/bench_validation.pl b/samples/benchmark/bench_validation.pl index 76845f3..9da5d8f 100644 --- a/samples/benchmark/bench_validation.pl +++ b/samples/benchmark/bench_validation.pl @@ -1,6 +1,7 @@ #!/usr/bin/perl -w use Benchmark qw(timethese cmpthese countit timestr); +use CGI::Ex::Dump qw(debug); use CGI::Ex::Validate; use Data::FormValidator; @@ -26,7 +27,7 @@ my $val_hash_ce = { untaint => 1, }, password2 => { - validate_if => 'password', + validate_if => 'password was_valid', equals => 'password', }, email => { @@ -77,8 +78,10 @@ sub check_form { push @{ $hash->{'password_error'} }, 'Password must be less than 30 characters'; } - if (! defined($form->{'password2'}) - || $form->{'password2'} ne $form->{'password'}) { + if (exists($form->{'password'}) + && ! $hash->{'password_error'} + && (! defined($form->{'password2'}) + || $form->{'password2'} ne $form->{'password'})) { push @{ $hash->{'password2_error'} }, 'Password2 and password must be the same'; } } @@ -92,6 +95,9 @@ sub check_form { return $hash; } +debug(CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash); +debug(Data::FormValidator->check($form, $val_hash_df)->msgs); +debug(check_form($form)); cmpthese (-2,{ cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce) }, @@ -105,22 +111,21 @@ cmpthese (-2,{ homegrown => sub { my $t = scalar keys %{ check_form($form) } }, },'auto'); - ### Home grown solution blows the others away - but lacks features # # Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds... -# cgi_ex: 2 wallclock secs ( 2.08 usr + 0.01 sys = 2.09 CPU) @ 2045.93/s (n=4276) -# data_val: 2 wallclock secs ( 2.15 usr + 0.00 sys = 2.15 CPU) @ 3496.28/s (n=7517) -# homegrown: 2 wallclock secs ( 2.09 usr + 0.01 sys = 2.10 CPU) @ 81919.52/s (n=172031) -# Rate cgi_ex data_val homegrown -# cgi_ex 2046/s -- -41% -98% -# data_val 3496/s 71% -- -96% -# homegrown 81920/s 3904% 2243% -- +# cgi_ex: 3 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 2845.10/s (n=5804) +# data_val: 3 wallclock secs ( 2.17 usr + 0.00 sys = 2.17 CPU) @ 1884.79/s (n=4090) +# homegrown: 3 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 77093.43/s (n=164209) +# Rate data_val cgi_ex homegrown +# data_val 1885/s -- -34% -98% +# cgi_ex 2845/s 51% -- -96% +# homegrown 77093/s 3990% 2610% -- # Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds... -# cgi_ex: 2 wallclock secs ( 2.11 usr + 0.00 sys = 2.11 CPU) @ 1696.68/s (n=3580) -# data_val: 2 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 2845.10/s (n=5804) -# homegrown: 2 wallclock secs ( 2.01 usr + 0.00 sys = 2.01 CPU) @ 83674.13/s (n=168185) -# Rate cgi_ex data_val homegrown -# cgi_ex 1697/s -- -40% -98% -# data_val 2845/s 68% -- -97% -# homegrown 83674/s 4832% 2841% -- +# cgi_ex: 2 wallclock secs ( 2.21 usr + 0.01 sys = 2.22 CPU) @ 2421.17/s (n=5375) +# data_val: 2 wallclock secs ( 2.27 usr + 0.03 sys = 2.30 CPU) @ 1665.22/s (n=3830) +# homegrown: 2 wallclock secs ( 2.04 usr + 0.01 sys = 2.05 CPU) @ 72820.00/s (n=149281) +# Rate data_val cgi_ex homegrown +# data_val 1665/s -- -31% -98% +# cgi_ex 2421/s 45% -- -97% +# homegrown 72820/s 4273% 2908% -- diff --git a/samples/devel/dprof_validation.d b/samples/devel/dprof_validation.d index 5b02305..a500024 100644 --- a/samples/devel/dprof_validation.d +++ b/samples/devel/dprof_validation.d @@ -10,18 +10,20 @@ my $form = { }; my $val_hash_ce = { + 'group no_alert' => 1, + 'group no_confirm' => 1, username => { required => 1, - match => 'm/^\w+$/', - match_error => '$name may only contain letters and numbers', - untaint => 1, + match2 => 'm/^\w+$/', + match2_error => '$name may only contain letters and numbers', +# untaint => 1, }, password => { required => 1, min_len => 6, max_len => 30, match => 'm/^[ -~]+$/', - untaint => 1, +# untaint => 1, }, password2 => { validate_if => 'password', @@ -30,7 +32,7 @@ my $val_hash_ce = { email => { required => 1, match => 'm/^[\w\.\-]+\@[\w\.\-]+$/', - untaint => 1, +# untaint => 1, }, }; diff --git a/samples/validate_js_1_onsubmit.html b/samples/validate_js_1_onsubmit.html index f420527..ec9162b 100644 --- a/samples/validate_js_1_onsubmit.html +++ b/samples/validate_js_1_onsubmit.html @@ -39,8 +39,8 @@ if (! document.validate) { <tr> <td valign=top>Verify Password:</td> <td> - <input type=password size=20 name=password2><br> - <span id=password2_error class=error></span> + <input type=password size=20 name=verify_password><br> + <span id=verify_password_error class=error></span> </td> </tr> <tr> @@ -121,23 +121,20 @@ if (! document.validate) { document.validation = { "group no_confirm": 1, "group no_alert": 1, - "group order": ["username", "password", "password2", "email", "email2", "state", "region", "s_r_combo", "enum", "compare", "checkone", "checktwo", "foo"], + "group order": ["username", "password", "verify_password", "email", "email2", "state", "region", "s_r_combo", "enum", "compare", "checkone", "checktwo", "foo"], username: { - name: "Username", required: 1, min_len: 3, max_len: 30 }, password: { - name: "Password", required: 1, min_len: 6, max_len: 30, match: ["m/\\d/", "m/[a-z]/"], match_error: "$name must contain both a letter and a number." }, - password2: { - name: "Verify password", + verify_password: { equals: "password", equals_name: "password" }, diff --git a/t/1_validate_05_types.t b/t/1_validate_05_types.t index d45041f..3456803 100644 --- a/t/1_validate_05_types.t +++ b/t/1_validate_05_types.t @@ -7,30 +7,30 @@ =cut use strict; -use Test::More tests => 112; +use Test::More tests => 120; use_ok('CGI::Ex::Validate'); my $v; my $e; -sub validate { scalar &CGI::Ex::Validate::validate(@_) } +sub validate { scalar CGI::Ex::Validate::validate(@_) } ### required $v = {foo => {required => 1}}; $e = validate({}, $v); -ok($e); +ok($e, 'required => 1 - fail'); $e = validate({foo => 1}, $v); -ok(! $e); +ok(! $e, 'required => 1 - good'); ### validate_if $v = {foo => {required => 1, validate_if => 'bar'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'validate_if - true'); $e = validate({bar => 1}, $v); -ok($e); +ok($e, 'validate_if - false'); $v = {text1 => {required => 1, validate_if => 'text2 was_valid'}, text2 => {validate_if => 'text3'}}; $e = validate({}, $v); @@ -56,255 +56,255 @@ ok($e && ! $e->as_hash->{text1_error}, "No error on validate_if with had_error a ### required_if $v = {foo => {required_if => 'bar'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'required_if - false'); $e = validate({bar => 1}, $v); -ok($e); +ok($e , 'required_if - true'); ### max_values $v = {foo => {required => 1}}; $e = validate({foo => [1,2]}, $v); -ok($e); +ok($e, 'max_values'); $v = {foo => {max_values => 2}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'max_values'); $e = validate({foo => "str"}, $v); -ok(! $e); +ok(! $e, 'max_values'); $e = validate({foo => [1]}, $v); -ok(! $e); +ok(! $e, 'max_values'); $e = validate({foo => [1,2]}, $v); -ok(! $e); +ok(! $e, 'max_values'); $e = validate({foo => [1,2,3]}, $v); -ok($e); +ok($e, 'max_values'); ### min_values $v = {foo => {min_values => 3, max_values => 10}}; $e = validate({foo => [1,2,3]}, $v); -ok(! $e); +ok(! $e, 'min_values'); $e = validate({foo => [1,2,3,4]}, $v); -ok(! $e); +ok(! $e, 'min_values'); $e = validate({foo => [1,2]}, $v); -ok($e); +ok($e, 'min_values'); $e = validate({foo => "str"}, $v); -ok($e); +ok($e, 'min_values'); $e = validate({}, $v); -ok($e); +ok($e, 'min_values'); ### enum $v = {foo => {enum => [1, 2, 3]}, bar => {enum => "1 || 2||3"}}; $e = validate({}, $v); -ok($e); +ok($e, 'enum'); $e = validate({foo => 1, bar => 1}, $v); -ok(! $e); +ok(! $e, 'enum'); $e = validate({foo => 1, bar => 2}, $v); -ok(! $e); +ok(! $e, 'enum'); $e = validate({foo => 1, bar => 3}, $v); -ok(! $e); +ok(! $e, 'enum'); $e = validate({foo => 1, bar => 4}, $v); -ok($e); +ok($e, 'enum'); # equals $v = {foo => {equals => 'bar'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'equals'); $e = validate({foo => 1}, $v); -ok($e); +ok($e, 'equals'); $e = validate({bar => 1}, $v); -ok($e); +ok($e, 'equals'); $e = validate({foo => 1, bar => 2}, $v); -ok($e); +ok($e, 'equals'); $e = validate({foo => 1, bar => 1}, $v); -ok(! $e); +ok(! $e, 'equals'); $v = {foo => {equals => '"bar"'}}; $e = validate({foo => 1, bar => 1}, $v); -ok($e); +ok($e, 'equals'); $e = validate({foo => 'bar', bar => 1}, $v); -ok(! $e); +ok(! $e, 'equals'); ### min_len $v = {foo => {min_len => 10}}; $e = validate({}, $v); -ok($e); +ok($e, 'min_len'); $e = validate({foo => ""}, $v); -ok($e); +ok($e, 'min_len'); $e = validate({foo => "123456789"}, $v); -ok($e); +ok($e, 'min_len'); $e = validate({foo => "1234567890"}, $v); -ok(! $e); +ok(! $e, 'min_len'); ### max_len $v = {foo => {max_len => 10}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'max_len'); $e = validate({foo => ""}, $v); -ok(! $e); +ok(! $e, 'max_len'); $e = validate({foo => "1234567890"}, $v); -ok(! $e); +ok(! $e, 'max_len'); $e = validate({foo => "12345678901"}, $v); -ok($e); +ok($e, 'max_len'); ### match $v = {foo => {match => qr/^\w+$/}}; $e = validate({foo => "abc"}, $v); -ok(! $e); +ok(! $e, 'match'); $e = validate({foo => "abc."}, $v); -ok($e); +ok($e, 'match'); $v = {foo => {match => [qr/^\w+$/, qr/^[a-z]+$/]}}; $e = validate({foo => "abc"}, $v); -ok(! $e); +ok(! $e, 'match'); $e = validate({foo => "abc1"}, $v); -ok($e); +ok($e, 'match'); $v = {foo => {match => 'm/^\w+$/'}}; $e = validate({foo => "abc"}, $v); -ok(! $e); +ok(! $e, 'match'); $e = validate({foo => "abc."}, $v); -ok($e); +ok($e, 'match'); $v = {foo => {match => 'm/^\w+$/ || m/^[a-z]+$/'}}; $e = validate({foo => "abc"}, $v); -ok(! $e); +ok(! $e, 'match'); $e = validate({foo => "abc1"}, $v); -ok($e); +ok($e, 'match'); $v = {foo => {match => '! m/^\w+$/'}}; $e = validate({foo => "abc"}, $v); -ok($e); +ok($e, 'match'); $e = validate({foo => "abc."}, $v); -ok(! $e); +ok(! $e, 'match'); $v = {foo => {match => 'm/^\w+$/'}}; $e = validate({}, $v); -ok($e); +ok($e, 'match'); $v = {foo => {match => '! m/^\w+$/'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'match'); ### compare $v = {foo => {compare => '> 0'}}; $e = validate({}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => '== 0'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => '< 0'}}; $e = validate({}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => '> 10'}}; $e = validate({foo => 11}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 10}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => '== 10'}}; $e = validate({foo => 11}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 10}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => '< 10'}}; $e = validate({foo => 9}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 10}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => '>= 10'}}; $e = validate({foo => 10}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 9}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => '!= 10'}}; $e = validate({foo => 10}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 9}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => '<= 10'}}; $e = validate({foo => 11}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 10}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => 'gt ""'}}; $e = validate({}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => 'eq ""'}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => 'lt ""'}}; $e = validate({}, $v); -ok($e); # 68 +ok($e, 'compare'); # 68 $v = {foo => {compare => 'gt "c"'}}; $e = validate({foo => 'd'}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 'c'}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => 'eq c'}}; $e = validate({foo => 'd'}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 'c'}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => 'lt c'}}; $e = validate({foo => 'b'}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 'c'}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => 'ge c'}}; $e = validate({foo => 'c'}, $v); -ok(! $e); +ok(! $e, 'compare'); $e = validate({foo => 'b'}, $v); -ok($e); +ok($e, 'compare'); $v = {foo => {compare => 'ne c'}}; $e = validate({foo => 'c'}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 'b'}, $v); -ok(! $e); +ok(! $e, 'compare'); $v = {foo => {compare => 'le c'}}; $e = validate({foo => 'd'}, $v); -ok($e); +ok($e, 'compare'); $e = validate({foo => 'c'}, $v); -ok(! $e); # 80 +ok(! $e, 'compare'); # 80 ### sql ### can't really do anything here without prompting for a db connection @@ -313,75 +313,94 @@ ok(! $e); # 80 my $n = 1; $v = {foo => {custom => $n}}; $e = validate({}, $v); -ok(! $e); +ok(! $e, 'custom'); $e = validate({foo => "str"}, $v); -ok(! $e); +ok(! $e, 'custom'); $n = 0; $v = {foo => {custom => $n}}; $e = validate({}, $v); -ok($e); +ok($e, 'custom'); $e = validate({foo => "str"}, $v); -ok($e); +ok($e, 'custom'); $n = sub { my ($key, $val) = @_; return defined($val) ? 1 : 0}; $v = {foo => {custom => $n}}; $e = validate({}, $v); -ok($e); +ok($e, 'custom'); $e = validate({foo => "str"}, $v); -ok(! $e); +ok(! $e, 'custom'); ### type checks $v = {foo => {type => 'ip'}}; $e = validate({foo => '209.108.25'}, $v); -ok($e); +ok($e, 'type ip'); $e = validate({foo => '209.108.25.111'}, $v); -ok(! $e); +ok(! $e, 'type ip'); + +$v = {foo => {type => 'domain'}}; +$e = validate({foo => 'bar.com'}, $v); +ok(! $e, 'type domain'); +$e = validate({foo => 'bing.bar.com'}, $v); +ok(! $e, 'type domain'); +$e = validate({foo => 'bi-ng.com'}, $v); +ok(! $e, 'type domain'); +$e = validate({foo => '123456789012345678901234567890123456789012345678901234567890123.com'}, $v); +ok(! $e, 'type domain'); + +$e = validate({foo => 'com'}, $v); +ok($e, 'type domain'); +$e = validate({foo => 'bi-.com'}, $v); +ok($e, 'type domain'); +$e = validate({foo => 'bi..com'}, $v); +ok($e, 'type domain'); +$e = validate({foo => '1234567890123456789012345678901234567890123456789012345678901234.com'}, $v); +ok($e, 'type domain'); ### min_in_set checks $v = {foo => {min_in_set => '2 of foo bar baz', max_values => 5}}; $e = validate({foo => 1}, $v); -ok($e); +ok($e, 'min_in_set'); $e = validate({foo => 1, bar => 1}, $v); -ok(! $e); +ok(! $e, 'min_in_set'); $e = validate({foo => 1, bar => ''}, $v); # empty string doesn't count as value -ok($e); +ok($e, 'min_in_set'); $e = validate({foo => 1, bar => 0}, $v); -ok(! $e); +ok(! $e, 'min_in_set'); $e = validate({foo => [1, 2]}, $v); -ok(! $e); +ok(! $e, 'min_in_set'); $e = validate({foo => [1]}, $v); -ok($e); +ok($e, 'min_in_set'); $v = {foo => {min_in_set => '2 foo bar baz', max_values => 5}}; $e = validate({foo => 1, bar => 1}, $v); -ok(! $e); +ok(! $e, 'min_in_set'); ### max_in_set checks $v = {foo => {max_in_set => '2 of foo bar baz', max_values => 5}}; $e = validate({foo => 1}, $v); -ok(! $e); +ok(! $e, 'max_in_set'); $e = validate({foo => 1, bar => 1}, $v); -ok(! $e); +ok(! $e, 'max_in_set'); $e = validate({foo => 1, bar => 1, baz => 1}, $v); -ok($e); +ok($e, 'max_in_set'); $e = validate({foo => [1, 2]}, $v); -ok(! $e); +ok(! $e, 'max_in_set'); $e = validate({foo => [1, 2, 3]}, $v); -ok($e); +ok($e, 'max_in_set'); ### validate_if revisited (but negated - uses max_in_set) $v = {foo => {required => 1, validate_if => '! bar'}}; $e = validate({}, $v); -ok($e); +ok($e, 'validate_if - negated'); $e = validate({bar => 1}, $v); -ok(! $e); +ok(! $e, 'validate_if - negated'); ### default value my $f = {}; $v = {foo => {required => 1, default => 'hmmmm'}}; $e = validate($f, $v); -ok(! $e); +ok(! $e, 'default'); -ok($f->{foo} && $f->{foo} eq 'hmmmm'); +ok($f->{foo} && $f->{foo} eq 'hmmmm', 'had right default'); diff --git a/t/1_validate_12_change.t b/t/1_validate_12_change.t index ef270e2..3d695a9 100644 --- a/t/1_validate_12_change.t +++ b/t/1_validate_12_change.t @@ -7,7 +7,7 @@ =cut use strict; -use Test::More tests => 5; +use Test::More tests => 10; use strict; use_ok('CGI::Ex::Validate'); @@ -34,6 +34,7 @@ ok(! $e, "Didn't get error"); my $form = { key1 => 'Bu-nch @of characte#rs^', key2 => '123 456 7890', + key3 => '123', }; @@ -44,7 +45,8 @@ $v = { }; $e = validate($form, $v); -ok(! $e && $form->{key1} eq 'Bunch of characters', "No error and key1 updated"); +ok(! $e, "No error"); +is($form->{'key1'}, 'Bunch of characters', "key1 updated"); $v = { key2 => { @@ -53,7 +55,8 @@ $v = { }; $e = validate($form, $v); -ok(! $e && $form->{key2} eq '(123) 456-7890', "No error and phone updated"); +ok(! $e, "No error"); +is($form->{'key2'}, '(123) 456-7890', "Phone updated"); $v = { key2 => { @@ -63,5 +66,14 @@ $v = { }; $e = validate($form, $v); -ok($e && $form->{key2} eq '', "Error with all replaced"); +ok($e, "Error"); +is($form->{'key2'}, '', "All replaced"); +$v = { + key3 => { + replace => 's/\d//', + }, +}; +$e = validate($form, $v); +ok(! $e, "No error"); +is($form->{'key3'}, '23', "Non-global is fine"); diff --git a/t/1_validate_14_untaint.t b/t/1_validate_14_untaint.t index 7dff711..98f9d21 100644 --- a/t/1_validate_14_untaint.t +++ b/t/1_validate_14_untaint.t @@ -10,7 +10,7 @@ use strict; use Test::More tests => 14; use FindBin qw($Bin); -use lib ($Bin =~ /(.+)/ ? "$1/../lib" : ''); # add bin - but untaint it +use lib ($Bin =~ /(.+)/ ? (-e "$1/../blib" ? "$1/../blib" : "$1/../lib") : ''); # add bin - but untaint it ### Set up taint checking sub is_tainted { local $^W; eval { eval("#" . substr(join("", @_), 0, 0)); 1; } ? 0 : 1 } diff --git a/t/3_conf_00_base.t b/t/3_conf_00_base.t index bd6e31c..e41d897 100644 --- a/t/3_conf_00_base.t +++ b/t/3_conf_00_base.t @@ -7,7 +7,11 @@ =cut use strict; -use Test::More tests => 2; +use Test::More tests => 8; +use POSIX qw(tmpnam); + +my $file = tmpnam; +END { unlink $file }; use_ok('CGI::Ex::Conf'); @@ -15,3 +19,33 @@ my $obj = CGI::Ex::Conf->new; ok($obj); ### TODO - re-enable more fileside tests + +if (eval { require JSON }) { + ok(eval { CGI::Ex::Conf::conf_write($file, {foo => "bar"}, {file_type => 'json'}) }, "Could JSON write") || diag($@); + my $ref = eval { CGI::Ex::Conf::conf_read($file, {file_type => 'json'}) }; + is(eval { $ref->{'foo'} }, 'bar', "Could JSON read"); +} else { + SKIP: { + skip("Can't test read/write of json", 2); + }; +} + +if (eval { require YAML }) { + ok(eval { CGI::Ex::Conf::conf_write($file, {foo => "bar2"}, {file_type => 'yaml'}) }, "Could YAML write") || diag($@); + my $ref = eval { CGI::Ex::Conf::conf_read($file, {file_type => 'yaml'}) }; + is(eval { $ref->{'foo'} }, 'bar2', "Could YAML read"); +} else { + SKIP: { + skip("Can't test read/write of yaml", 2); + }; +} + +if (eval { require Data::Dumper }) { + ok(eval { CGI::Ex::Conf::conf_write($file, {foo => "bar2"}, {file_type => 'pl'}) }, "Could Perl write") || diag($@); + my $ref = eval { CGI::Ex::Conf::conf_read($file, {file_type => 'pl'}) }; + is(eval { $ref->{'foo'} }, 'bar2', "Could perl read"); +} else { + SKIP: { + skip("Can't test read/write of pl", 2); + }; +} diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t index 2ed1676..5d86aca 100644 --- a/t/4_app_00_base.t +++ b/t/4_app_00_base.t @@ -13,9 +13,10 @@ we do try to put it through most paces. =cut -use Test::More tests => 214; +use Test::More tests => 234; use strict; use warnings; +use CGI::Ex::Dump qw(debug); { package Foo; @@ -46,7 +47,7 @@ use warnings; sub main_info_complete { 0 } - sub main_file_print { return \ "Main Content" } + sub main_file_print { return \ "Main Content [%~ extra %]" } sub main_path_info_map { shift->{'main_path_info_map'} } @@ -64,7 +65,7 @@ use warnings; sub step3_info_complete { 0 } - sub step3_file_print { return \ "All good" } + sub step3_file_print { return \ "All good [%~ extra %]" } sub step4_file_val { return {wow => {required => 1, required_error => 'wow is required'}} } @@ -78,12 +79,15 @@ use warnings; sub step4_finalize { shift->append_path('step3') } + sub step5__part_a_file_print { return \ "Step 5 Nested ([% step %])" } + + sub step5__part_a_info_complete { 0 } + } ###----------------------------------------------------------------### ###----------------------------------------------------------------### -###----------------------------------------------------------------### -###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Test some basic returns ###\n"; ok(! eval { CGI::Ex::App::new() }, "Invalid new"); @@ -107,16 +111,22 @@ ok($app->morph_package('foo_bar') eq 'CGI::Ex::App::FooBar', "Got a good morph_p ok(ref($app->path), "Got a good path"); ok(@{ $app->path } == 0, "Got a good path"); -ok($app->default_step eq 'main', "Got a good default_step"); -ok($app->login_step eq '__login', "Got a good login_step"); -ok($app->error_step eq '__error', "Got a good error_step"); -ok($app->forbidden_step eq '__forbidden', "Got a good forbidden_step"); -ok($app->js_step eq 'js', "Got a good js_step"); +is($app->default_step, 'main', "Got a good default_step"); +is($app->login_step, '__login', "Got a good login_step"); +is($app->error_step, '__error', "Got a good error_step"); +is($app->forbidden_step, '__forbidden', "Got a good forbidden_step"); +is($app->js_step, 'js', "Got a good js_step"); + +# check for different step types +is($app->run_hook('file_print', '__leading_underbars'), 'foo_bar/__leading_underbars.html', 'file_print - __ is preserved at beginning of step'); +is($app->run_hook('file_print', 'central__underbars'), 'foo_bar/central/underbars.html', 'file_print - __ is used in middle of step'); +my $ref = ref($app); +is($app->run_hook('morph_package', '__leading_underbars'), "${ref}::LeadingUnderbars", 'morph_package - __ is works at beginning of step'); +is($app->run_hook('morph_package', 'central__underbars'), "${ref}::Central::Underbars", 'morph_package - __ is used in middle of step'); ###----------------------------------------------------------------### ###----------------------------------------------------------------### -###----------------------------------------------------------------### -###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Test basic step selection/form input/validation/filling/template swapping methods ###\n"; #$ENV{'REQUEST_METHOD'} = 'GET'; @@ -175,6 +185,8 @@ ok($Foo::test_stdout eq "Main Content post", "Got the right output for Foo2_4"); Foo2_4->new({_no_post_navigate => 1})->navigate; ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo2_4"); +my $f; + ###----------------------------------------------------------------### local $ENV{'REQUEST_METHOD'} = 'POST'; @@ -190,6 +202,16 @@ Foo->new({ })->navigate; ok($Foo::test_stdout =~ /Some step4 content.*wow is required.*<script>/s, "Got the right output for Foo (step4)"); +$f = Foo->new({ + form => {step => 'step5/part_a'}, +})->navigate; +is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5__part_a)"); + +$f = Foo->new({ + form => {step => 'step5__part_a'}, +})->navigate; +is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5__part_a)"); + { package Foo3; our @ISA = qw(Foo); @@ -284,11 +306,19 @@ ok($Foo::test_stdout =~ /fatal error.+path_info_map/, "Got the right output for ###----------------------------------------------------------------### +local $ENV{'PATH_INFO'} = '/whatever'; +$f = Foo->new({ + path_info_map_base => [[qr{(.+)}, sub { my ($form, $m1) = @_; $form->{'step'} = 'step3'; $form->{'extra'} = $m1 }]], +})->navigate; +is($Foo::test_stdout, 'All good/whatever', "Got the right output path_info_map_base with a code ref"); + +###----------------------------------------------------------------### + #$ENV{'REQUEST_METHOD'} = 'GET'; #$ENV{'QUERY_STRING'} = 'wow=something'; local $ENV{'PATH_INFO'} = '/step2'; -my $f = Foo->new({ +$f = Foo->new({ form=> {wow => 'something'}, })->navigate; ok($Foo::test_stdout eq "All good", "Got the right output"); @@ -309,6 +339,14 @@ ok($f->form->{'wow'} eq 'something', "Got the right variable set in form"); ###----------------------------------------------------------------### +local $ENV{'PATH_INFO'} = '/step5/part_a'; +$f = Foo->new({ + path_info_map_base => [[qr{(.+)}, 'step']], +})->navigate; +is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for Foo (step5/part_a)"); + +###----------------------------------------------------------------### + local $ENV{'PATH_INFO'} = ''; { @@ -338,6 +376,7 @@ ok($Foo::test_stdout eq 'JS', "Got the right output for Foo6"); ###----------------------------------------------------------------### ###----------------------------------------------------------------### ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Test Authorization Methods ###\n"; local $ENV{'PATH_INFO'} = ''; @@ -347,7 +386,7 @@ Foo->new({ form => {}, require_auth => 1, })->navigate; -ok($Foo::test_stdout eq "Login Form", "Got the right output"); +is($Foo::test_stdout, "Login Form", "Got the right output"); Foo->new({ form => {}, @@ -496,6 +535,7 @@ ok($Foo::test_stdout eq "Login Form", "Got the right output for Bar6 ($@)"); ###----------------------------------------------------------------### ###----------------------------------------------------------------### ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Test Configuration methods ###\n"; { @@ -552,6 +592,7 @@ ok($Foo::test_stdout eq "" && $@, "Got a conf_validation error"); ###----------------------------------------------------------------### ###----------------------------------------------------------------### ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Various other coverage tests\n"; ok(Conf1->new->conf_obj, "Got a conf_obj"); @@ -672,6 +713,7 @@ ok(! eval { CGI::Ex::App->new->get_pass_by_user } && $@, "Got a good error for g ok(! eval { CGI::Ex::App->new->find_hook } && $@, "Got a good error for find_hook"); ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; print "### Some morph tests ###\n"; { @@ -706,69 +748,67 @@ print "### Some morph tests ###\n"; our @ISA = qw(Foo8::Blah6); sub info_complete { 0 } sub file_print { \ 'blah7_file_print' } + + package Foo8::Blah9; + our @ISA = qw(Foo8); + sub info_complete { 0 } + sub file_print { \ 'blah9_file_print' } + + package Foo8; + sub __error_allow_morph { 0 } + sub __error_file_print { \ '[% error_step %] - [% error %]' } + $INC{'Foo8/Blah10.pm'} = 'internal'; # fake require - not a real App package + + package Foo8; + sub blah11_morph_package { 'Not::Exists::Blah11' } } Foo8->new({form => {step => 'blah1'}})->navigate; -ok($Foo::test_stdout eq 'blah1_pre', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah1_pre', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah1'}, allow_morph => 1})->navigate; -ok($Foo::test_stdout eq 'blah1_pre', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah1_pre', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah2'}})->navigate; -ok($Foo::test_stdout eq 'Main Content', "Got the right output for Foo8"); +is($Foo::test_stdout, 'Main Content', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah3'}})->navigate; -ok($Foo::test_stdout eq 'blah3_post', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah3_post', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah4'}})->navigate; -ok($Foo::test_stdout eq 'blah4_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah4_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah5'}})->navigate; -ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah5'}, allow_morph => 1})->navigate; -ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah5'}, allow_morph => 0})->navigate; -ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah5'}, allow_morph => {}})->navigate; -ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah5'}, allow_morph => {blah5 => 1}})->navigate; -ok($Foo::test_stdout eq 'blah5_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah5_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah6'}})->navigate; -ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah6_file_print', "Got the right output for Foo8"); Foo8->new({form => {step => 'blah8'}, allow_morph => 1})->navigate; -ok($Foo::test_stdout eq 'blah8_file_print', "Got the right output for Foo8 ($Foo::test_stdout)"); +is($Foo::test_stdout, 'blah8_file_print', "Got the right output for Foo8 ($Foo::test_stdout)"); -my $foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => 1}); +my $foo8 = Foo8->new({form => {step => 'blah7'}}); $foo8->morph('blah6'); $foo8->navigate; -ok($Foo::test_stdout eq 'blah7_file_print', "Got the right output for Foo8"); - -$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => {blah7 => 1}}); -$foo8->morph('blah6'); -$foo8->navigate; -ok($Foo::test_stdout eq 'blah7_file_print', "Got the right output for Foo8"); - -$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => {blah9 => 1}}); -$foo8->morph('blah6'); -$foo8->navigate; -ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8"); - -$foo8 = Foo8->new({form => {step => 'blah7'}, allow_nested_morph => 0}); -$foo8->morph('blah6'); -$foo8->navigate; -ok($Foo::test_stdout eq 'blah6_file_print', "Got the right output for Foo8"); +is($Foo::test_stdout, 'blah7_file_print', "Got the right output for Foo8"); $foo8 = Foo8->new({form => {step => 'early_exit'}, no_history => 1}); $foo8->morph('blah6'); $foo8->navigate; ok($Foo::test_stdout eq 'early', "Got the right output for Foo8"); -ok(ref($foo8) eq 'Foo8::Blah6', 'Still is unmorphed right'); +is(ref($foo8), 'Foo8::Blah6', 'Still is unmorphed right'); $foo8 = Foo8->new; $foo8->morph; @@ -777,8 +817,77 @@ $foo8->morph('blah6'); eval { $foo8->exit_nav_loop }; # coverage ok($@, "Got the die from exit_nav_loop"); +Foo8->new({form => {step => 'blah9'}, allow_morph => 2})->navigate; +is($Foo::test_stdout, 'blah9_file_print', "Got the right output for Foo8::Blah9 ($Foo::test_stdout)"); + +$foo8 = Foo8->new({form => {step => 'blah10'}, allow_morph => 2}); +eval { $foo8->navigate }; +#use CGI::Ex::Dump qw(debug); +#debug $foo8->dump_history; +ok($Foo::test_stdout =~ /^blah10 -/, "Got the right output for Foo8::Blah10"); +ok($Foo::test_stdout =~ m|Found package Foo8::Blah10|, "Got the right output for Foo8::Blah10") || diag $Foo::test_stdout; + +$foo8 = Foo8->new({form => {step => 'blah11'}, allow_morph => 2}); +eval { $foo8->navigate }; +#use CGI::Ex::Dump qw(debug); +#debug $foo8->dump_history; +ok($Foo::test_stdout =~ /^blah11 -/, "Got the right output for Foo8::Blah11"); +ok($Foo::test_stdout =~ m|Not/Exists/Blah11.pm.*\@INC|, "Got the right output for Foo8::Blah11") || diag $Foo::test_stdout; + + +$foo8 = Foo8->new; +$foo8->run_hook('morph', 'blah6', 1); +is(ref($foo8), 'Foo8::Blah6', "Right package"); + +$foo8->run_hook_as('run_step', 'blah7', 'Foo8::Blah6::Blah7'); +is($Foo::test_stdout, 'blah7_file_print', "Got the right output for Foo8::Blah6::Blah7"); +is(ref($foo8), 'Foo8::Blah6', "Right package"); + +$foo8->run_hook_as('run_step', 'main', 'Foo8'); +is($Foo::test_stdout, 'Main Content', "Got the right output for Foo8"); +is(ref($foo8), 'Foo8::Blah6', "Right package"); + +$foo8->run_hook_as('run_step', 'blah6', 'Foo8::Blah6'); +is($Foo::test_stdout, 'blah6_file_print', "Got the right output for Foo8::Blah6"); +$foo8->run_hook('unmorph', 'blah6'); +#use CGI::Ex::Dump qw(debug); +#debug $foo8->dump_history; + + + +{ + package Baz; + our @ISA = qw(Foo); + sub default_step { 'bazmain' } + sub info_complete { 0 } + sub file_print { my ($self, $step) = @_; return \qq{\u$step Content} } + sub allow_morph { 1 } + + package Baz::Bstep1; + our @ISA = qw(Baz); + + package Baz::Bstep2; + our @ISA = qw(Baz); + sub hash_swap { shift->goto_step('bstep3') } # hijack it here + + package Baz::Bstep3; + our @ISA = qw(Baz); +} + +Baz->navigate; +is($Foo::test_stdout, 'Bazmain Content', "Got the right output for Foo8::Blah6"); +Baz->navigate({form => {step => 'bstep1'}}); +is($Foo::test_stdout, 'Bstep1 Content', "Got the right output for Foo8::Blah6"); + +my $baz = Baz->new({form => {step => 'bstep2'}}); +eval { $baz->navigate }; +is($Foo::test_stdout, 'Bstep3 Content', "Got the right output for Foo8::Blah6"); +is(ref($baz), 'Baz', "And back to the correct object type"); +#debug $baz->dump_history; + ###----------------------------------------------------------------### -print "### Some path tests tests ###\n"; +print "#-----------------------------------------\n"; +print "### Some path tests ###\n"; { package Foo9; @@ -791,7 +900,7 @@ print "### Some path tests tests ###\n"; sub one_skip { 1 } sub two_skip { 1 } sub info_complete { 0 } - sub invalid_run_step { shift->jump('::') } + sub invalid_run_step { shift->goto_step('::') } } ok(Foo9->new->previous_step eq '', 'No previous step if not navigating'); @@ -799,21 +908,23 @@ my $c = Foo9->new(form => {step => 'one'}); $c->add_to_path('three', 'four', 'five'); $c->insert_path('one', 'two'); $c->navigate; -ok($Foo::test_stdout eq 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9"); +is($Foo::test_stdout, 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9"); ok(! eval { $c->set_path("more") }, "Can't call set_path after nav started"); $c = Foo9->new(form => {step => 'five'}); $c->set_path('one', 'two', 'three', 'four', 'five'); $c->navigate; -ok($Foo::test_stdout eq 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9"); +is($Foo::test_stdout, 'First(one) Previous(two) Current(three) Next(four) Last(five)', "Got the right content for Foo9"); $c = Foo9->new; $c->append_path('one'); -eval { $c->jump('FIRST') }; -ok($Foo::test_stdout eq '', "Can't jump without nav_loop"); +eval { $c->goto_step('FIRST') }; +is($Foo::test_stdout, 'Main Content', "Can jump without nav_loop started"); -eval { Foo9->new(form => {step => 'invalid'})->navigate }; -ok($Foo::test_stdout =~ /fatal.*invalid jump index/si, "Can't jump with invalid step"); +$c = Foo9->new; +$c->set_path('one'); +eval { $c->goto_step('main') }; +is($Foo::test_stdout, 'Main Content', "Can jump to step not on the path"); ###----------------------------------------------------------------### @@ -883,9 +994,11 @@ ok($Foo::test_stdout =~ /fatal.*invalid jump index/si, "Can't jump with invalid my $Foo10 = Foo10->new(form => {step => 'a'}); $Foo10->navigate; -ok($Foo10->join_path eq 'aababacdae(z)', 'Followed good path: '.$Foo10->join_path); +is($Foo10->join_path, 'aababacdae(z)', 'Followed good path'); ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; +print "### Integrated validation tests ###\n"; { package Foo11; @@ -946,7 +1059,7 @@ ok(! $f->ready_validate, "Not ready to validate"); sub step1_file_print { \ 'step1_file_print [% has_errors %]' } } -ok(Foo13->new(ext_val => 'html')->navigate->js_validation('step0') eq '', 'Got right validation'); +ok(Foo13->new(ext_val => 'html')->navigate, 'Ran Foo13'); ok($Foo::test_stdout eq 'Main Content', "Got the right content on Foo13 ($Foo::test_stdout)"); Foo13->new(form => {step => 'step1'})->navigate->js_validation('step1'); @@ -958,6 +1071,8 @@ ok(Foo13->new->js_validation('step1', 'foo', {}) eq '', "No validation found"); ok(Foo13->new->js_validation('step1', 'foo', {foo => {required => 1}}), "Validation found"); ###----------------------------------------------------------------### +print "#-----------------------------------------\n"; +print "### Header tests ###\n"; { package CGIX; @@ -996,3 +1111,4 @@ CGI::Ex::App->new(cgix => CGIX->new)->print_out('foo', \ "# the output\n"); ok($Foo::test_stdout eq 'Print: text/html', "Got right header: $Foo::test_stdout"); ###----------------------------------------------------------------###\ +print "#-----------------------------------------\n"; diff --git a/t/8_auth_00_base.t b/t/8_auth_00_base.t index 4b5cbfd..bf63018 100644 --- a/t/8_auth_00_base.t +++ b/t/8_auth_00_base.t @@ -7,7 +7,7 @@ =cut use strict; -use Test::More tests => 35; +use Test::More tests => 68; use_ok('CGI::Ex::Auth'); @@ -15,16 +15,22 @@ use_ok('CGI::Ex::Auth'); package Auth; use base qw(CGI::Ex::Auth); use strict; - use vars qw($printed $set_cookie $deleted_cookie); + use vars qw($printed $set_cookie $deleted_cookie $failed_login_user $cookie); - sub login_print { $printed = 1 } - sub set_cookie { $set_cookie = 1 } - sub delete_cookie { $deleted_cookie = 1 } + sub login_print { $failed_login_user = shift->login_hash_common->{'cea_user'}; $printed = 1 } + sub set_cookie { shift; $cookie = shift; $set_cookie = 1 } + sub delete_cookie { $cookie = {}; $deleted_cookie = 1 } sub get_pass_by_user { '123qwe' } sub script_name { $0 } sub no_cookie_verify { 1 } sub secure_hash_keys { ['aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', 'bbbbbbbbbbbbbbbbbbbbbbbbbbb', 'ccc'] } sub failed_sleep { 0 } + + sub reset { + $Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; + $Auth::failed_login_user = ''; + $Auth::cookie = {}; + } } { @@ -46,56 +52,127 @@ my $cookie_bad = { cea_user => 'test/123qw' }; my $cookie_good = { cea_user => 'test/123qwe' }; my $cookie_good2 = { cea_user => $token }; -sub form_good { Auth->get_valid_auth({form => {%$form_good}, cookies => {} }) } -sub form_good2 { Auth->get_valid_auth({form => {%$form_good2}, cookies => {} }) } -sub form_good3 { Aut2->get_valid_auth({form => {%$form_good3}, cookies => {} }) } -sub form_bad { Auth->get_valid_auth({form => {%$form_bad}, cookies => {} }) } -sub cookie_good { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good} }) } -sub cookie_good2 { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good2}}) } -sub cookie_bad { Auth->get_valid_auth({form => {}, cookies => {%$cookie_bad} }) } - -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub form_good { Auth->get_valid_auth({form => {%$form_good}, cookies => {} }) } +Auth::reset(); ok(form_good(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub form_good2 { Auth->get_valid_auth({form => {%$form_good2}, cookies => {} }) } +Auth::reset(); ok(form_good2(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub form_good3 { Aut2->get_valid_auth({form => {%$form_good3}, cookies => {} }) } +Auth::reset(); ok(form_good3(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub form_bad { Auth->get_valid_auth({form => {%$form_bad}, cookies => {} }) } +Auth::reset(); ok(! form_bad(), "Got bad auth"); ok($Auth::printed, "Printed was set"); ok(! $Auth::set_cookie, "set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); +is($Auth::failed_login_user, 'test', 'correct user on failed passed information'); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub cookie_good { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good} }) } +Auth::reset(); ok(cookie_good(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub cookie_good2 { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good2}}) } +Auth::reset(); ok(cookie_good2(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); -$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +sub cookie_bad { Auth->get_valid_auth({form => {}, cookies => {%$cookie_bad} }) } +Auth::reset(); ok(! cookie_bad(), "Got bad auth"); ok($Auth::printed, "Printed was set"); ok(! $Auth::set_cookie, "Set_cookie was not called"); -ok($Auth::deleted_cookie, "deleted_cookie was not called"); +ok($Auth::deleted_cookie, "deleted_cookie was called"); +is($Auth::failed_login_user, 'test', 'correct user on failed passed information'); + +sub combined_good { Auth->get_valid_auth({form => {cea_user => "test"}, cookies => {%$cookie_good}}) } +Auth::reset(); +ok(combined_good(), "Got good auth") || do { + my $e = $@; + use CGI::Ex::Dump qw(debug); + debug $e; + die; +}; +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie was called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +sub combined_bad { Auth->get_valid_auth({form => {cea_user => "test2"}, cookies => {%$cookie_good}}) } +Auth::reset(); +ok(! combined_bad(), "Got bad auth"); +ok($Auth::printed, "Printed was set"); +ok(! $Auth::set_cookie, "Set_cookie was not called"); +ok($Auth::deleted_cookie, "deleted_cookie was called"); +is($Auth::failed_login_user, 'test2', 'correct user on failed passed information'); + +sub combined_bad2 { Auth->get_valid_auth({form => {cea_user => "test"}, cookies => {%$cookie_bad}}) } +Auth::reset(); +ok(! combined_bad2(), "Got bad auth"); +ok($Auth::printed, "Printed was set"); +ok(! $Auth::set_cookie, "Set_cookie was not called"); +ok($Auth::deleted_cookie, "deleted_cookie was called"); +is($Auth::failed_login_user, 'test', 'correct user on failed passed information'); + +sub combined_bad3 { Auth->get_valid_auth({form => {cea_user => "test2/123"}, cookies => {%$cookie_good}}) } +Auth::reset(); +ok(! combined_bad3(), "Got bad auth"); +ok($Auth::printed, "Printed was set"); +ok(! $Auth::set_cookie, "Set_cookie was not called"); +ok($Auth::deleted_cookie, "deleted_cookie was called"); +is($Auth::failed_login_user, 'test2', 'correct user on failed passed information'); + +###----------------------------------------------------------------### + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}}); +ok($Auth::set_cookie, "Set_cookie called"); +ok($Auth::cookie->{'expires'}, "Cookie had expires"); + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}, use_session_cookie => 0}); +ok($Auth::set_cookie, "Set_cookie called"); +ok($Auth::cookie->{'expires'}, "Cookie had expires"); + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}, use_session_cookie => 1}); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::cookie->{'expires'}, "Session cookie"); + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}, use_plaintext => 1}); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::cookie->{'expires'}, "Session cookie"); + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}, use_plaintext => 1, use_session_cookie => 0}); +ok($Auth::set_cookie, "Set_cookie called"); +ok($Auth::cookie->{'expires'}, "Cookie had expires"); + +Auth::reset(); +Auth->get_valid_auth({form => {%$form_good}, cookies => {}, use_plaintext => 1, use_session_cookie => 1}); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::cookie->{'expires'}, "Session cookie"); + +###----------------------------------------------------------------### my $auth = Aut2->get_valid_auth({form => {%$form_good3}}); my $data = $auth->last_auth_data; @@ -118,7 +195,7 @@ SKIP: { sub form_good4 { Aut3->get_valid_auth({form => {%$form_good4}, cookies => {} }) } - $Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; + Auth::reset(); ok(form_good4(), "Got good auth"); ok(! $Auth::printed, "Printed was not set"); ok($Auth::set_cookie, "Set_cookie called"); diff --git a/t/9_jsondump_00_base.t b/t/9_jsondump_00_base.t index f3eea86..40fe489 100644 --- a/t/9_jsondump_00_base.t +++ b/t/9_jsondump_00_base.t @@ -61,8 +61,8 @@ test_dump({a => sub {}}, "{\"a\":\"CODE\"}", {handle_unknown_types => sub {my $s test_dump({a => 1}, "{}", {skip_keys => ['a']}); test_dump({a => 1}, "{}", {skip_keys => {a=>1}}); -test_dump({2 => 1, _a => 1}, "{2:1,\"_a\":1}", {pretty=>0}); -test_dump({2 => 1, _a => 1}, "{2:1}", {pretty=>0, skip_keys_qr => qr/^_/}); +test_dump({2 => 1, _a => 1}, "{\"2\":1,\"_a\":1}", {pretty=>0}); +test_dump({2 => 1, _a => 1}, "{\"2\":1}", {pretty=>0, skip_keys_qr => qr/^_/}); test_dump({a => 1}, "{\n \"a\" : 1\n}", {pretty => 1}); test_dump({a => 1}, "{\n \"a\" : 1\n}", {pretty => 1, hash_nl => "\n", hash_sep => " : ", indent => " "});