@@ -1,18 +1,3 @@
-2.42
- 2014-12-10
- * Adding protection to location bounces to stop potential XSS vulnerabilities
-
-2.41
- 2014-06-12
- * Restoring a tab character in Makefile.PL so that make can run again
-
-2.40
- 2012-12-17
- * Validation fixes for regex based keys
- * Allow for HTML5 types
- * Make sure that default values always stringify
- * App find_hook now returns a list
-
2.38
2012-03-02
* No functional changes, just fixes for newer versions of perl that have changed the way that "is" works.
@@ -94,4 +94,3 @@ t/6_die_00_base.t
t/7_template_00_base.t
t/8_auth_00_base.t
t/9_jsondump_00_base.t
-META.json Module JSON meta-data (added by MakeMaker)
@@ -1,41 +0,0 @@
-{
- "abstract" : "CGI utility suite - makes powerful application writing fun and easy",
- "author" : [
- "Paul Seamons"
- ],
- "dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.120921",
- "license" : [
- "unknown"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "CGI-Ex",
- "no_index" : {
- "directory" : [
- "t",
- "inc"
- ]
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "0"
- }
- },
- "configure" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "0"
- }
- },
- "runtime" : {
- "requires" : {
- "Template::Alloy" : "1.016"
- }
- }
- },
- "release_status" : "stable",
- "version" : "2.42"
-}
@@ -1,22 +1,22 @@
----
-abstract: 'CGI utility suite - makes powerful application writing fun and easy'
+--- #YAML:1.0
+name: CGI-Ex
+version: 2.38
+abstract: CGI utility suite - makes powerful application writing fun and easy
author:
- - 'Paul Seamons'
-build_requires:
- ExtUtils::MakeMaker: 0
+ - Paul Seamons
+license: unknown
+distribution_type: module
configure_requires:
- ExtUtils::MakeMaker: 0
-dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.120921'
-license: unknown
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: CGI-Ex
-no_index:
- directory:
- - t
- - inc
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
requires:
- Template::Alloy: 1.016
-version: 2.42
+ Template::Alloy: 1.004
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.56
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
@@ -12,19 +12,19 @@ WriteMakefile(
VERSION_FROM => "lib/CGI/Ex.pm",
INSTALLDIRS => 'site',
PREREQ_PM => {
- 'Template::Alloy' => '1.016',
+ 'Template::Alloy' => '1.004',
},
-
+
dist => {
DIST_DEFAULT => 'all tardist',
COMPRESS => 'gzip -vf',
SUFFIX => '.gz',
},
-
+
clean => {
FILES => '*~',
},
-
+
realclean => {
FILES => '*~',
},
@@ -34,7 +34,7 @@ package MY;
sub postamble {
return qq^
-
+
pm_to_blib: README
README: \$(VERSION_FROM)
@@ -0,0 +1,352 @@
+NAME
+ CGI::Ex - CGI utility suite - makes powerful application writing fun and
+ easy
+
+CGI::Ex SYNOPSIS
+ ### You probably don't want to use CGI::Ex directly
+ ### You probably should use CGI::Ex::App instead.
+
+ my $cgix = CGI::Ex->new;
+
+ $cgix->print_content_type;
+
+ my $hash = $cgix->form;
+
+ if ($hash->{'bounce'}) {
+
+ $cgix->set_cookie({
+ name => ...,
+ value => ...,
+ });
+
+ $cgix->location_bounce($new_url_location);
+ exit;
+ }
+
+ if (scalar keys %$form) {
+ my $val_hash = $cgix->conf_read($pathtovalidation);
+ my $err_obj = $cgix->validate($hash, $val_hash);
+ if ($err_obj) {
+ my $errors = $err_obj->as_hash;
+ my $input = "Some content";
+ my $content = "";
+ $cgix->swap_template(\$input, $errors, $content);
+ $cgix->fill({text => \$content, form => $hashref});
+ print $content;
+ exit;
+ } else {
+ print "Success";
+ }
+ } else {
+ print "Main page";
+ }
+
+DESCRIPTION
+ CGI::Ex provides a suite of utilities to make writing CGI scripts more
+ enjoyable. Although they can all be used separately, the main
+ functionality of each of the modules is best represented in the
+ CGI::Ex::App module. CGI::Ex::App takes CGI application building to the
+ next step. CGI::Ex::App is not quite a framework (which normally
+ includes pre-built html) instead CGI::Ex::App is an extended application
+ flow that dramatically reduces CGI build time in most cases. It does so
+ using as little magic as possible. See CGI::Ex::App.
+
+ The main functionality is provided by several other modules that may be
+ used separately, or together through the CGI::Ex interface.
+
+ "CGI::Ex::Template"
+ A Template::Toolkit compatible processing engine. With a few
+ limitations, CGI::Ex::Template can be a drop in replacement for
+ Template::Toolkit.
+
+ "CGI::Ex::Fill"
+ A regular expression based form filler inner (accessed through
+ ->fill or directly via its own functions). Can be a drop in
+ replacement for HTML::FillInForm. See CGI::Ex::Fill for more
+ information.
+
+ "CGI::Ex::Validate"
+ A form field / cgi parameter / any parameter validator (accessed
+ through ->validate or directly via its own methods). Not quite a
+ drop in for most validators, although it has most of the
+ functionality of most of the validators but with the key additions
+ of conditional validation. Has a tightly integrated JavaScript
+ portion that allows for duplicate client side validation. See
+ CGI::Ex::Validate for more information.
+
+ "CGI::Ex::Conf"
+ A general use configuration, or settings, or key / value file
+ reader. Has ability for providing key fallback as well as immutable
+ key definitions. Has default support for yaml, storable, perl, ini,
+ and xml and open architecture for definition of others. See
+ CGI::Ex::Conf for more information.
+
+ "CGI::Ex::Auth"
+ A highly configurable web based authentication system. See
+ CGI::Ex::Auth for more information.
+
+CGI::Ex METHODS
+ "->fill"
+ fill is used for filling hash or cgi object values into an existing
+ html document (it doesn't deal at all with how you got the
+ document). Arguments may be given as a hash, or a hashref or
+ positional. Some of the following arguments will only work using
+ CGI::Ex::Fill - most will work with either CGI::Ex::Fill or
+ HTML::FillInForm (assume they are available unless specified
+ otherwise). (See CGI::Ex::Fill for a full explanation of
+ functionality). The arguments to fill are as follows (and in order
+ of position):
+
+ "text"
+ Text should be a reference to a scalar string containing the
+ html to be modified (actually it could be any reference or
+ object reference that can be modified as a string). It will be
+ modified in place. Another named argument scalarref is available
+ if you would like to copy rather than modify.
+
+ "form"
+ Form may be a hashref, a cgi style object, a coderef, or an
+ array of multiple hashrefs, cgi objects, and coderefs. Hashes
+ should be key value pairs. CGI objects should be able to call
+ the method param (This can be overrided). Coderefs should expect
+ the field name as an argument and should return a value. Values
+ returned by form may be undef, scalar, arrayref, or coderef
+ (coderef values should expect an argument of field name and
+ should return a value). The code ref options are available to
+ delay or add options to the bringing in of form information -
+ without having to tie the hash. Coderefs are not available in
+ HTML::FillInForm. Also HTML::FillInForm only allows CGI objects
+ if an arrayref is used.
+
+ NOTE: Only one of the form, fdat, and fobject arguments are
+ allowed at a time.
+
+ "target"
+ The name of the form that the fields should be filled to. The
+ default value of undef, means to fill in all forms in the html.
+
+ "fill_passwords"
+ Boolean value defaults to 1. If set to zero - password fields
+ will not be filled.
+
+ "ignore_fields"
+ Specify which fields to not fill in. It takes either array ref
+ of names, or a hashref with the names as keys. The hashref
+ option is not available in CGI::Ex::Fill.
+
+ Other named arguments are available for compatibility with
+ HTML::FillInForm. They may only be used as named arguments.
+
+ "scalarref"
+ Almost the same as the argument text. If scalarref is used, the
+ filled html will be returned. If text is used the html passed is
+ filled in place.
+
+ "arrayref"
+ An array ref of lines of the document. Forces a returned filled
+ html document.
+
+ "file"
+ An filename that will be opened, filled, and returned.
+
+ "fdat"
+ A hashref of key value pairs.
+
+ "fobject"
+ A cgi style object or arrayref of cgi style objects used for
+ getting the key value pairs. Should be capable of the ->param
+ method and ->cookie method as document in CGI.
+
+ See CGI::Ex::Fill for more information about the filling process.
+
+ "->object"
+ Returns the CGI object that is currently being used by CGI::Ex. If
+ none has been set it will automatically generate an object of type
+ $PREFERRED_CGI_MODULE which defaults to CGI.
+
+ "->validate"
+ Validate has a wide range of options available. (See
+ CGI::Ex::Validate for a full explanation of functionality). Validate
+ has two arguments:
+
+ "form"
+ Can be either a hashref to be validated, or a CGI style object
+ (which has the param method).
+
+ "val_hash"
+ The val_hash can be one of three items. First, it can be a
+ straight perl hashref containing the validation to be done.
+ Second, it can be a YAML document string. Third, it can be the
+ path to a file containing the validation. The validation in a
+ validation file will be read in depending upon file extension.
+
+ "->get_form"
+ Very similar to CGI->new->Vars except that arrays are returned as
+ arrays. Not sure why CGI didn't do this anyway (well - yes - legacy
+ Perl 4 - but at some point things need to be updated).
+
+ my $hash = $cgix->get_form;
+ my $hash = $cgix->get_form(CGI->new);
+ my $hash = get_form();
+ my $hash = get_form(CGI->new);
+
+ "->set_form"
+ Allow for setting a custom form hash. Useful for testing, or other
+ purposes.
+
+ $cgix->set_form(\%new_form);
+
+ "->get_cookies"
+ Returns a hash of all cookies.
+
+ my $hash = $cgix->get_cookies;
+ my $hash = $cgix->get_cookies(CGI->new);
+ my $hash = get_cookies();
+ my $hash = get_cookies(CGI->new);
+
+ "->set_cookies"
+ Allow for setting a custom cookies hash. Useful for testing, or
+ other purposes.
+
+ $cgix->set_cookies(\%new_cookies);
+
+ "->make_form"
+ Takes a hash and returns a query_string. A second optional argument
+ may contain an arrayref of keys to use from the hash in building the
+ query_string. First argument is undef, it will use the form stored
+ in itself as the hash.
+
+ "->content_type"
+ Can be called multiple times during the same session. Will only
+ print content-type once. (Useful if you don't know if something else
+ already printed content-type). Calling this sends the Content-type
+ header. Trying to print ->content_type is an error. For clarity, the
+ method ->print_content_type is available.
+
+ $cgix->print_content_type;
+
+ # OR
+ $cgix->print_content_type('text/html');
+
+ # OR
+ $cgix->print_content_type('text/html', 'utf-8');
+
+ "->set_cookie"
+ Arguments are the same as those to CGI->new->cookie({}). Uses CGI's
+ cookie method to create a cookie, but then, depending on if content
+ has already been sent to the browser will either print a Set-cookie
+ header, or will add a <meta http-equiv='set-cookie'> tag (this is
+ supported on most major browsers). This is useful if you don't know
+ if something else already printed content-type.
+
+ "->location_bounce"
+ Depending on if content has already been sent to the browser will
+ either print a Location header, or will add a <meta
+ http-equiv='refresh'> tag (this is supported on all major browsers).
+ This is useful if you don't know if something else already printed
+ content-type. Takes single argument of a url.
+
+ "->last_modified"
+ Depending on if content has already been sent to the browser will
+ either print a Last-Modified header, or will add a <meta
+ http-equiv='Last-Modified'> tag (this is supported on most major
+ browsers). This is useful if you don't know if something else
+ already printed content-type. Takes an argument of either a time
+ (may be a CGI -expires style time) or a filename.
+
+ "->expires"
+ Depending on if content has already been sent to the browser will
+ either print a Expires header, or will add a <meta
+ http-equiv='Expires'> tag (this is supported on most major
+ browsers). This is useful if you don't know if something else
+ already printed content-type. Takes an argument of a time (may be a
+ CGI -expires style time).
+
+ "->send_status"
+ Send a custom status. Works in both CGI and mod_perl. Arguments are
+ a status code and the content (optional).
+
+ "->send_header"
+ Send a http header. Works in both CGI and mod_perl. Arguments are a
+ header name and the value for that header.
+
+ "->print_js"
+ Prints out a javascript file. Does everything it can to make sure
+ that the javascript will cache. Takes either a full filename, or a
+ shortened name which will be looked for in @INC. (ie
+ /full/path/to/my.js or CGI/Ex/validate.js or CGI::Ex::validate)
+
+ #!/usr/bin/perl
+ use CGI::Ex;
+ CGI::Ex->print_js($ENV{'PATH_INFO'});
+
+ "->swap_template"
+ This is intended as a simple yet strong subroutine to swap in tags
+ to a document. It is intended to be very basic for those who may not
+ want the full features of a Templating system such as
+ Template::Toolkit (even though they should investigate them because
+ they are pretty nice). The default allows for basic template toolkit
+ variable swapping. There are two arguments. First is a string or a
+ reference to a string. If a string is passed, a copy of that string
+ is swapped and returned. If a reference to a string is passed, it is
+ modified in place. The second argument is a form, or a CGI object,
+ or a cgiex object, or a coderef (if the second argument is missing,
+ the cgiex object which called the method will be used). If it is a
+ coderef, it should accept key as its only argument and return the
+ proper value.
+
+ my $cgix = CGI::Ex->new;
+ my $form = {foo => 'bar',
+ this => {is => {nested => ['wow', 'wee']}}
+ };
+
+ my $str = $cgix->swap_template("<html>[% foo %]<br>[% foo %]</html>", $form));
+ # $str eq '<html>bar<br>bar</html>'
+
+ $str = $cgix->swap_template("[% this.is.nested.1 %]", $form));
+ # $str eq 'wee'
+
+ $str = "[% this.is.nested.0 %]";
+ $cgix->swap_template(\$str, $form);
+ # $str eq 'wow'
+
+ # may also be called with only one argument as follows:
+ # assuming $cgix had a query string of ?foo=bar&baz=wow&this=wee
+ $str = "<html>([% foo %]) <br>
+ ([% baz %]) <br>
+ ([% this %]) </html>";
+ $cgix->swap_template(\$str);
+ #$str eq "<html>(bar) <br>
+ # (wow) <br>
+ # (wee) </html>";
+
+ For further examples, please see the code contained in
+ t/samples/cgi_ex_* of this distribution.
+
+ If at a later date, the developer upgrades to Template::Toolkit, the
+ templates that were being swapped by CGI::Ex::swap_template should
+ be compatible with Template::Toolkit.
+
+MODULES
+ See also CGI::Ex::App.
+
+ See also CGI::Ex::Auth.
+
+ See also CGI::Ex::Conf.
+
+ See also CGI::Ex::Die.
+
+ See also CGI::Ex::Dump.
+
+ See also CGI::Ex::Fill.
+
+ See also CGI::Ex::Template.
+
+ See also CGI::Ex::Validate.
+
+LICENSE
+ This module may be distributed under the same terms as Perl itself.
+
+AUTHOR
+ Paul Seamons <perl at seamons dot com>
+
@@ -6,12 +6,14 @@ CGI::Ex::App::Constants - Easier access to magic App values
=cut
-use vars qw(%constants @EXPORT @EXPORT_OK %EXPORT_TAGS);
+use vars qw(%constants @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
use strict;
use warnings;
use Exporter qw(import); # allow for goto from CGI::Ex::App
use base qw(Exporter);
+$VERSION = '2.38';
+
BEGIN {
my $all = {
App__allow_morph__allow_reblessing => '1 - This will allow changing MyApp to MyApp::MyStep when on step my_step',
@@ -1,38 +1,45 @@
package CGI::Ex::App;
###---------------------###
-# Copyright 2004-2014 - Paul Seamons
+# See the perldoc in CGI/Ex/App.pod
+# Copyright 2004-2012 - Paul Seamons
# Distributed under the Perl Artistic License without warranty
use strict;
+use Carp qw(croak);
BEGIN {
eval { use Time::HiRes qw(time) };
eval { use Scalar::Util };
}
-our $VERSION = '2.42';
-
-sub croak { die sprintf "%s at %3\$s line %4\$s\n", $_[0], caller 1 }
+our $VERSION = '2.38';
sub new {
- my $class = shift || croak "Missing class name";
- my $self = bless ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_}, $class;
+ my $class = shift || croak "Usage: ".__PACKAGE__."->new";
+ my $self = ref($_[0]) ? shift() : (@_ % 2) ? {} : {@_};
+ bless $self, $class;
+
$self->init;
$self->init_from_conf;
+
return $self;
}
sub init {}
sub init_from_conf {
my $self = shift;
- @$self{keys %$_} = values %$_ if $self->load_conf and $_ = $self->conf;
+ return if ! $self->load_conf;
+ my $conf = $self->conf;
+ @{ $self }{ keys %$conf } = values %$conf;
+ return;
}
sub import { # only ever called with explicit use CGI::Ex::App qw() - not with use base
my $class = shift;
- return if not @_ = grep { /^:?App($|__)/ } @_;
- require CGI::Ex::App::Constants;
- unshift @_, 'CGI::Ex::App::Constants';
- goto &CGI::Ex::App::Constants::import;
+ if (@_ = grep { /^:?App($|__)/ } @_) {
+ require CGI::Ex::App::Constants;
+ unshift @_, 'CGI::Ex::App::Constants';
+ goto &CGI::Ex::App::Constants::import;
+ }
}
###---------------------###
@@ -55,16 +62,19 @@ sub navigate {
}
}
$self->handle_error($@) if ! $self->{'_no_post_navigate'} && ! eval { $self->post_navigate; 1 } && $@ && $@ ne "Long Jump\n";
+
$self->destroy;
return $self;
}
sub nav_loop {
my $self = shift;
+
local $self->{'_recurse'} = $self->{'_recurse'} || 0;
if ($self->{'_recurse'}++ >= $self->recurse_limit) {
my $err = "recurse_limit (".$self->recurse_limit.") reached";
- croak(($self->{'jumps'} || 0) <= 1 ? $err : "$err number of jumps (".$self->{'jumps'}.")");
+ $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
+ croak $err;
}
my $path = $self->path;
@@ -84,56 +94,64 @@ sub nav_loop {
}
$self->run_hook('morph', $step); # let steps be in external modules
+
+ # 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->run_hook('unmorph', $step);
return;
}
- $self->run_hook('refine_path', $step, $self->{'path_i'} >= $#$path);
+ 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->run_hook('unmorph', $step);
}
return if $self->post_loop($path);
+
$self->insert_path($self->default_step); # run the default step as a last resort
$self->nav_loop; # go recursive
+
return;
}
sub path {
my $self = shift;
return $self->{'path'} ||= do {
- my @path;
+ my $path = [];
+
$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;
+ push @$path, $self->forbidden_step;
} elsif ($self->valid_steps # must be in valid_steps if defined
&& ! $self->valid_steps->{$step}
&& $step ne $self->default_step
&& $step ne $self->js_step) {
$self->stash->{'forbidden_step'} = $step;
- push @path, $self->forbidden_step;
+ push @$path, $self->forbidden_step;
} else {
- push @path, $step;
+ push @$path, $step;
}
}
- \@path;
+ $path;
};
}
sub parse_path_info {
my ($self, $type, $maps, $info, $form) = @_;
- return if !$maps;
$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] or next;
- $form ||= $self->form;
+ my @match = $info =~ $map->[0];
+ next if ! @match;
if (UNIVERSAL::isa($map->[1], 'CODE')) {
$map->[1]->($form, @match);
} else {
@@ -145,26 +163,31 @@ sub parse_path_info {
sub run_hook {
my ($self, $hook, $step, @args) = @_;
- my ($code, $found) = (ref $hook eq 'CODE') ? ($_[1], $hook = 'coderef') : ($self->find_hook($hook, $step));
+ 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');
- return scalar $self->$code($step, @args) if !$self->{'no_history'};
-
- push @{ $self->history }, my $hist = {step => $step, meth => $hook, found => $found, time => time, level => $self->{'_level'}, elapsed => 0};
+ my $hist;
+ if (! $self->{'no_history'}) {
+ push @{ $self->history }, ($hist = {step => $step, meth => $hook, found => $found, time => time, level => $self->{'_level'}});
+ $hist->{'elapsed'} = time - $hist->{'time'};
+ }
local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
- $hist->{'elapsed'} = time - $hist->{'time'};
- return $hist->{'response'} = $self->$code($step, @args);
-}
-sub find_hook {
- my ($self, $hook, $step) = @_;
- croak "Missing hook name" if ! $hook;
- if ($step and my $code = $self->can("${step}_${hook}")) {
- return ($code, "${step}_${hook}");
- } elsif ($code = $self->can($hook)) {
- return ($code, $hook);
+ my $resp = $self->$code($step, @args);
+
+ if (! $self->{'no_history'}) {
+ $hist->{'elapsed'} = time - $hist->{'time'};
+ $hist->{'response'} = $resp;
}
- return;
+
+ return $resp;
}
sub run_hook_as {
@@ -179,7 +202,9 @@ sub run_hook_as {
}
sub run_step {
- my ($self, $step) = @_;
+ my $self = shift;
+ my $step = shift;
+
return 1 if $self->run_hook('pre_step', $step); # if true exit the nav_loop
return 0 if $self->run_hook('skip', $step); # if true skip this step
@@ -226,7 +251,7 @@ sub print {
sub handle_error {
my ($self, $err) = @_;
die $err if $self->{'_handling_error'};
- local @$self{'_handling_error', '_recurse' } = (1, 0); # allow for this next step - even if we hit a recurse error
+ local @{ $self }{'_handling_error', '_recurse' } = (1, 0); # allow for this next step - even if we hit a recurse error
$self->stash->{'error_step'} = $self->current_step;
$self->stash->{'error'} = $err;
eval {
@@ -242,7 +267,6 @@ sub handle_error {
sub allow_morph { $_[0]->{'allow_morph'} }
sub auth_args { $_[0]->{'auth_args'} }
-sub auth_obj { shift->{'auth_obj'} || do { require CGI::Ex::Auth; CGI::Ex::Auth->new(@_) } }
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'} }
@@ -259,12 +283,11 @@ 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 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_obj { shift->{'template_obj'} || do { require Template::Alloy; Template::Alloy->new(@_) } }
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 }
@@ -280,6 +303,22 @@ sub conf_obj {
};
}
+sub template_obj {
+ my ($self, $args) = @_;
+ return $self->{'template_obj'} || do {
+ require Template::Alloy;
+ Template::Alloy->new($args);
+ };
+}
+
+sub auth_obj {
+ my ($self, $args) = @_;
+ return $self->{'auth_obj'} || do {
+ require CGI::Ex::Auth;
+ CGI::Ex::Auth->new($args);
+ };
+}
+
sub val_obj {
my $self = shift;
return $self->{'val_obj'} || do {
@@ -309,8 +348,9 @@ sub conf {
$self->{'conf'} = pop if @_ == 1;
return $self->{'conf'} ||= do {
my $conf = $self->conf_file;
- $conf = $self->conf_obj->read($conf, {no_warn_on_fail => 1}) || ($self->conf_die_on_fail ? croak $@ : {})
- if ! ref $conf;
+ if (! ref $conf) {
+ $conf = $self->conf_obj->read($conf, {no_warn_on_fail => 1}) || ($self->conf_die_on_fail ? croak $@ : {});
+ }
my $hash = $self->conf_validation;
if ($hash && scalar keys %$hash) {
my $err_obj = $self->val_obj->validate($conf, $hash);
@@ -377,19 +417,21 @@ sub add_errors {
sub add_to_hash {
my $self = shift;
my $old = shift;
- my $new = ref($_[0]) ? shift : {@_};
- @$old{keys %$new} = values %$new;
+ my $new = shift;
+ $new = {$new, @_} if ! ref $new; # non-hashref
+ $old->{$_} = $new->{$_} foreach keys %$new;
}
sub clear_app {
my $self = shift;
- delete @$self{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
- _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
+ delete @{ $self }{qw(cgix cookies form hash_common hash_errors hash_fill hash_swap history
+ _morph_lineage _morph_lineage_start_index path path_i stash val_obj)};
return $self;
}
sub dump_history {
my ($self, $all) = @_;
+
my $hist = $self->history;
my $dump = [sprintf "Elapsed: %.5f", time - $self->{'_time'}];
@@ -399,16 +441,19 @@ sub dump_history {
next;
}
my $note = (' ' x ($row->{'level'} || 0))
- . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf '%.5f', $row->{'elapsed'});
+ . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
my $resp = $row->{'response'};
if ($all) {
$note = [$note, $resp];
} else {
$note .= ' - '
- .(! defined $resp ? 'undef'
- : ref($resp) eq 'ARRAY' && !@$resp ? '[]'
- : ref($resp) eq 'HASH' && !scalar keys %$resp ? '{}'
- : $resp =~ /^(.{30}|.{0,30}(?=\n))(?s:.)/ ? "$1..." : $resp);
+ .(! defined $resp ? 'undef'
+ : ref($resp) eq 'ARRAY' && ! @$resp ? '[]'
+ : ref($resp) eq 'HASH' && ! scalar keys %$resp ? '{}'
+ : do {
+ $resp = $1 if $resp =~ /^(.+)\n/;
+ length($resp) > 30 ? substr($resp, 0, 30)." ..." : $resp;
+ });
$note .= ' - '.$row->{'info'} if defined $row->{'info'};
}
push @$dump, $note;
@@ -427,6 +472,17 @@ sub exit_nav_loop {
die "Long Jump\n";
}
+sub find_hook {
+ my ($self, $hook, $step) = @_;
+ croak "Missing hook name" if ! $hook;
+ if ($step && (my $code = $self->can("${step}_${hook}"))) {
+ return [$code, "${step}_${hook}"],
+ } elsif ($code = $self->can($hook)) {
+ return [$code, $hook];
+ }
+ return [];
+}
+
sub insert_path {
my $self = shift;
my $ref = $self->path;
@@ -534,7 +590,7 @@ sub morph {
}
} elsif ($allow ne '1') {
$ref->{'info'} = "package $new doesn't support CGI::Ex::App API";
- die "Found package $new, but $new does not support CGI::Ex::App API";
+ die "Found package $new, but $new doesn't support CGI::Ex::App API";
}
$ok = 1;
}
@@ -599,6 +655,7 @@ sub file_print {
$_step =~ s|\B__+|/|g;
$_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+
return $base_dir . $module . $_step;
}
@@ -621,10 +678,11 @@ sub file_val {
if (@$abs > 1) {
foreach my $_abs (@$abs) {
- my $path = "$_abs/$base_dir/$module/$_step";
+ my $path = $_abs . $base_dir . $module . $_step;
return $path if -e $path;
}
}
+
return $abs->[0] . $base_dir . $module . $_step;
}
@@ -632,7 +690,7 @@ sub fill_template {
my ($self, $step, $outref, $fill) = @_;
return if ! $fill || ! scalar keys %$fill;
my $args = $self->run_hook('fill_args', $step) || {};
- local @$args{'text', 'form'} = ($outref, $fill);
+ local @{ $args }{'text', 'form'} = ($outref, $fill);
require CGI::Ex::Fill;
CGI::Ex::Fill::fill($args);
}
@@ -641,6 +699,7 @@ sub finalize { 1 } # false means show step
sub hash_base {
my ($self, $step) = @_;
+
my $hash = $self->{'hash_base'} ||= {
script_name => $self->script_name,
path_info => $self->path_info,
@@ -651,6 +710,7 @@ sub hash_base {
$hash->{'generate_form'} = sub { $copy->run_hook('generate_form', $step, (ref($_[0]) ? (undef, shift) : shift)) };
$hash->{'form_name'} = $self->run_hook('form_name', $step);
$hash->{$self->step_key} = $step;
+
return $hash;
}
@@ -671,15 +731,17 @@ sub hash_validation {
sub info_complete {
my ($self, $step) = @_;
return 0 if ! $self->run_hook('ready_validate', $step);
- return $self->run_hook('validate', $step, $self->form) ? 1 : 0;
+ return 0 if ! $self->run_hook('validate', $step, $self->form);
+ return 1;
}
sub js_validation {
my ($self, $step) = @_;
my $form_name = $_[2] || $self->run_hook('form_name', $step);
my $hash_val = $_[3] || $self->run_hook('hash_validation', $step);
+ my $js_uri = $self->js_uri_path;
return '' if ! $form_name || ! ref($hash_val) || ! scalar keys %$hash_val;
- return $self->val_obj->generate_js($hash_val, $form_name, $self->js_uri_path);
+ return $self->val_obj->generate_js($hash_val, $form_name, $js_uri);
}
sub generate_form {
@@ -705,7 +767,8 @@ sub morph_package {
sub name_module {
my ($self, $step) = @_;
return $self->{'name_module'} ||= ($self->script_name =~ m/ (\w+) (?:\.\w+)? $/x)
- ? $1 : die "Could not determine module name from \"name_module\" lookup (".($step||'').")\n";
+ ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
+ : die "Couldn't determine module name from \"name_module\" lookup (".($step||'').")";
}
sub name_step { my ($self, $step) = @_; $step }
@@ -717,32 +780,34 @@ sub prepare { 1 } # false means show step
sub print_out {
my ($self, $step, $out) = @_;
- $self->cgix->print_content_type($self->run_hook('mimetype', $step), $self->run_hook('charset', $step));
+ $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
print ref($out) eq 'SCALAR' ? $$out : $out;
}
sub ready_validate {
my ($self, $step) = @_;
- if ($self->run_hook('validate_when_data', $step)
- and my @keys = keys %{ $self->run_hook('hash_validation', $step) || {} }) {
- my $form = $self->form;
- return (grep { exists $form->{$_} } @keys) ? 1 : 0;
+ if ($self->run_hook('validate_when_data', $step)) {
+ if (my @keys = keys %{ $self->run_hook('hash_validation', $step) || {} }) {
+ my $form = $self->form;
+ return (grep { exists $form->{$_} } @keys) ? 1 : 0;
+ }
}
return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
}
sub refine_path {
my ($self, $step, $is_at_end) = @_;
- return 0 if ! $is_at_end; # if we are not at the end of the path, do not do anything
+ return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
+
my $next_step = $self->run_hook('next_step', $step) || return 0;
$self->run_hook('set_ready_validate', $step, 0);
$self->append_path($next_step);
return 1;
}
-sub set_ready_validate {
+sub set_ready_validate { # hook and method
my $self = shift;
- my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift); # hook and method
+ my ($step, $is_ready) = (@_ == 2) ? @_ : (undef, shift);
$ENV{'REQUEST_METHOD'} = ($is_ready) ? 'POST' : 'GET';
return $is_ready;
}
@@ -751,42 +816,46 @@ sub skip { 0 } # success indicates to skip the step (and continue loop)
sub swap_template {
my ($self, $step, $file, $swap) = @_;
- my $t = $self->__template_obj($step);
- my $out = '';
- $t->process($file, $swap, \$out) || die $t->error;
- return $out;
-}
-sub __template_obj {
- my ($self, $step) = @_;
my $args = $self->run_hook('template_args', $step) || {};
$args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
- return $self->template_obj($args);
+
+ my $t = $self->template_obj($args);
+ my $out = '';
+ $t->process($file, $swap, \$out) || die $t->error;
+ return $out;
}
sub validate {
my ($self, $step, $form) = @_;
- my $hash = $self->__hash_validation($step);
- return 1 if ! ref($hash) || ! scalar keys %$hash;
- my @validated_fields;
- if (my $err_obj = eval { $self->val_obj->validate($form, $hash, \@validated_fields) }) {
- $self->add_errors($err_obj->as_hash({as_hash_join => "<br>\n", as_hash_suffix => '_error'}));
+ my $hash = $self->run_hook('hash_validation', $step);
+ my $what_was_validated = [];
+
+ return 1 if ! ref($hash) || ! scalar keys %$hash;
+ my $err_obj = eval { $self->val_obj->validate($form, $hash, $what_was_validated) };
+ die "Step $step: $@" if $@ && ! $err_obj;
+
+ ### had an error - store the errors and return false
+ if ($err_obj) {
+ $self->add_errors($err_obj->as_hash({
+ as_hash_join => "<br>\n",
+ as_hash_suffix => '_error',
+ }));
return 0;
}
- die "Step $step: $@" if $@;
- foreach my $ref (@validated_fields) { # allow for the validation to give us some redirection
- $self->append_path( ref $_ ? @$_ : $_) if $_ = $ref->{'append_path'};
- $self->replace_path(ref $_ ? @$_ : $_) if $_ = $ref->{'replace_path'};
- $self->insert_path( ref $_ ? @$_ : $_) if $_ = $ref->{'insert_path'};
+ ### allow for the validation to give us some redirection
+ foreach my $ref (@$what_was_validated) {
+ foreach my $method (qw(append_path replace_path insert_path)) {
+ next if ! (my $val = $ref->{$method});
+ $self->$method(ref $val ? @$val : $val);
+ }
}
return 1;
}
-sub __hash_validation { shift->run_hook('hash_validation', @_) }
-
sub validate_when_data { $_[0]->{'validate_when_data'} }
###---------------------###
@@ -795,7 +864,7 @@ sub validate_when_data { $_[0]->{'validate_when_data'} }
sub navigate_authenticated {
my ($self, $args) = @_;
$self = $self->new($args) if ! ref $self;
- croak "Cannot call navigate_authenticated method if default require_auth method is overwritten"
+ croak "Can't call navigate_authenticated method if default require_auth method is overwritten"
if $self->can('require_auth') != \&CGI::Ex::App::require_auth;
$self->require_auth(1);
return $self->navigate;
@@ -809,7 +878,12 @@ sub require_auth {
sub is_authed { my $data = shift->auth_data; $data && ! $data->{'error'} }
-sub check_valid_auth { shift->_do_auth({login_print => sub {}, location_bounce => sub {}}) }
+sub check_valid_auth {
+ return shift->_do_auth({
+ login_print => sub {}, # check only - don't login if not
+ location_bounce => sub {}, # call get_valid_auth - but don't bounce to other locations
+ });
+}
sub get_valid_auth {
my $self = shift;
@@ -823,9 +897,11 @@ sub get_valid_auth {
});
}
+
sub _do_auth {
my ($self, $extra) = @_;
return $self->auth_data if $self->is_authed;
+
my $args = { %{ $self->auth_args || {} }, %{ $extra || {} } };
$args->{'script_name'} ||= $self->script_name;
$args->{'path_info'} ||= $self->path_info;
@@ -842,17 +918,19 @@ sub _do_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
+
return ($resp && $data) ? $data : undef;
}
###---------------------###
# default steps
-sub js_require_auth { 0 }
sub js_run_step { # step that allows for printing javascript libraries that are stored in perls @INC.
my $self = shift;
- my $path = $self->form->{'js'} || $self->path_info;
- $self->cgix->print_js($path =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$! ? $1 : '');
+ my $file = $self->form->{'js'} || $self->path_info;
+ $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; # make sure path info looks like /js/CGI/Ex/foo.js
+
+ $self->cgix->print_js($file);
$self->{'_no_post_navigate'} = 1;
return 1;
}
@@ -874,4 +952,6 @@ 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<br>[% login_error %]" }
-1; # Full documentation resides in CGI/Ex/App.pod
+1;
+
+### See the perldoc in CGI/Ex/App.pod
@@ -1418,7 +1418,7 @@ should return an arrayref containing the code_ref to run, and the
name of the method looked for. It uses ->can to find the appropriate
hook.
- my $code = $self->find_hook('finalize', 'main');
+ my $code = $self->hook('finalize', 'main');
### will look first for $self->main_finalize;
### will then look for $self->finalize;
@@ -2246,7 +2246,7 @@ hook in another package.
# OR
- my $hash = $self->run_hook_as('hash_swap', 'step', 'SomeOther::Module');
+ 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.
@@ -3205,6 +3205,6 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,7 +7,7 @@ CGI::Ex::Auth - Handle logins nicely.
=cut
###----------------------------------------------------------------###
-# Copyright 2004-2014 - Paul Seamons #
+# Copyright 2004-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
@@ -19,7 +19,7 @@ use Digest::MD5 qw(md5_hex);
use CGI::Ex;
use Carp qw(croak);
-$VERSION = '2.42';
+$VERSION = '2.38';
###----------------------------------------------------------------###
@@ -1402,6 +1402,6 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHORS
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,14 +7,15 @@ CGI::Ex::Conf - Conf Reader/Writer for many different data format types
=cut
###----------------------------------------------------------------###
-# Copyright 2003-2014 - Paul Seamons #
+# Copyright 2003-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use strict;
use base qw(Exporter);
use Carp qw(croak);
-use vars qw(@DEFAULT_PATHS
+use vars qw($VERSION
+ @DEFAULT_PATHS
$DEFAULT_EXT
%EXT_READERS
%EXT_WRITERS
@@ -28,6 +29,8 @@ use vars qw(@DEFAULT_PATHS
);
@EXPORT_OK = qw(conf_read conf_write in_cache);
+$VERSION = '2.38';
+
$DEFAULT_EXT = 'conf';
%EXT_READERS = ('' => \&read_handler_yaml,
@@ -922,7 +925,7 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,12 +7,13 @@ CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
=cut
###----------------------------------------------------------------###
-# Copyright 2004-2014 - Paul Seamons #
+# Copyright 2004-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use strict;
-use vars qw($no_recurse
+use vars qw($VERSION
+ $no_recurse
$EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL
$ERROR_TEMPLATE
$LOG_HANDLER $FINAL_HANDLER
@@ -22,6 +23,7 @@ use CGI::Ex;
use CGI::Ex::Dump qw(debug ctrace dex_html);
BEGIN {
+ $VERSION = '2.38';
$SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
$IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
$EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
@@ -184,6 +186,6 @@ This module may distributed under the same terms as Perl itself.
=head1 AUTHORS
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,7 +7,7 @@ CGI::Ex::Dump - A debug utility
=cut
###----------------------------------------------------------------###
-# Copyright 2004-2014 - Paul Seamons #
+# Copyright 2004-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
@@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
use strict;
use Exporter;
-$VERSION = '2.42';
+$VERSION = '2.38';
@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 caller_trace);
@@ -248,6 +248,6 @@ This module may distributed under the same terms as Perl itself.
=head1 AUTHORS
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,7 +7,7 @@ CGI::Ex::Fill - Fast but compliant regex based form filler
=cut
###----------------------------------------------------------------###
-# Copyright 2003-2014 - Paul Seamons #
+# Copyright 2003-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
@@ -24,7 +24,7 @@ use vars qw($VERSION
use base qw(Exporter);
BEGIN {
- $VERSION = '2.42';
+ $VERSION = '2.38';
@EXPORT = qw(form_fill);
@EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
};
@@ -838,6 +838,6 @@ This module may distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -7,17 +7,21 @@ CGI::Ex::JSONDump - Comprehensive data to JSON dump.
=cut
###----------------------------------------------------------------###
-# Copyright 2006-2014 - Paul Seamons #
+# Copyright 2006-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-use vars qw(@EXPORT @EXPORT_OK);
+use vars qw($VERSION
+ @EXPORT @EXPORT_OK);
use strict;
use base qw(Exporter);
BEGIN {
+ $VERSION = '2.38';
+
@EXPORT = qw(JSONDump);
@EXPORT_OK = @EXPORT;
+
};
sub JSONDump {
@@ -389,6 +393,6 @@ This module may distributed under the same terms as Perl itself.
=head1 AUTHORS
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -8,9 +8,10 @@ CGI::Ex::Template - Template::Alloy based TT2/TT3/HT/HTE/Tmpl/Velocity engine.
use strict;
use warnings;
-use Template::Alloy 1.016;
+use Template::Alloy 1.004;
use base qw(Template::Alloy);
-use vars qw($QR_PRIVATE
+use vars qw($VERSION
+ $QR_PRIVATE
$WHILE_MAX
$MAX_EVAL_RECURSE
$MAX_MACRO_RECURSE
@@ -24,6 +25,8 @@ use vars qw($QR_PRIVATE
$VOBJS
);
+$VERSION = '2.38';
+
### install true symbol table aliases that can be localized
*QR_PRIVATE = *Template::Alloy::QR_PRIVATE;
*WHILE_MAX = *Template::Alloy::WHILE_MAX;
@@ -151,6 +154,6 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -2,21 +2,22 @@ package CGI::Ex::Validate;
###---------------------###
# See the perldoc in CGI/Ex/Validate.pod
-# Copyright 2003-2014 - Paul Seamons
+# Copyright 2003-2012 - Paul Seamons
# Distributed under the Perl Artistic License without warranty
use strict;
use Carp qw(croak);
-our $VERSION = '2.42';
+our $VERSION = '2.38';
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;
- return bless ref($_[0]) ? shift : {@_}, $class;
+ my $class = shift || croak "Usage: ".__PACKAGE__."->new";
+ my $self = ref($_[0]) ? shift : {@_};
+ return bless $self, $class;
}
sub cgix { shift->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } }
@@ -52,50 +53,32 @@ sub validate {
next;
}
$found = 1;
- my $key = $ref->{'field'} || die "Missing field key during normal validation";
-
- # allow for field names that contain regular expressions
- my @keys;
- if ($key =~ 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 $key" if $opt =~ /e/;
- foreach my $_key (sort keys %$form) {
- next if ($not && $_key =~ m/(?$opt:$pat)/) || (! $not && $_key !~ m/(?$opt:$pat)/);
- push @keys, [$_key, [undef, $1, $2, $3, $4, $5]];
- }
+ my $field = $ref->{'field'} || die "Missing field key during normal validation";
+ if (! $checked{$field}++) {
+ $self->{'was_checked'}->{$field} = 1;
+ $self->{'was_valid'}->{$field} = 1;
+ $self->{'had_error'}->{$field} = 0;
+ }
+ local $ref->{'was_validated'} = 1;
+ my $err = $self->validate_buddy($form, $field, $ref);
+ if ($ref->{'was_validated'} && $what_was_validated) {
+ push @$what_was_validated, $ref;
} else {
- @keys = ([$key]);
+ $self->{'was_valid'}->{$field} = 0;
}
- foreach my $r (@keys) {
- my ($field, $ifs_match) = @$r;
- if (! $checked{$field}++) {
- $self->{'was_checked'}->{$field} = 1;
- $self->{'was_valid'}->{$field} = 1;
- $self->{'had_error'}->{$field} = 0;
- }
- local $ref->{'was_validated'} = 1;
- my $err = $self->validate_buddy($form, $field, $ref, $ifs_match);
- if ($ref->{'was_validated'}) {
- push @$what_was_validated, $ref if $what_was_validated;
- } else {
- $self->{'was_valid'}->{$field} = 0;
- }
-
- # 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;
- if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
- $hold_error = $err;
- } else {
- push @errors, $hold_error ? @$hold_error : @$err;
- $hold_error = undef;
- }
+ # 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;
+ if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
+ $hold_error = $err;
} else {
+ push @errors, $hold_error ? @$hold_error : @$err;
$hold_error = undef;
}
+ } else {
+ $hold_error = undef;
}
}
push(@errors, @$hold_error) if $hold_error; # allow for final OR to work
@@ -196,7 +179,7 @@ sub check_conditional {
my $ref = $ifs->[$i];
if (! ref $ref) {
if ($ref eq 'OR') {
- $i++ if $found; # if found skip the OR altogether
+ $i ++ if $found; # if found skip the OR altogether
$found = 1; # reset
next;
} else {
@@ -218,7 +201,6 @@ sub check_conditional {
$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;
@@ -244,7 +226,8 @@ sub validate_buddy {
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 $errs = $self->validate_buddy($form, $_field, $field_val, [undef, $1, $2, $3, $4, $5]);
+ 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;
@@ -254,7 +237,6 @@ sub validate_buddy {
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 (defined($field_val->{'default'})
&& (!defined($form->{$field})
@@ -424,13 +406,10 @@ sub validate_buddy {
if ($field2 =~ m/^([\"\'])(.*)\1$/) {
my $test = $2;
$success = (defined($value) && $value eq $test);
- } else {
- $field2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
- if (exists($form->{$field2}) && defined($form->{$field2})) {
- $success = (defined($value) && $value eq $form->{$field2});
- } elsif (! defined($value)) {
- $success = 1; # occurs if they are both undefined
- }
+ } 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'};
@@ -325,9 +325,6 @@ not specified, the key from the top level hash will be used.
real_key_name2 => {
required => 1,
},
- 'm/\w+/' => { # this will apply to all fields matching this regex
- required => 1,
- },
Each of the individual field validation hashrefs should contain the
types listed in VALIDATION TYPES.
@@ -661,14 +658,7 @@ if the conditions are met. Works in JS.
field => 'm/^(\w+)_pass/',
validate_if => '$1_user',
required => 1,
- },
- {
- field => 'm/^(\w+)_pass2/',
- validate_if => '$1_pass',
- equals => '$1_pass',
- 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
@@ -1229,6 +1219,6 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <paul at seamons dot com>
=cut
@@ -1,4 +1,4 @@
-// Copyright 2003-2014 - Paul Seamons - ver 2.37
+// Copyright 2003-2012 - Paul Seamons - ver 2.37
// Distributed under the Perl Artistic License without warranty
// See perldoc CGI::Ex::Validate for usage
@@ -123,14 +123,9 @@ function v_clean_field_val (field_val, N_level) {
} else if (k.match(/^custom_js_?\d*$/)) {
if (typeof(v) == 'string' && v.match(/^\s*function\s*\(/)) eval("field_val[k] = "+v);
} else if (k.match(/^(validate|required)_if_?\d*$/)) {
- if (typeof(v) == 'string' || ! v.length) v = field_val[k] = [v];
- var deps = v_clean_cond(v, N_level);
- for (var k in deps) field_val.deps[k] = 2;
- } else if (k.match(/^equals_?\d*$/)) {
- if (!/^[\"\']/.test(field_val[k])) {
- var deps = v_clean_cond([field_val[k].replace(/^!\s*/,'')], N_level);
- for (var k in deps) field_val.deps[k] = 3;
- }
+ if (typeof(v) == 'string' || ! v.length) v = field_val[k] = [v];
+ var deps = v_clean_cond(v, N_level);
+ for (var k in deps) field_val.deps[k] = 2;
}
}
}
@@ -173,7 +168,7 @@ function v_validate (form, val_hash) {
var is_found = 1;
var errors = [];
- var hold_err;
+ var hold_error;
var chk = {};
for (var j = 0; j < fields.length; j++) {
@@ -184,31 +179,26 @@ function v_validate (form, val_hash) {
continue;
}
is_found = 1;
- var names = v_field_names(form, ref.field);
- if (!names) names = [[ref.field, null]];
- for (var i = 0; i < names.length; i++) {
- var f = names[i][0];
- var ifs_match = names[i][1];
- if (! chk[f]) {
- chk[f] = 1;
- val_hash['group was_checked'][f] = 1;
- val_hash['group was_valid'][f] = 1;
- val_hash['group had_error'][f] = 0;
- }
- var err = v_validate_buddy(form, f, ref, val_hash, ifs_match);
- if (err.length) {
- val_hash['group had_error'][f] = 1;
- val_hash['group was_valid'][f] = 0;
- if (j <= fields.length && typeof(fields[j + 1] != 'object') && fields[j + 1] == 'OR') {
- hold_err = err;
- } else {
- if (hold_err) err = hold_err;
- for (var k = 0; k < err.length; k++) errors.push(err[k]);
- hold_err = '';
- }
+ var f = ref.field;
+ if (! chk[f]) {
+ chk[f] = 1;
+ val_hash['group was_checked'][f] = 1;
+ val_hash['group was_valid'][f] = 1;
+ val_hash['group had_error'][f] = 0;
+ }
+ var err = v_validate_buddy(form, f, ref, val_hash);
+ if (err.length) {
+ val_hash['group had_error'][f] = 1;
+ val_hash['group was_valid'][f] = 0;
+ if (j <= fields.length && typeof(fields[j + 1] != 'object') && fields[j + 1] == 'OR') {
+ hold_error = err;
} else {
- hold_err = '';
+ if (hold_error) err = hold_error;
+ for (var k = 0; k < err.length; k++) errors.push(err[k]);
+ hold_error = '';
}
+ } else {
+ hold_error = '';
}
}
@@ -274,35 +264,27 @@ function v_field_order (field_val) {
return o.sort();
}
-function v_field_names (form, field) {
- var m = field.match(/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/);
- if (!m) return;
- var fields = [];
- var not = m[1];
- var pat = m[3];
- var opt = m[4];
- if (opt.indexOf('e') != -1) { v_error("The e option cannot be used on field "+field); return [] }
- opt = opt.replace(/[sg]/g,'');
- var reg = new RegExp(pat, opt);
-
- for (var i = 0; i < form.elements.length; i++) {
- var _field = form.elements[i].name;
- if (_field && (not && ! (m = _field.match(reg))) || (m = _field.match(reg))) fields.push([_field, m]);
- }
- return fields;
-}
-
function v_validate_buddy (form, field, field_val, val_hash, ifs_match) {
var errors = [];
if (! form.elements || field_val.exclude_js) return [];
var types = field_val.order || v_field_order(field_val);
- var m;
- var names = v_field_names(form, field);
- if (names) {
- for (var i = 0; i < names.length; i++) {
- var err = v_validate_buddy(form, names[i][0], field_val, val_hash, names[i][1]);
- for (var j = 0; j < err.length; j++) errors.push(err[j]);
+ var m;
+ if (m = field.match(/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/)) {
+ var not = m[1];
+ var pat = m[3];
+ var opt = m[4];
+ if (opt.indexOf('e') != -1) { v_error("The e option cannot be used on field "+field); return [] }
+ opt = opt.replace(/[sg]/g,'');
+ var reg = new RegExp(pat, opt);
+
+ for (var i = 0; i < form.elements.length; i++) {
+ var _field = form.elements[i].name;
+ if (! _field) continue;
+ if ( (not && ! (m = _field.match(reg))) || (m = _field.match(reg))) {
+ var err = v_validate_buddy(form, _field, field_val, val_hash, m);
+ for (var j = 0; j < err.length; j++) errors.push(err[j]);
+ }
}
return errors;
}
@@ -318,7 +300,7 @@ function v_validate_buddy (form, field, field_val, val_hash, ifs_match) {
&& (typeof(_value) == 'undefined'
|| (typeof(_value) == 'object' && _value.length == 0)
|| ! _value.length)) {
- _value = ''+field_val['default'];
+ _value = field_val['default'];
modified = 1;
}
@@ -455,10 +437,7 @@ function v_validate_buddy (form, field, field_val, val_hash, ifs_match) {
if (m = _fv.match(/^([\"\'])(.*)\1$/)) {
if (value == m[2]) success = 1;
} else {
- var _fv2 = _fv.replace(/\$(\d+)/g, function (all, N) {
- return (typeof(ifs_match) != 'object' || typeof(ifs_match[N]) == 'undefined') ? '' : ifs_match[N];
- });
- var value2 = v_get_form_value(form[_fv2]);
+ var value2 = v_get_form_value(form[_fv]);
if (typeof(value2) == 'undefined') value2 = '';
if (value == value2) success = 1;
}
@@ -618,6 +597,7 @@ function v_set_form_value (el, values, form) {
return;
}
if (! type) return;
+ if (type.match(/(hidden|password|text|textarea|submit)/)) return el.value = values[0];
if (type.indexOf('select') != -1) {
if (el.length) for (var i = 0; i < el.length; i++) el[i].selected = (el[i].value == values[0]) ? true : false;
return;
@@ -627,7 +607,9 @@ function v_set_form_value (el, values, form) {
return el.checked = f ? true : false;
}
if (type == 'file') return;
- return el.value = values[0];
+
+ alert('Unknown form type for '+el.name+': '+type);
+ return;
}
function v_set_disable (el, disable) {
@@ -656,13 +638,17 @@ function v_get_form_value (el, form) {
return a;
}
if (! type) return '';
+ if (type.match(/(hidden|password|text|textarea|submit)/)) return el.value;
if (type.indexOf('select') != -1) {
if (! el.length) return '';
if (el.selectedIndex == -1) return '';
return el[el.selectedIndex].value;
}
if (type == 'checkbox' || type == 'radio') return el.checked ? el.value : '';
- return el.value;
+ if (type == 'file') return el.value;
+
+ alert('Unknown form type for '+el.name+': '+type);
+ return '';
}
function v_find_val () {
@@ -979,20 +965,8 @@ document.check_form = function (form, val_hash) {
var h = {};
_add = function (k, v) { if (! h[k]) h[k] = []; h[k].push(v) };
for (var i = 0; i < clean.fields.length; i++) {
- var k = clean.fields[i].field;
- var names = v_field_names(form,k);
- if (!names) names = [[k,null]];
- for (var ii = 0; ii < names.length; ii++) {
- var k = names[ii][0];
- var ifs_match = names[ii][1];
- _add(k, [clean.fields[i],k,ifs_match]);
- for (var j in clean.fields[i].deps) {
- if (ifs_match) j = j.replace(/\$(\d+)/g, function (all, N) {
- return (typeof(ifs_match) != 'object' || typeof(ifs_match[N]) == 'undefined') ? '' : ifs_match[N];
- });
- if (j != k) _add(j, [clean.fields[i],k,ifs_match]);
- }
- }
+ _add(clean.fields[i].field, clean.fields[i]);
+ for (var j in clean.fields[i].deps) if (j != clean.fields[i].field) _add(j, clean.fields[i]);
}
for (var k in h) {
if (!h.hasOwnProperty(k)) continue;
@@ -1000,7 +974,7 @@ document.check_form = function (form, val_hash) {
if (! el) return v_error("No form element by the name "+k);
var _change = !types.change ? 0 : typeof(types.change) == 'object' ? types.change[k] : 1;
var _blur = !types.blur ? 0 : typeof(types.blur) == 'object' ? types.blur[k] : 1;
- v_el_attach(el, h[k], form, val_hash, _change, _blur, ifs_match);
+ v_el_attach(el, h[k], form, val_hash, _change, _blur);
}
}
@@ -1012,7 +986,7 @@ document.check_form = function (form, val_hash) {
if (types.load) { v_event = 'load'; document.validate(form) }
}
-function v_el_attach (el, fvs, form, val_hash, _change, _blur, ifs_match) {
+function v_el_attach (el, fvs, form, val_hash, _change, _blur) {
if (!_change && !_blur) return;
if (! el.type) {
if (el.length) for (var i = 0; i < el.length; i++) v_el_attach(el[i], fvs, form, val_hash, _change, _blur);
@@ -1025,28 +999,21 @@ function v_el_attach (el, fvs, form, val_hash, _change, _blur, ifs_match) {
var f = {};
var chk = {};
for (var i = 0; i < fvs.length; i++) {
- var field_val = fvs[i][0];
- var k = fvs[i][1];
- var ifs_match = fvs[i][2];
+ var field_val = fvs[i];
+ var k = field_val.field;
if (! chk[k]) {
chk[k] = 1;
val_hash['group was_checked'][k] = 1;
val_hash['group was_valid'][k] = 1;
val_hash['group had_error'][k] = 0;
}
- var _e = v_validate_buddy(form, k, field_val, val_hash, ifs_match);
+ var _e = v_validate_buddy(form, k, field_val, val_hash);
if (_e.length) {
val_hash['group had_error'][k] = 1;
val_hash['group was_valid'][k] = 0;
for (var j = 0; j < _e.length; j++) e.push(_e[j]);
}
- if (field_val.delegate_error) {
- k = field_val.delegate_error;
- if (ifs_match) k = k.replace(/\$(\d+)/g, function (all, N) {
- return (typeof(ifs_match) != 'object' || typeof(ifs_match[N]) == 'undefined') ? '' : ifs_match[N];
- });
- }
- f[k] = _e.length ? 0 : 1;
+ f[field_val.delegate_error || field_val.field] = _e.length ? 0 : 1;
}
for (var k in f) if (f[k]) v_inline_error_clear(k, val_hash, form);
if (! e.length) return;
@@ -7,7 +7,7 @@ CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
=cut
###----------------------------------------------------------------###
-# Copyright 2003-2014 - Paul Seamons #
+# Copyright 2003-2012 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
@@ -24,7 +24,7 @@ use vars qw($VERSION
use base qw(Exporter);
BEGIN {
- $VERSION = '2.42';
+ $VERSION = '2.38';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
@@ -294,20 +294,12 @@ sub content_typed {
sub location_bounce {
my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
$self = __PACKAGE__->new if ! $self;
- $loc =~ s{(\s)}{sprintf("%%%02X", ord $1)}xge if $loc;
- my $html_loc = $loc;
- if ($html_loc) {
- $html_loc =~ s/&/&/g;
- $html_loc =~ s/</</g;
- $html_loc =~ s/>/>/g;
- $html_loc =~ s/\"/"/g;
- }
if ($self->content_typed) {
if ($DEBUG_LOCATION_BOUNCE) {
- print "<a class=debug href=\"$html_loc\">Location: $html_loc</a><br />\n";
+ print "<a class=debug href=\"$loc\">Location: $loc</a><br />\n";
} else {
- print "<meta http-equiv=\"refresh\" content=\"0;url=$html_loc\" />\n";
+ print "<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n";
}
} elsif (my $r = $self->apache_request) {
@@ -316,7 +308,7 @@ sub location_bounce {
$r->header_out("Location", $loc);
$r->content_type('text/html');
$r->send_http_header;
- $r->print("Bounced to $html_loc\n");
+ $r->print("Bounced to $loc\n");
} else {
$r->headers_out->add("Location", $loc);
$r->content_type('text/html');
@@ -327,7 +319,7 @@ sub location_bounce {
print "Location: $loc\r\n",
"Status: 302 Bounce\r\n",
"Content-Type: text/html\r\n\r\n",
- "Bounced to $html_loc\r\n";
+ "Bounced to $loc\r\n";
}
}
@@ -1065,6 +1057,6 @@ This module may be distributed under the same terms as Perl itself.
=head1 AUTHOR
-Paul Seamons <paul@seamons.com>
+Paul Seamons <perl at seamons dot com>
=cut
@@ -28,6 +28,7 @@ Test Form
</div>
<div id="output"></div>
</body>
+</html>
<script>
var ok_i = 0;
var nok = 0;
@@ -468,36 +469,6 @@ function run_tests () {
ok(! e, "No error - just replaced");
ok(document.the_form.textarea1.value == "W0W", "Got right value ("+document.the_form.textarea1.value+")");
- // match field names
- e = validate({text1: " hey "}, {'m/^text1$/':{required:1}});
- ok(! e, "complexname - no error");
-
- e = validate({text1: ""}, {'m/^text1$/':{required:1}});
- ok(e, "complexname - had error");
-
- e = validate({text1: ""}, {'m/^(tex)t1$/':{required:1, validate_if:'$1t2'}});
- ok(!e, "validate_ifstr - no error");
-
- e = validate({text1: "", text2: 1}, {'m/^(tex)t1$/':{required:1, validate_if:'$1t2'}});
- ok(e, "validate_ifstr - had error");
-
- e = validate({text1: ""}, {'m/^(tex)t1$/':{required:1, validate_if:{field:'$1t2',required:1}}});
- ok(!e, "validate_if - no error");
-
- e = validate({text1: "", text2: 1}, {'m/^(tex)t1$/':{required:1, validate_if:{field:'$1t2',required:1}}});
- ok(e, "validate_if - had error");
-
- e = validate({text1: ""}, {'m/^(tex)t1$/':{required:1, validate_if:'$1t2 was_valid'}});
- ok(!e, "was valid - no error");
-
- e = validate({text1: "", text2: 1}, {'m/^(tex)t1$/':{required:1, validate_if:'$1t2 was_valid'}, text2:{required:1}, 'group order':['text2']});
- ok(e, "was valid - had error");
-
- e = validate({text1: "foo", text2: "bar"}, {'m/^(tex)t1$/':{equals:'$1t2'}});
- ok(e, "equals - had error");
-
- e = validate({text1: "foo", text2: "foo"}, {'m/^(tex)t1$/':{equals:'$1t2'}});
- ok(!e, "equals - no error");
//alert(_form_value(form.text2));
//form.text2[0].value = "text1";
@@ -516,4 +487,3 @@ function run_tests () {
window.onload = run_tests;
</script>
-</html>
@@ -105,17 +105,6 @@ if (! document.validate) {
<td id=foo_img></td>
<td id=foo_error class=error></td>
</tr>
-<tr><td colspan=2><hr></td></tr>
-<tr id=cplx_row>
- <td valign=top>Complete:</td>
- <td>
- <input type=text name=cplx value="" size=8>
- <input type=text name=cplx_a value="" size=8>
- <input type=text name=cplx_b value="" size=8>
- </td>
- <td id=cplx_img></td>
- <td id=cplx_error class=error></td>
-</tr>
<tr>
<td colspan=2 align=right>
<input type=submit value=Submit>
@@ -127,12 +116,10 @@ if (! document.validate) {
<script src="../lib/CGI/Ex/validate.js"></script>
<script>
document.validate_set_hook = function (args) {
- if (!document.getElementById(args.key+'_img')) alert('cannot set '+args.key);
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 (!document.getElementById(args.key+'_img')) alert('cannot clear '+args.key);
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';
@@ -243,24 +230,6 @@ document.validation = {
foo: {
min_in_set: "2 of foo bar baz",
max_in_set: "2 of foo bar baz"
- },
- 'm/^(c\\w+x)$/': {
- required:1,
- name: 'Field one'
- },
- 'm/^(c\\w+x)_a$/': {
- validate_if: '$1',
- equals: '$1',
- equals_name: 'field one',
- delegate_error: '$1',
- name: 'Field two'
- },
- 'm/^(c\\w+x)_b$/': {
- validate_if: '$1_a was_valid',
- equals: '$1_a',
- equals_name: 'field two',
- delegate_error: '$1',
- name: 'Field three'
}
};
if (document.check_form) document.check_form('a');
@@ -7,7 +7,7 @@
=cut
use strict;
-use Test::More tests => 190;
+use Test::More tests => 181;
use_ok('CGI::Ex::Validate');
@@ -52,26 +52,6 @@ ok(! $e, "No error on validate_if with had_error and bad_data");
$e = validate({text1 => 1}, $v);
ok($e && ! $e->as_hash->{text1_error}, "No error on validate_if with had_error and good data");
-$e = validate({text1 => ""}, {'m/^(tex)t1$/' => {required => 1, validate_if => '$1t2'}});
-ok(!$e, "validate_ifstr - no error");
-
-$e = validate({text1 => "", text2 => 1}, {'m/^(tex)t1$/' => {required => 1, validate_if => '$1t2'}});
-ok($e, "validate_ifstr - had error");
-
-$e = validate({text1 => ""}, {'m/^(tex)t1$/' => {required => 1, validate_if => {field => '$1t2',required => 1}}});
-ok(!$e, "validate_if - no error");
-
-$e = validate({text1 => "", text2 => 1}, {'m/^(tex)t1$/' => {required => 1, validate_if => {field => '$1t2',required => 1}}});
-ok($e, "validate_if - had error");
-
-$e = validate({text1 => ""}, {'m/^(tex)t1$/' => {required => 1, validate_if => '$1t2 was_valid'}});
-ok(!$e, "was valid - no error");
-
-$e = validate({text1 => "", text2 => 1}, {'m/^(tex)t1$/' => {required => 1, validate_if => '$1t2 was_valid'}});
-ok(!$e, "was valid - no error");
-
-$e = validate({text1 => "", text2 => 1}, {'m/^(tex)t1$/' => {required => 1, validate_if => '$1t2 was_valid'}, text2 => {required => 1}, 'group order' => [qw(text2)]});
-ok($e, "was valid - had error");
### required_if
$v = {foo => {required_if => 'bar'}};
@@ -163,13 +143,6 @@ ok($e, 'equals');
$e = validate({foo => 'bar', bar => 1}, $v);
ok(! $e, 'equals');
-$e = validate({text1 => "foo", text2 => "bar"}, {'m/^(tex)t1$/' => {equals => '$1t2'}});
-ok($e, "equals - had error");
-
-$e = validate({text1 => "foo", text2 => "foo"}, {'m/^(tex)t1$/' => {equals => '$1t2'}});
-ok(!$e, "equals - no error");
-
-
### min_len
$v = {foo => {min_len => 10}};
$e = validate({}, $v);
@@ -236,10 +236,10 @@ is($Foo::test_stdout, 'Step 5 Nested (step5__part_a)', "Got the right output for
sub main_info_complete { 1 }
}
eval { Foo3->navigate };
-like($Foo::test_stdout, qr/recurse_limit \(15\)/, "Got the right output for Foo3");
+ok($Foo::test_stdout =~ /recurse_limit \(15\)/, "Got the right output for Foo3");
eval { Foo3->new({recurse_limit => 10})->navigate };
-like($Foo::test_stdout, qr/recurse_limit \(10\)/, "Got the right output for Foo3");
+ok($Foo::test_stdout =~ /recurse_limit \(10\)/, "Got the right output for Foo3");
###----------------------------------------------------------------###
@@ -643,7 +643,7 @@ ok($dh->dump_history('all'), "Can call dump_history");
sub hash_fill {}
sub hash_swap {}
sub hash_errors {}
- sub find_hook { my ($self, $hook, $step) = @_; return $self->SUPER::find_hook($hook, $step) if $step eq 'main'; return ("non_code",1) }
+ sub find_hook { my ($self, $hook, $step) = @_; return $self->SUPER::find_hook($hook, $step) if $step eq 'main'; return ["non_code",1] }
}
Foo7->new({no_history => 1})->navigate;
ok($Foo::test_stdout eq "Main Content", "Got the right output for Foo7 ($Foo::test_stdout)");
@@ -1033,19 +1033,19 @@ print "### Integrated validation tests ###\n";
}
local $ENV{'SCRIPT_NAME'} = '/cgi/ralph.pl';
-is(Foo11->new->file_print("george"), 'ralph/george.html', 'file_print: '. Foo11->new->file_print("george"));
-like(Foo11->new->file_val("george"), qr|\Q/ralph/george.val\E|, 'file_val: '. Foo11->new->file_val("george"));
-is(ref(Foo12->new->file_val("george")), 'HASH', 'file_val: no such path');
-is(Foo11->new(val_path => '../' )->file_val("george"), '../ralph/george.val', 'file_val');
-is(Foo11->new(val_path => sub {'../'} )->file_val("george"), '../ralph/george.val', 'file_val');
-is(Foo11->new(val_path => ['../'] )->file_val("george"), '../ralph/george.val', 'file_val');
-is(Foo11->new(val_path => ['../', './'])->file_val("george"), '../ralph/george.val', 'file_val');
+ok(Foo11->new->file_print("george") eq 'ralph/george.html', 'file_print: '. Foo11->new->file_print("george"));
+ok(Foo11->new->file_val("george") =~ m|\Q/ralph/george.val\E|, 'file_val: '. Foo11->new->file_val("george"));
+ok(ref(Foo12->new->file_val("george")) eq 'HASH', 'file_val: no such path');
+ok(Foo11->new(val_path => '../' )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => sub {'../'} )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => ['../'] )->file_val("george") eq '../ralph/george.val', 'file_val');
+ok(Foo11->new(val_path => ['../', './'])->file_val("george") eq '../ralph/george.val', 'file_val');
ok(! eval { Foo11->new->file_print("step2") } && $@, 'Bad name_step');
ok(! eval { Foo11->new->file_val("step2") } && $@, 'Bad name_step');
-is(Foo11->new->file_print("step3"), 'ralph/foo.htm', 'file_print: '. Foo11->new->file_print("step3"));
-like(Foo11->new->file_val("step3"), qr|\Q/ralph/foo.val\E|, 'file_val: '. Foo11->new->file_val("step3"));
+ok(Foo11->new->file_print("step3") eq 'ralph/foo.htm', 'file_print: '. Foo11->new->file_print("step3"));
+ok(Foo11->new->file_val("step3") =~ m|\Q/ralph/foo.val\E|, 'file_val: '. Foo11->new->file_val("step3"));
local $ENV{'REQUEST_METHOD'} = 'POST';