%define name CGI-Ex
-%define version 1.14
+%define version 2.00
%define __find_provides %( echo -n /usr/lib/rpm/find-provides && [ -x /usr/lib/rpm/find-provides.perl ] && echo .perl )
%define __find_requires %( echo -n /usr/lib/rpm/find-requires && [ -x /usr/lib/rpm/find-requires.perl ] && echo .perl )
Provides: %{name} = %{version}
%description
-CGI::Ex is a Perl module that offers an extended suite of
-functionality, over and above that offered by CGI, HTML::FillInForm,
-and the host of Validator scripts on CPAN. CGI::Ex tries to use the
-best functions from existing modules and extend them with rich
-functionality. Particularly of interest is CGI::Ex::App which
-provides extremely easy yet robust CGI developement.
+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 prebuilt 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 L<CGI::Ex::App>.
+
+The main functionality is provided by several other modules that
+may be used separately, or together through the CGI::Ex interface.
%prep
%setup -q -n %{name}-%{version}
-2005-02-28 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.14 is done
+2.00
+ * Added CGI::Ex::Template and test suites
+ * Allow for CGI::Ex::Template to be fully TT2 syntax compliant
+ * Re-implementation of CGI::Ex::Auth
+ * Allow for step to be automatically untainted during loop in CGI::Ex::App
+ * Fix base_dir_rel to work with "" as the dir in CGI::Ex::App
+ * Bug fixes in CGI::Ex::Fill
+ * Better perldoc in CGI::Ex::Fill
+ * Add named parameter function called fill in CGI::Ex::Fill
+ * DProfd CGI::Ex::Conf for improvements
+ * DProfd CGI::Ex::Validate for improvements
+ * Added conf_read and conf_write methods for Conf
+ * Cleanup of all of the test
+ * Add missing tests
+ * Add Array Prototype fixes from Eamon Daly
+ * Add examples and cleanup to CGI::Ex::App
+ * Cleanup hooks in App (add fill_args and template_args)
+ * Change run_hook syntax in App
+ * Add dump_history with more history information
+ * Integrate CGI::Ex::Auth with App
+
+1.14 2005-02-28
* Bug fix in validate (OR's were not working)
* Allow for checking for package existence without require in App
* Add hash_swap
* Allow for untaint in CGI::Ex::Validate
* Allow for !field in equals of CGI::Ex::Validate
* Allow for return of names in CGI::Ex::Validate
- * All CGI::Ex to work better with CGI/mod_perl1/mod_perl2
+ * Allow CGI::Ex to work better with CGI/mod_perl1/mod_perl2
* Fix required => 0 in javascript
-2004-12-02 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.13 is done
+1.13 2004-12-02
* Show more App perldoc examples
* Fix some App path bugs
* Add more app hooks
* Cleanup app code
* Allow for Conf to write to each of the types
-2004-11-010 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.12 is done
+1.12 2004-11-10
* Show more App perldoc examples
* Fix some App path bugs
* Change some App method names
* Allow for App js_validation
* Allow for App validation redirection
-2004-11-08 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.11 is done
+1.11 2004-11-08
* Let file path dependent tests succeed
* Allow for next current and previous steps in App
* Couple of warn cleans in App
-2004-11-05 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.10 is done
+1.10 2004-11-05
* Make CGI::Ex::App->print really work with Template
* Fix very large javascript variable swapping bug
* Numerous upgrades to App
* Allow validate to populate what_was_validated array
* Allow for App to cleanup crossed references
-2004-04-23 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 1.00 is done
+1.00 2004-04-23
* Added set_path method
* Added Auth module
* Fix validate.js for select-multiple
* Add min_in_set and max_in_set types for validate
* Add default for validate (sets default value)
-2004-03-22 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 0.99 is done
+0.99 2004-03-22
* Allow swap_template to be called with one argument
* Added extended examples in t/samples/cgi_ex_*
* Remove dependency on CGI::Util (doesn't exists on some perls)
* Added set_form
* Updated tests
-2004-03-19 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 0.98 is done
+0.98 2004-03-19
* Multiple fixes in Fill module
* Updates on perldocs (thanks to Simon Bellwood for bug reports)
* Addition of Dump (debug) module
* Addition of Die module
* Addition of App module
-2004-03-05 Paul Seamons <cgi_ex@seamons.com>
-
+0.97 2004-03-05
* Allow for custom_js type
* Fix unshift, shift, and push in ie 5.0
* Fix type CC in validate.js
* Allow for duplicate field definitions
-2003-11-26 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 0.96 is done
+0.96 2003-11-26
* Fix for pos not resetting in CGI::Ex::Fill
* Fix for general items set in self not being passed to generate_js
* Workaround for yaml_load.js |- not properly trimming whitespace
-2003-11-26 Paul Seamons <cgi_ex@seamons.com>
-
- * Version 0.94 is done
+0.94 2003-11-26
* Javascript functionality is in.
-2003-11-01 Paul Seamons <cgi_ex@seamons.com>
-
+0.0 2003-11-01
* Version 0.0 checked in
Changes
lib/CGI/Ex.pm
lib/CGI/Ex/App.pm
+lib/CGI/Ex/App.pod
lib/CGI/Ex/Auth.pm
lib/CGI/Ex/Conf.pm
lib/CGI/Ex/Die.pm
lib/CGI/Ex/md5.js
lib/CGI/Ex/sha1.js
lib/CGI/Ex/Template.pm
+lib/CGI/Ex/Template.pod
lib/CGI/Ex/validate.js
lib/CGI/Ex/Validate.pm
+lib/CGI/Ex/Var.pm
lib/CGI/Ex/yaml_load.js
Makefile.PL
-MANIFEST This list of files
+MANIFEST
MANIFEST.SKIP
-META.yml Module meta-data (added by MakeMaker)
+META.yml
README
+samples/benchmark/bench_auth.pl
+samples/benchmark/bench_cgix_hfif.pl
+samples/benchmark/bench_conf_readers.pl
+samples/benchmark/bench_conf_writers.pl
+samples/benchmark/bench_method_calling.pl
+samples/benchmark/bench_optree.pl
+samples/benchmark/bench_template.pl
+samples/benchmark/bench_template_tag_parser.pl
+samples/benchmark/bench_validation.pl
+samples/benchmark/bench_various_templaters.pl
+samples/cgi_ex_1.cgi
+samples/cgi_ex_2.cgi
+samples/conf_path_1/apples.pl
+samples/conf_path_1/oranges.pl
+samples/conf_path_3/apples.pl
+samples/conf_path_3/oranges.pl
+samples/devel/dprof_conf.d
+samples/devel/dprof_template.d
+samples/devel/dprof_validation.d
+samples/generate_js.pl
+samples/html1.htm
+samples/html2.htm
+samples/js_validate_1.html
+samples/js_validate_2.html
+samples/js_validate_3.html
+samples/memory_template.pl
+samples/perl1.pl
+samples/perl2.pl
+samples/yaml1.val
+samples/yaml2.val
+samples/yaml3.val
+samples/yaml_js_1.html
+samples/yaml_js_2.html
+samples/yaml_js_3.html
+samples/yaml_js_4.html
t/0_ex_00_base.t
-t/0_ex_01_swap.t
t/1_validate_00_base.t
-t/1_validate_01_form.t
-t/1_validate_02_form_fail.t
t/1_validate_03_cgi.t
-t/1_validate_04_cgi_fail.t
t/1_validate_05_types.t
t/1_validate_06_groups.t
t/1_validate_07_yaml.t
t/1_validate_08_yaml_file.t
-t/1_validate_09_perl_file.t
-t/1_validate_10_storable_file.t
t/1_validate_11_no_extra.t
t/1_validate_12_change.t
-t/1_validate_13_html_file.t
t/1_validate_14_untaint.t
t/2_fill_00_base.t
t/2_fill_01_form.t
t/2_fill_12_mult.t
t/2_fill_13_warning.t
t/2_fill_14_password.t
-t/2_fill_15_multiple_fields.t
t/2_fill_16_ignore_fields.t
t/2_fill_17_xhtml.t
t/2_fill_18_coderef.t
t/4_app_00_base.t
t/5_dump_00_base.t
t/6_die_00_base.t
-t/samples/bench_cgix_hfif.pl
-t/samples/bench_conf_readers.pl
-t/samples/bench_conf_writers.pl
-t/samples/bench_method_calling.pl
-t/samples/cgi_ex_1.cgi
-t/samples/cgi_ex_2.cgi
-t/samples/conf_path_1/apples.pl
-t/samples/conf_path_1/oranges.pl
-t/samples/conf_path_3/apples.pl
-t/samples/conf_path_3/oranges.pl
-t/samples/generate_js.pl
-t/samples/html1.htm
-t/samples/html2.htm
-t/samples/js_validate_1.html
-t/samples/js_validate_2.html
-t/samples/js_validate_3.html
-t/samples/perl1.pl
-t/samples/perl2.pl
-t/samples/storable1.storable
-t/samples/yaml1.val
-t/samples/yaml2.val
-t/samples/yaml3.val
-t/samples/yaml_js_1.html
-t/samples/yaml_js_2.html
-t/samples/yaml_js_3.html
-t/samples/yaml_js_4.html
+t/7_template_00_base.t
+t/7_template_01_includes.t
+t/8_auth_00_base.t
\.gz$
.cvsignore
tmon\.out
-t/samples/template
-wrap
\ No newline at end of file
+WrapEx.pm
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CGI-Ex
-version: 1.14
+version: 2.00
version_from: lib/CGI/Ex.pm
installdirs: site
requires:
NAME
- CGI::Ex - CGI utility suite (form getter/filler/validator/app builder)
-
-SYNOPSIS
- ### CGI Module Extensions
-
- my $cgix = CGI::Ex->new;
- my $hashref = $cgix->get_form; # uses CGI by default
-
- ### send the Content-type header - whether or not we are mod_perl
- $cgix->print_content_type;
-
- my $val_hash = $cgix->conf_read($pathtovalidation);
-
- my $err_obj = $cgix->validate($hashref, $val_hash);
- if ($err_obj) {
- my $errors = $err_obj->as_hash;
- my $input = "Some content";
- my $content = "";
- SomeTemplateObject->process($input, $errors, $content);
- $cgix->fill({text => \$content, form => $hashref});
- print $content;
- exit;
- }
-
- print "Success\n";
-
- ### Filling functionality
-
- $cgix->fill({text => \$text, form => \%hash});
- $cgix->fill({text => \$text, fdat => \%hash});
- $cgix->fill({text => \$text, fobject => $cgiobject});
- $cgix->fill({text => \$text, form => [\%hash1, $cgiobject]});
- $cgix->fill({text => \$text); # uses $self->object as the form
- $cgix->fill({text => \$text,
- form => \%hash,
- target => 'formname',
- fill_password => 0,
- ignore_fields => ['one','two']});
- $cgix->fill(\$text); # uses $self->object as the form
- $cgix->fill(\$text, \%hash, 'formname', 0, ['one','two']);
- my $copy = $cgix->fill({scalarref => \$text, fdat => \%hash});
- my $copy = $cgix->fill({arrayref => \@lines, fdat => \%hash});
- my $copy = $cgix->fill({file => $filename, fdat => \%hash});
-
- ### Validation functionality
-
- my $err_obj = $cgix->validate($form, $val_hash);
- my $err_obj = $cgix->validate($form, $path_to_validation);
- my $err_obj = $cgix->validate($form, $yaml_string);
-
- ### get errors separated by key name
- ### useful for inline errors
- my $hash = $err_obj->as_hash;
- my %hash = $err_obj->as_hash;
-
- ### get aggregate list of errors
- ### useful for central error description
- my $array = $err_obj->as_array;
- my @array = $err_obj->as_array;
-
- ### get a string
- ### useful for central error description
- my $string = $err_obj->as_string;
- my $string = "$err_obj";
-
- $cgix->{raise_error} = 1;
- $cgix->validate($form, $val_hash);
- # SAME AS #
- my $err_obj = $cgix->validate($form, $val_hash);
- die $err_obj if $err_obj;
-
- ### Settings functionality
-
- ### read file via yaml
- my $ref = $cgix->conf_read('/full/path/to/conf.yaml');
-
- ### merge all found settings.pl files together
- @CGI::Ex::Conf::DEFAULT_PATHS = qw(/tmp /my/data/dir /home/foo);
- @CGI::Ex::Conf::DIRECTIVE = 'MERGE';
- @CGI::Ex::Conf::DEFAULT_EXT = 'pl';
- my $ref = $cgix->conf_read('settings');
+ 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 a framework (which normally includes
- prebuilt html) instead CGI::Ex::App is an extended application flow that
- normally dramatically reduces CGI build time. See CGI::Ex::App.
-
- CGI::Ex is another form filler / validator / conf reader / template
- interface. Its goal is to take the wide scope of validators and other
- useful CGI application modules out there and merge them into one utility
- that has all of the necessary features of them all, as well as several
- extended methods that I have found useful in working on the web.
+ 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
and xml and open architecture for definition of others. See
CGI::Ex::Conf for more information.
-METHODS
+ "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
"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 modfied as a string). It will be
+ 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.
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
- 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 informatin -
+ 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.
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 compatiblity with
+ Other named arguments are available for compatibility with
HTML::FillInForm. They may only be used as named arguments.
"scalarref"
"->get_form"
Very similar to CGI->new->Vars except that arrays are returned as
- arrays. Not sure why CGI::Val didn't do this anyway (well - yes -
- legacy Perl 4 - but at some point things need to be updated).
+ 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
#$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.
templates that were being swapped by CGI::Ex::swap_template should
be compatible with Template::Toolkit.
-EXISTING MODULES
- The following is a list of existing validator and formfiller modules at
- the time of this writing (I'm sure this probably isn't exaustive).
-
- "Email::Valid" - Validator
- "SSN::Validate" - Validator
- "Embperl::Form::Validate" - Validator
- "Data::CGIForm" - Validator
- "HTML::FillInForm" - Form filler-iner
- "CGI" - CGI Getter. Form filler-iner
-
-TODO
- Add an integrated template toolkit interface.
+MODULES
+ See also CGI::Ex::App.
- Add an integrated debug module.
+ See also CGI::Ex::Auth.
-MODULES
- See also CGI::Ex::Fill.
+ See also CGI::Ex::Conf.
- See also CGI::Ex::Validate.
+ See also CGI::Ex::Die.
- See also CGI::Ex::Conf.
+ See also CGI::Ex::Dump.
- See also CGI::Ex::Die.
+ See also CGI::Ex::Fill.
- See also CGI::Ex::App.
+ See also CGI::Ex::Template.
- See also CGI::Ex::Dump.
+ See also CGI::Ex::Validate.
AUTHOR
- Paul Seamons
+ Paul Seamons
LICENSE
- This module may be distributed under the same terms as Perl itself.
+ This module may be distributed under the same terms as Perl itself.
package CGI::Ex;
-### CGI Extended
+=head1 NAME
+
+CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2003 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
use strict;
use vars qw($VERSION
- $PREFERRED_FILL_MODULE
$PREFERRED_CGI_MODULE
$PREFERRED_CGI_REQUIRED
- $TEMPLATE_OPEN
- $TEMPLATE_CLOSE
$AUTOLOAD
$DEBUG_LOCATION_BOUNCE
@EXPORT @EXPORT_OK
);
use base qw(Exporter);
-$VERSION = '1.14';
-$PREFERRED_FILL_MODULE ||= '';
-$PREFERRED_CGI_MODULE ||= 'CGI';
-$TEMPLATE_OPEN ||= qr/\[%\s*/;
-$TEMPLATE_CLOSE ||= qr/\s*%\]/;
-@EXPORT = ();
-@EXPORT_OK = qw(get_form
- get_cookies
- print_content_type
- content_type
- content_typed
- set_cookie
- );
+BEGIN {
+ $VERSION = '2.00';
+ $PREFERRED_CGI_MODULE ||= 'CGI';
+ @EXPORT = ();
+ @EXPORT_OK = qw(get_form
+ get_cookies
+ print_content_type
+ content_type
+ content_typed
+ set_cookie
+ location_bounce
+ );
+}
###----------------------------------------------------------------###
# my $cgix = CGI::Ex->new;
sub new {
- my $class = shift || die "Missing class name";
- my $self = ref($_[0]) ? shift : {@_};
- return bless $self, $class;
+ my $class = shift || die "Missing class name";
+ my $self = ref($_[0]) ? shift : {@_};
+ return bless $self, $class;
}
+###----------------------------------------------------------------###
+
### allow for holding another classed CGI style object
# my $query = $cgix->object;
# $cgix->object(CGI->new);
sub object {
- my $self = shift;
- die 'Usage: my $query = $cgix_obj->object' if ! ref $self;
- return $self->{'object'} = shift if $#_ != -1;
- return $self->{'object'} ||= do {
- $PREFERRED_CGI_REQUIRED ||= do {
- my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE;
- $file .= ".pm";
- $file =~ s|::|/|g;
- eval { require $file };
- die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@;
- 1; # return of inner do
- };
- $PREFERRED_CGI_MODULE->new; # return of the do
- };
+ my $self = shift || die 'Usage: my $query = $cgix_obj->object';
+ $self->{'object'} = shift if $#_ != -1;
+
+ if (! defined $self->{'object'}) {
+ $PREFERRED_CGI_REQUIRED ||= do {
+ my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE;
+ $file .= ".pm";
+ $file =~ s|::|/|g;
+ eval { require $file };
+ die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@;
+ 1; # return of do
+ };
+ $self->{'object'} = $PREFERRED_CGI_MODULE->new;
+ }
+
+ return $self->{'object'};
}
-### allow for calling their methods
+### allow for calling CGI MODULE methods
sub AUTOLOAD {
- my $self = shift;
- my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
- return wantarray # does wantarray propogate up ?
- ? ($self->object->$meth(@_))
- : $self->object->$meth(@_);
+ my $self = shift;
+ my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
+ return $self->object->$meth(@_);
}
-sub DESTROY {}
+sub DESTROY { }
###----------------------------------------------------------------###
# my $hash = get_form();
# my $hash = get_form(CGI->new);
sub get_form {
- my $self = shift;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->get_form' if ! ref $self;
- if (! UNIVERSAL::isa($self, __PACKAGE__)) { # get_form(CGI->new) syntax
- my $obj = $self;
- $self = __PACKAGE__->new;
- $self->object($obj);
- }
- return $self->{'form'} if $self->{'form'};
-
- ### get the info out of the object
- my $obj = shift || $self->object;
- my %hash = ();
- foreach my $key ($obj->param) {
- my @val = $obj->param($key);
- $hash{$key} = ($#val == -1) ? die : ($#val == 0) ? $val[0] : \@val;
- }
- return $self->{'form'} = \%hash;
+ my $self = shift || __PACKAGE__->new;
+ if (! $self->isa(__PACKAGE__)) { # get_form(CGI->new) syntax
+ my $obj = $self;
+ $self = __PACKAGE__->new;
+ $self->object($obj);
+ }
+ return $self->{'form'} if $self->{'form'};
+
+ ### get the info out of the object
+ my $obj = shift || $self->object;
+ my %hash = ();
+ foreach my $key ($obj->param) {
+ my @val = $obj->param($key);
+ $hash{$key} = ($#val <= 0) ? $val[0] : \@val;
+ }
+ return $self->{'form'} = \%hash;
}
### allow for a setter
### $cgix->set_form(\%form);
sub set_form {
- my $self = shift;
- die 'Usage: $cgix_obj->set_form(\%form)' if ! ref $self;
- $self->{'form'} = shift || {};
+ my $self = shift || die 'Usage: $cgix_obj->set_form(\%form)';
+ return $self->{'form'} = shift || {};
}
### Combined get and set form
# my $hash = $cgix->form;
# $cgix->form(\%form);
sub form {
- my $self = shift;
- die (defined wantarray
- ? 'Usage: my $form = $cgix_obj->form' : 'Usage: $cgix_obj->form(\%form)')
- if ! UNIVERSAL::isa($self, __PACKAGE__);
- return $self->set_form(shift) if $#_ != -1;
- return $self->get_form;
+ my $self = shift;
+ return $self->set_form(shift) if @_ == 1;
+ return $self->get_form;
}
### allow for creating a url encoded key value sequence
# my $str = $cgix->make_form(\%form);
# my $str = $cgix->make_form(\%form, \@keys_to_include);
sub make_form {
- my $self = shift;
- die 'Usage: $cgix_obj->make_form(\%form)' if ! ref $self;
- my $form = shift || $self->get_form;
- my $keys = ref($_[0]) ? shift : [sort keys %$form];
- my $str = '';
- foreach (@$keys) {
- my $key = $_; # make a copy
- my $val = $form->{$key};
- $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
- $key =~ y/ /+/;
- foreach (ref($val) ? @$val : $val) {
- my $_val = $_; # make a copy
- $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
- $_val =~ y/ /+/;
- $str .= "$key=$_val&"; # intentionally not using join
+ my $self = shift || die 'Usage: $cgix_obj->make_form(\%form)';
+ my $form = shift || $self->get_form;
+ my $keys = ref($_[0]) ? shift : [sort keys %$form];
+ my $str = '';
+ foreach (@$keys) {
+ my $key = $_; # make a copy
+ my $val = $form->{$key};
+ $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
+ $key =~ y/ /+/;
+ foreach (ref($val) ? @$val : $val) {
+ my $_val = $_; # make a copy
+ $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
+ $_val =~ y/ /+/;
+ $str .= "$key=$_val&"; # intentionally not using join
+ }
}
- }
- chop $str;
- return $str;
+ chop $str;
+ return $str;
}
###----------------------------------------------------------------###
# my $hash = get_cookies();
# my $hash = get_cookies(CGI->new);
sub get_cookies {
- my $self = shift;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->get_cookies' if ! ref $self;
- if (! UNIVERSAL::isa($self, __PACKAGE__)) { # get_cookies(CGI->new) syntax
- my $obj = $self;
- $self = __PACKAGE__->new;
- $self->object($obj);
- }
- return $self->{'cookies'} if $self->{'cookies'};
-
- my $obj = shift || $self->object;
- use CGI::Ex::Dump qw(debug);
- my %hash = ();
- foreach my $key ($obj->cookie) {
- my @val = $obj->cookie($key);
- $hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val;
- }
- return $self->{'cookies'} = \%hash;
+ my $self = shift || __PACKAGE__->new;
+ if (! $self->isa(__PACKAGE__)) { # get_cookies(CGI->new) syntax
+ my $obj = $self;
+ $self = __PACKAGE__->new;
+ $self->object($obj);
+ }
+ return $self->{'cookies'} if $self->{'cookies'};
+
+ my $obj = shift || $self->object;
+ my %hash = ();
+ foreach my $key ($obj->cookie) {
+ my @val = $obj->cookie($key);
+ $hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val;
+ }
+ return $self->{'cookies'} = \%hash;
}
### Allow for a setter
### $cgix->set_cookies(\%cookies);
sub set_cookies {
- my $self = shift;
- die 'Usage: $cgix_obj->set_cookies(\%cookies)' if ! ref $self;
- $self->{'cookies'} = shift || {};
+ my $self = shift || die 'Usage: $cgix_obj->set_cookies(\%cookies)';
+ return $self->{'cookies'} = shift || {};
}
### Combined get and set cookies
# my $hash = $cgix->cookies;
# $cgix->cookies(\%cookies);
sub cookies {
- my $self = shift;
- die (defined wantarray
- ? 'Usage: my $hash = $cgix_obj->cookies' : 'Usage: $cgix_obj->cookies(\%cookies)')
- if ! UNIVERSAL::isa($self, __PACKAGE__);
- return $self->set_cookies(shift) if $#_ != -1;
- return $self->get_cookies;
+ my $self = shift;
+ return $self->set_cookies(shift) if @_ == 1;
+ return $self->get_cookies;
}
###----------------------------------------------------------------###
# my $r = $cgix->apache_request
# $cgix->apache_request($r);
sub apache_request {
- my $self = shift;
- die 'Usage: $cgix_obj->apache_request' if ! ref $self;
- $self->{'apache_request'} = shift if $#_ != -1;
- if (! defined $self->{'apache_request'}) {
- return if ! $self->mod_perl_version;
- $self->{'apache_request'} = Apache->request;
- }
- return $self->{'apache_request'};
+ my $self = shift || die 'Usage: $cgix_obj->apache_request';
+ $self->{'apache_request'} = shift if $#_ != -1;
+
+ if (! $self->{'apache_request'}) {
+ if ($self->is_mod_perl_1) {
+ require Apache;
+ $self->{'apache_request'} = Apache->request;
+ } elsif ($self->is_mod_perl_2) {
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ $self->{'apache_request'} = Apache2::RequestUtil->request;
+ }
+ }
+
+ return $self->{'apache_request'};
}
### Get the version of mod_perl running (0 if not mod_perl)
# my $version = $cgix->mod_perl_version;
sub mod_perl_version {
- my $self = shift;
- die 'Usage: $cgix_obj->mod_perl_version' if ! ref $self;
- if (! defined $self->{'mod_perl_version'}) {
- return 0 if ! $ENV{'MOD_PERL'};
- # mod_perl/1.27 or mod_perl/1.99_16
- # if MOD_PERL is set - don't die if regex fails - just assume 1.0
- $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m|^mod_perl/(\d+\.[\d_]+)$|)
- ? $1 : '1.0_0';
- }
- return $self->{'mod_perl_version'};
+ my $self = shift || die 'Usage: $cgix_obj->mod_perl_version';
+
+ if (! defined $self->{'mod_perl_version'}) {
+ return 0 if ! $ENV{'MOD_PERL'};
+ # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
+ # if MOD_PERL is set - don't die if regex fails - just assume 1.0
+ $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x)
+ ? $1 : '1.0_0';
+ }
+ return $self->{'mod_perl_version'};
}
-sub is_mod_perl_1 { shift->mod_perl_version < 1.98 }
-sub is_mod_perl_2 { shift->mod_perl_version >= 1.98 }
+sub is_mod_perl_1 { my $m = shift->mod_perl_version; return $m < 1.98 && $m > 0 }
+sub is_mod_perl_2 { my $m = shift->mod_perl_version; return $m >= 1.98 }
### Allow for a setter
# $cgix->set_apache_request($r)
###----------------------------------------------------------------###
### same signature as print_content_type
-sub content_type {
- &print_content_type;
-}
+sub content_type { &print_content_type }
### will send the Content-type header
# $cgix->print_content_type;
# print_content_type();
# print_content_type('text/plain);
sub print_content_type {
- my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift);
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->print_content_type' if ! ref $self;
- if ($type) {
- die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo
- } else {
- $type = 'text/html';
- }
-
- if (my $r = $self->apache_request) {
- return if $r->bytes_sent;
- $r->content_type($type);
- $r->send_http_header if $self->is_mod_perl_1;
- } else {
- if (! $ENV{'CONTENT_TYPED'}) {
- print "Content-Type: $type\r\n\r\n";
- $ENV{'CONTENT_TYPED'} = '';
+ my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift);
+ $self = __PACKAGE__->new if ! $self;
+
+ if ($type) {
+ die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo
+ } else {
+ $type = 'text/html';
+ }
+
+ if (my $r = $self->apache_request) {
+ return if $r->bytes_sent;
+ $r->content_type($type);
+ $r->send_http_header if $self->is_mod_perl_1;
+ } else {
+ if (! $ENV{'CONTENT_TYPED'}) {
+ print "Content-Type: $type\r\n\r\n";
+ $ENV{'CONTENT_TYPED'} = '';
+ }
+ $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
}
- $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
- }
}
### Boolean check if content has been typed
# $cgix->content_typed;
# content_typed();
sub content_typed {
- my $self = shift;
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->content_typed' if ! ref $self;
-
- if (my $r = $self->apache_request) {
- return $r->bytes_sent;
- } else {
- return ($ENV{'CONTENT_TYPED'}) ? 1 : undef;
- }
+ my $self = shift || __PACKAGE__->new;
+
+ if (my $r = $self->apache_request) {
+ return $r->bytes_sent;
+ } else {
+ return $ENV{'CONTENT_TYPED'} ? 1 : undef;
+ }
}
###----------------------------------------------------------------###
# $cgix->location_bounce($url);
# location_bounce($url);
sub location_bounce {
- my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
- $self = __PACKAGE__->new if ! $self;
- die 'Usage: $cgix_obj->location_bounce($url)' if ! ref $self;
+ my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
+ $self = __PACKAGE__->new if ! $self;
+
+ if ($self->content_typed) {
+ if ($DEBUG_LOCATION_BOUNCE) {
+ print "<a class=debug href=\"$loc\">Location: $loc</a><br />\n";
+ } else {
+ print "<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n";
+ }
+
+ } elsif (my $r = $self->apache_request) {
+ $r->status(302);
+ if ($self->is_mod_perl_1) {
+ $r->header_out("Location", $loc);
+ $r->content_type('text/html');
+ $r->send_http_header;
+ $r->print("Bounced to $loc\n");
+ } else {
+ $r->headers_out->add("Location", $loc);
+ $r->content_type('text/html');
+ $r->rflush;
+ }
- if ($self->content_typed) {
- if ($DEBUG_LOCATION_BOUNCE) {
- print "<a class=debug href=\"$loc\">Location: $loc</a><br />\n";
- } else {
- print "<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n";
- }
- } else {
- if (my $r = $self->apache_request) {
- $r->status(302);
- if ($self->is_mod_perl_1) {
- $r->header_out("Location", $loc);
- $r->content_type('text/html');
- $r->send_http_header;
- $r->print("Bounced to $loc\n");
- } else {
- my $t = $r->headers_out;
- $t->add("Location", $loc);
- $r->headers_out($t);
- }
} else {
- print "Location: $loc\r\n",
- "Status: 302 Bounce\r\n",
- "Content-Type: text/html\r\n\r\n",
- "Bounced to $loc\r\n";
+ print "Location: $loc\r\n",
+ "Status: 302 Bounce\r\n",
+ "Content-Type: text/html\r\n\r\n",
+ "Bounced to $loc\r\n";
}
- }
}
### set a cookie nicely - even if we have already sent content
# set_cookie({name => $name, ...});
# set_cookie( name => $name, ... );
sub set_cookie {
- my $self = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
- my $args = ref($_[0]) ? shift : {@_};
- foreach (keys %$args) {
- next if /^-/;
- $args->{"-$_"} = delete $args->{$_};
- }
-
- ### default path to / and allow for 1hour instead of 1h
- $args->{-path} ||= '/';
- $args->{-expires} = time_calc($args->{-expires}) if $args->{-expires};
-
- my $obj = $self->object;
- my $cookie = "" . $obj->cookie(%$args);
-
- if ($self->content_typed) {
- print "<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n";
- } else {
- if (my $r = $self->apache_request) {
- if ($self->is_mod_perl_1) {
- $r->header_out("Set-cookie", $cookie);
- } else {
- my $t = $r->headers_out;
- $t->add("Set-Cookie", $cookie);
- $r->headers_out($t);
- }
+ my $self = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
+
+ my $args = ref($_[0]) ? shift : {@_};
+ foreach (keys %$args) {
+ next if /^-/;
+ $args->{"-$_"} = delete $args->{$_};
+ }
+
+ ### default path to / and allow for 1hour instead of 1h
+ $args->{-path} ||= '/';
+ $args->{-expires} = time_calc($args->{-expires}) if $args->{-expires};
+
+ my $obj = $self->object;
+ my $cookie = "" . $obj->cookie(%$args);
+
+ if ($self->content_typed) {
+ print "<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n";
} else {
- print "Set-Cookie: $cookie\r\n"
+ if (my $r = $self->apache_request) {
+ if ($self->is_mod_perl_1) {
+ $r->header_out("Set-cookie", $cookie);
+ } else {
+ $r->headers_out->add("Set-Cookie", $cookie);
+ }
+ } else {
+ print "Set-Cookie: $cookie\r\n";
+ }
}
- }
}
### print the last modified time
# $cgix->last_modified; # now
# $cgix->last_modified((stat $file)[9]); # file's time
# $cgix->last_modified(time, 'Expires'); # different header
-# last_modified(); # now
-# last_modified((stat $file)[9]); # file's time
-# last_modified(time, 'Expires'); # different header
sub last_modified {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- $self = $self->new if ! ref $self;
- my $time = shift || time;
- my $key = shift || 'Last-Modified';
-
- ### get a time string - looks like:
- ### Mon Dec 9 18:03:21 2002
- ### valid RFC (although not prefered)
- $time = scalar gmtime time_calc($time);
-
- if ($self->content_typed) {
- print "<meta http-equiv=\"$key\" content=\"$time\" />\n";
- } else {
- if (my $r = $self->apache_request) {
- if ($self->is_mod_perl_1) {
- $r->header_out($key, $time);
- } else {
- my $t = $r->headers_out;
- $t->add($key, $time);
- $r->headers_out($t);
- }
+ my $self = shift || die 'Usage: $cgix_obj->last_modified($time)'; # may be called as function or method
+ my $time = shift || time;
+ my $key = shift || 'Last-Modified';
+
+ ### get a time string - looks like:
+ ### Mon Dec 9 18:03:21 2002
+ ### valid RFC (although not prefered)
+ $time = scalar gmtime time_calc($time);
+
+ if ($self->content_typed) {
+ print "<meta http-equiv=\"$key\" content=\"$time\" />\n";
+ } elsif (my $r = $self->apache_request) {
+ if ($self->is_mod_perl_1) {
+ $r->header_out($key, $time);
+ } else {
+ $r->headers_out->add($key, $time);
+ }
} else {
- print "$key: $time\r\n"
+ print "$key: $time\r\n";
}
- }
-
}
### add expires header
sub expires {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as a function or method
- my $time = shift || time;
- return $self->last_modified($time, 'Expires');
+ my $self = ref($_[0]) ? shift : __PACKAGE__->new; # may be called as a function or method
+ my $time = shift || time;
+ return $self->last_modified($time, 'Expires');
}
### similar to expires_calc from CGI::Util
### allows for lenient calling, hour instead of just h, etc
### takes time or 0 or now or filename or types of -23minutes
sub time_calc {
- my $time = shift; # may only be called as a function
- if (! $time || lc($time) eq 'now') {
- return time;
- } elsif ($time =~ m/^\d+$/) {
- return $time;
- } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) {
- my $m = {
- 's' => 1,
- 'm' => 60,
- 'h' => 60 * 60,
- 'd' => 60 * 60 * 24,
- 'w' => 60 * 60 * 24 * 7,
- 'M' => 60 * 60 * 24 * 30,
- 'y' => 60 * 60 * 24 * 365,
- };
- 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;
- return $stat[9];
- }
+ my $time = shift; # may only be called as a function
+ if (! $time || lc($time) eq 'now') {
+ return time;
+ } elsif ($time =~ m/^\d+$/) {
+ return $time;
+ } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) {
+ my $m = {
+ 's' => 1,
+ 'm' => 60,
+ 'h' => 60 * 60,
+ 'd' => 60 * 60 * 24,
+ 'w' => 60 * 60 * 24 * 7,
+ 'M' => 60 * 60 * 24 * 30,
+ 'y' => 60 * 60 * 24 * 365,
+ };
+ 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;
+ return $stat[9];
+ }
}
### allow for generic status send
sub send_status {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- my $code = shift || die "Missing status";
- my $mesg = shift;
- if (! defined $mesg) {
- $mesg = "HTTP Status of $code received\n";
- }
- if ($self->content_typed) {
- die "Cannot send a status ($code - $mesg) after content has been sent";
- }
- if (my $r = $self->apache_request) {
- $r->status($code);
- if ($self->is_mod_perl_1) {
- $r->content_type('text/html');
- $r->send_http_header;
- $r->print($mesg);
+ my $self = shift || die 'Usage: $cgix_obj->send_status(302 => "Bounced")';
+ my $code = shift || die "Missing status";
+ my $mesg = shift;
+ if (! defined $mesg) {
+ $mesg = "HTTP Status of $code received\n";
+ }
+ if ($self->content_typed) {
+ die "Cannot send a status ($code - $mesg) after content has been sent";
+ }
+ if (my $r = $self->apache_request) {
+ $r->status($code);
+ if ($self->is_mod_perl_1) {
+ $r->content_type('text/html');
+ $r->send_http_header;
+ $r->print($mesg);
+ } else {
+ # not sure of best way to send the message in MP2
+ }
} else {
- # not sure of best way to send the message in MP2
+ print "Status: $code\r\n";
+ $self->print_content_type;
+ print $mesg;
}
- } else {
- print "Status: $code\r\n";
- $self->print_content_type;
- print $mesg;
- }
}
### allow for sending a simple header
sub send_header {
- my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method
- my $key = shift;
- my $value = shift;
- if ($self->content_typed) {
- die "Cannot send a header ($key - $value) after content has been sent";
- }
- if (my $r = $self->apache_request) {
- if ($self->is_mod_perl_1) {
- $r->header_out($key, $value);
+ my $self = shift || die 'Usage: $cgix_obj->send_header';
+ my $key = shift;
+ my $val = shift;
+ if ($self->content_typed) {
+ die "Cannot send a header ($key - $val) after content has been sent";
+ }
+ if (my $r = $self->apache_request) {
+ if ($self->is_mod_perl_1) {
+ $r->header_out($key, $val);
+ } else {
+ $r->headers_out->add($key, $val);
+ }
} else {
- my $t = $r->headers_out;
- $t->add($key, $value);
- $r->headers_out($t);
+ print "$key: $val\r\n";
}
- } else {
- print "$key: $value\r\n";
- }
}
###----------------------------------------------------------------###
### allow for printing out a static javascript file
### for example $self->print_js("CGI::Ex::validate.js");
sub print_js {
- my ($self, $js_file) = ($#_ == 1) ? (@_) : (__PACKAGE__, shift);
- $self = $self->new if ! ref $self;
-
- ### fix up the file - force .js on the end
- $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i;
- $js_file =~ s|::|/|g;
-
- ### get file info
- my $stat;
- if (! $js_file) {
- # do nothing - give the 404
- } elsif ($js_file !~ m|^\.{0,2}/|) {
- foreach my $path (@INC) {
- my $_file = "$path/$js_file";
- next if ! -f $_file;
- $js_file = $_file;
- $stat = [stat _];
- last;
+ my $self = shift || die 'Usage: $cgix_obj->print_js($js_file)';
+ my $js_file = shift || '';
+ $self = $self->new if ! ref $self;
+
+ ### fix up the file - force .js on the end
+ $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i;
+ $js_file =~ s|::|/|g;
+
+ ### get file info
+ my $stat;
+ if ($js_file && $js_file =~ m|^(\w+(?:/+\w+)*\.js)$|i) {
+ foreach my $path (@INC) {
+ my $_file = "$path/$1";
+ next if ! -f $_file;
+ $js_file = $_file;
+ $stat = [stat _];
+ last;
+ }
}
- } else {
- if (-f $js_file) {
- $stat = [stat _];
+
+ ### no file = 404
+ if (! $stat) {
+ if (! $self->content_typed) {
+ $self->send_status(404, "JS File not found for print_js\n");
+ } else {
+ print "<h1>JS File not found for print_js</h1>\n";
+ }
+ return;
}
- }
- ### no - file - 404
- if (! $stat) {
+ ### do headers
if (! $self->content_typed) {
- $self->send_status(404, "JS File not found for print_js\n");
- } else {
- print "<h1>JS File not found for print_js</h1>\n";
+ $self->last_modified($stat->[9]);
+ $self->expires('+ 1 year');
+ $self->print_content_type('application/x-javascript');
}
- return;
- }
+ return if $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'HEAD';
- ### do headers
- if (! $self->content_typed) {
- $self->last_modified($stat->[9]);
- $self->expires('+ 1 year');
- $self->print_content_type('application/x-javascript');
- }
-
- return if $ENV{REQUEST_METHOD} && $ENV{REQUEST_METHOD} eq 'HEAD';
-
- ### send the contents
- if (open IN, $js_file) {
+ ### send the contents
+ local *FH;
+ open(FH, "<$js_file") || die "Couldn't open file $js_file: $!";
local $/ = undef;
- print <IN>;
- close IN;
- } else {
- die "Couldn't open file $js_file: $!";
- }
+ print <FH>;
+ close FH;
}
###----------------------------------------------------------------###
### or another specified filler. Argument style is similar to
### HTML::FillInForm. May be called as a method or a function.
sub fill {
- my $self = shift;
- my $args = shift;
- if (ref($args)) {
- if (! UNIVERSAL::isa($args, 'HASH')) {
- $args = {text => $args};
- @$args{'form','target','fill_password','ignore_fields'} = @_;
- }
- } else {
- $args = {$args, @_};
- }
-
- my $module = $self->{fill_module} || $PREFERRED_FILL_MODULE;
-
- ### allow for using the standard HTML::FillInForm
- ### too bad it won't modify our file in place for us
- if ($module eq 'HTML::FillInForm') {
- eval { require HTML::FillInForm };
- if ($@) {
- die "Couldn't require HTML::FillInForm: $@";
- }
- $args->{scalarref} = $args->{text} if $args->{text};
- $args->{fdat} = $args->{form} if $args->{form};
- my $filled = HTML::FillInForm->new->fill(%$args);
- if ($args->{text}) {
- my $ref = $args->{text};
- $$ref = $filled;
- return 1;
- }
- return $filled;
-
- ### allow for some other type - for whatever reason
- } elsif ($module) {
- my $file = $module;
- $file .= '.pm' if $file !~ /\.\w+$/;
- $file =~ s|::|/|g;
- eval { require $file };
- if ($@) {
- die "Couldn't require $module: $@";
- }
- return $module->new->fill(%$args);
-
- ### well - we will use our own then
- } else {
- require CGI::Ex::Fill;
-
- ### get the text to work on
- my $ref;
- if ($args->{text}) { # preferred method - gets modified in place
- $ref = $args->{text};
- } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm
- my $str = ${ $args->{scalarref} };
- $ref = \$str;
- } elsif ($args->{arrayref}) { # joined together (copy)
- my $str = join "", @{ $args->{arrayref} };
- $ref = \$str;
- } elsif ($args->{file}) { # read it in
- open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!";
- my $str = '';
- read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!";
- close IN;
- $ref = \$str;
+ my $self = shift;
+ my $args = shift;
+ if (ref($args)) {
+ if (! UNIVERSAL::isa($args, 'HASH')) {
+ $args = {text => $args};
+ @$args{'form','target','fill_password','ignore_fields'} = @_;
+ }
} else {
- die "No suitable text found for fill.";
+ $args = {$args, @_};
}
- ### allow for data to be passed many ways
- my $form = $args->{form} || $args->{fobject}
- || $args->{fdat} || $self->object;
-
- &CGI::Ex::Fill::form_fill($ref,
- $form,
- $args->{target},
- $args->{fill_password},
- $args->{ignore_fields},
- );
- return ! $args->{text} ? $$ref : 1;
- }
+ my $module = $self->{'fill_module'} || 'CGI::Ex::Fill';
+
+ ### allow for using the standard HTML::FillInForm
+ ### too bad it won't modify our file in place for us
+ if ($module eq 'HTML::FillInForm') {
+ eval { require HTML::FillInForm };
+ if ($@) {
+ die "Couldn't require HTML::FillInForm: $@";
+ }
+ $args->{scalarref} = $args->{text} if $args->{text};
+ $args->{fdat} = $args->{form} if $args->{form};
+ my $filled = HTML::FillInForm->new->fill(%$args);
+ if ($args->{text}) {
+ my $ref = $args->{text};
+ $$ref = $filled;
+ return 1;
+ }
+ return $filled;
+
+ } else {
+ require CGI::Ex::Fill;
+
+ ### get the text to work on
+ my $ref;
+ if ($args->{text}) { # preferred method - gets modified in place
+ $ref = $args->{text};
+ } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm
+ my $str = ${ $args->{scalarref} };
+ $ref = \$str;
+ } elsif ($args->{arrayref}) { # joined together (copy)
+ my $str = join "", @{ $args->{arrayref} };
+ $ref = \$str;
+ } elsif ($args->{file}) { # read it in
+ open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!";
+ my $str = '';
+ read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!";
+ close IN;
+ $ref = \$str;
+ } else {
+ die "No suitable text found for fill.";
+ }
+
+ ### allow for data to be passed many ways
+ my $form = $args->{form} || $args->{fobject}
+ || $args->{fdat} || $self->object;
+
+ CGI::Ex::Fill::form_fill($ref,
+ $form,
+ $args->{target},
+ $args->{fill_password},
+ $args->{ignore_fields},
+ );
+ return ! $args->{text} ? $$ref : 1;
+ }
}
###----------------------------------------------------------------###
sub validate {
- my $self = shift || die "Sub \"validate\" must be called as a method";
- my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift);
+ my $self = shift || die 'Usage: my $er = $cgix_obj->validate($form, $val_hash_or_file)';
+ my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift);
- require CGI::Ex::Validate;
+ require CGI::Ex::Validate;
- my $args = {};
- $args->{raise_error} = 1 if $self->{raise_error};
- return CGI::Ex::Validate->new($args)->validate($form, $file);
+ my $args = {};
+ $args->{raise_error} = 1 if $self->{raise_error};
+ return CGI::Ex::Validate->new($args)->validate($form, $file);
}
###----------------------------------------------------------------###
sub conf_obj {
- my $self = shift || die "Sub \"conf_obj\" must be called as a method";
- return $self->{conf_obj} ||= do {
- require CGI::Ex::Conf;
- CGI::Ex::Conf->new(@_);
- };
+ my $self = shift || die 'Usage: my $ob = $cgix_obj->conf_obj($args)';
+ return $self->{conf_obj} ||= do {
+ require CGI::Ex::Conf;
+ CGI::Ex::Conf->new(@_);
+ };
}
sub conf_read {
- my $self = shift || die "Sub \"conf_read\" must be called as a method";
- return $self->conf_obj->read(@_);
+ my $self = shift || die 'Usage: my $conf = $cgix_obj->conf_read($file)';
+ return $self->conf_obj->read(@_);
}
###----------------------------------------------------------------###
-### 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)
sub swap_template {
- my $self = shift || die "Sub \"swap_template\" must be called as a method";
- my $str = shift;
- return $str if ! $str;
- my $ref = ref($str) ? $str : \$str;
-
- ### basic - allow for passing a hash, or object, or code ref
- my $form = shift;
- $form = $self if ! $form && ref($self);
- $form = $self->get_form() if UNIVERSAL::isa($form, __PACKAGE__);
-
- my $get_form_value;
- if (UNIVERSAL::isa($form, 'HASH')) {
- $get_form_value = sub {
- my $key = shift;
- return defined($form->{$key}) ? $form->{$key} : '';
- };
- } elsif (my $meth = UNIVERSAL::can($form, 'param')) {
- $get_form_value = sub {
- my $key = shift;
- my $val = $form->$meth($key);
- return defined($val) ? $val : '';
- };
- } elsif (UNIVERSAL::isa($form, 'CODE')) {
- $get_form_value = sub {
- my $key = shift;
- my $val = &{ $form }($key);
- return defined($val) ? $val : '';
- };
- } else {
- die "Not sure how to use $form passed to swap_template_tags";
- }
-
- ### now do the swap
- $$ref =~ s{$TEMPLATE_OPEN \b (\w+) ((?:\.\w+)*) \b $TEMPLATE_CLOSE}{
- if (! $2) {
- &$get_form_value($1);
+ my $self = shift || die 'Usage: my $out = $cgix_obj->swap_template($file, \%vars, $template_args)';
+ my $str = shift;
+ my $form = shift;
+ my $args = shift || {};
+ $form = $self if ! $form && ref($self);
+ $form = $self->get_form if UNIVERSAL::isa($form, __PACKAGE__);
+
+ my ($ref, $return) = ref($str) ? ($str, 0) : (\$str, 1);
+
+ ### look up the module
+ my $module = $self->{'template_module'} || 'CGI::Ex::Template';
+ my $pkg = "$module.pm";
+ $pkg =~ s|::|/|g;
+ require $pkg;
+
+ ### swap it
+ my $out = '';
+ $module->new($args)->process($ref, $form, \$out);
+
+ if (! $return) {
+ $$ref = $out;
+ return 1;
} else {
- my @extra = split(/\./, substr($2,1));
- my $ref = &$get_form_value($1);
- my $val;
- while (defined(my $key = shift(@extra))) {
- if (UNIVERSAL::isa($ref, 'HASH')) {
- if (! exists($ref->{$key}) || ! defined($ref->{$key})) {
- $val = '';
- last;
- }
- $ref = $ref->{$key};
- } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
- if (! exists($ref->[$key]) || ! defined($ref->[$key])) {
- $val = '';
- last;
- }
- $ref = $ref->[$key];
- } else {
- $val = '';
- last;
- }
- }
- if (! defined($val)) {
- if ($#extra == -1) {
- $val = $ref;
- }
- $val = '' if ! defined($val);
- }
- $val; # return of the swap
+ return $out;
}
- }xeg;
-
- return ref($str) ? 1 : $$ref;
}
###----------------------------------------------------------------###
__END__
-=head1 NAME
+=head1 CGI::Ex SYNOPSIS
-CGI::Ex - CGI utility suite (form getter/filler/validator/app builder)
+ ### You probably don't want to use CGI::Ex directly
+ ### You probably should use CGI::Ex::App instead.
-=head1 SYNOPSIS
+ my $cgix = CGI::Ex->new;
- ### CGI Module Extensions
+ $cgix->print_content_type;
- my $cgix = CGI::Ex->new;
- my $hashref = $cgix->get_form; # uses CGI by default
-
- ### send the Content-type header - whether or not we are mod_perl
- $cgix->print_content_type;
-
- my $val_hash = $cgix->conf_read($pathtovalidation);
-
- my $err_obj = $cgix->validate($hashref, $val_hash);
- if ($err_obj) {
- my $errors = $err_obj->as_hash;
- my $input = "Some content";
- my $content = "";
- SomeTemplateObject->process($input, $errors, $content);
- $cgix->fill({text => \$content, form => $hashref});
- print $content;
- exit;
- }
-
- print "Success\n";
-
- ### Filling functionality
-
- $cgix->fill({text => \$text, form => \%hash});
- $cgix->fill({text => \$text, fdat => \%hash});
- $cgix->fill({text => \$text, fobject => $cgiobject});
- $cgix->fill({text => \$text, form => [\%hash1, $cgiobject]});
- $cgix->fill({text => \$text); # uses $self->object as the form
- $cgix->fill({text => \$text,
- form => \%hash,
- target => 'formname',
- fill_password => 0,
- ignore_fields => ['one','two']});
- $cgix->fill(\$text); # uses $self->object as the form
- $cgix->fill(\$text, \%hash, 'formname', 0, ['one','two']);
- my $copy = $cgix->fill({scalarref => \$text, fdat => \%hash});
- my $copy = $cgix->fill({arrayref => \@lines, fdat => \%hash});
- my $copy = $cgix->fill({file => $filename, fdat => \%hash});
-
- ### Validation functionality
-
- my $err_obj = $cgix->validate($form, $val_hash);
- my $err_obj = $cgix->validate($form, $path_to_validation);
- my $err_obj = $cgix->validate($form, $yaml_string);
-
- ### get errors separated by key name
- ### useful for inline errors
- my $hash = $err_obj->as_hash;
- my %hash = $err_obj->as_hash;
-
- ### get aggregate list of errors
- ### useful for central error description
- my $array = $err_obj->as_array;
- my @array = $err_obj->as_array;
-
- ### get a string
- ### useful for central error description
- my $string = $err_obj->as_string;
- my $string = "$err_obj";
-
- $cgix->{raise_error} = 1;
- $cgix->validate($form, $val_hash);
- # SAME AS #
- my $err_obj = $cgix->validate($form, $val_hash);
- die $err_obj if $err_obj;
-
- ### Settings functionality
-
- ### read file via yaml
- my $ref = $cgix->conf_read('/full/path/to/conf.yaml');
-
- ### merge all found settings.pl files together
- @CGI::Ex::Conf::DEFAULT_PATHS = qw(/tmp /my/data/dir /home/foo);
- @CGI::Ex::Conf::DIRECTIVE = 'MERGE';
- @CGI::Ex::Conf::DEFAULT_EXT = 'pl';
- my $ref = $cgix->conf_read('settings');
+ 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";
+ }
=head1 DESCRIPTION
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 a framework (which normally
-includes prebuilt html) instead CGI::Ex::App is an extended application
-flow that normally dramatically reduces CGI build time. See L<CGI::Ex::App>.
-
-CGI::Ex is another form filler / validator / conf reader / template
-interface. Its goal is to take the wide scope of validators and other
-useful CGI application modules out there and merge them into one
-utility that has all of the necessary features of them all, as well
-as several extended methods that I have found useful in working on the web.
+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 L<CGI::Ex::App>.
The main functionality is provided by several other modules that
may be used separately, or together through the CGI::Ex interface.
=over 4
+=item C<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.
+
=item C<CGI::Ex::Fill>
A regular expression based form filler inner (accessed through B<-E<gt>fill>
default support for yaml, storable, perl, ini, and xml and open architecture
for definition of others. See L<CGI::Ex::Conf> for more information.
+=item C<CGI::Ex::Auth>
+
+A highly configurable web based authentication system. See L<CGI::Ex::Auth> for
+more information.
+
=back
-=head1 METHODS
+=head1 CGI::Ex METHODS
=over 4
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 modfied as a string). It will be modified in place.
+that can be modified as a string). It will be modified in place.
Another named argument B<scalarref> is available if you would like to
copy rather than modify.
multiple hashrefs, cgi objects, and coderefs. Hashes should be key
value pairs. CGI objects should be able
to call the method B<param> (This can be overrided). Coderefs should
-expect expect the field name as an argument and should return a value.
-Values returned by form may be undef, scalar, arrayref, or coderef
+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 informatin - without having to
+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.
=back
-Other named arguments are available for compatiblity with HTML::FillInForm.
+Other named arguments are available for compatibility with HTML::FillInForm.
They may only be used as named arguments.
=over 4
=item C<-E<gt>get_form>
Very similar to CGI->new->Vars except that arrays are returned as
-arrays. Not sure why CGI::Val didn't do this anyway (well - yes -
+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);
+
=item C<-E<gt>set_form>
Allow for setting a custom form hash. Useful for testing, or other
purposes.
+ $cgix->set_form(\%new_form);
+
=item C<-E<gt>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);
+
+=item C<-E<gt>set_cookies>
+
+Allow for setting a custom cookies hash. Useful for testing, or other
+purposes.
+
+ $cgix->set_cookies(\%new_cookies);
+
=item C<-E<gt>make_form>
Takes a hash and returns a query_string. A second optional argument
#$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.
=back
-=head1 EXISTING MODULES
-
-The following is a list of existing validator and formfiller modules
-at the time of this writing (I'm sure this probably isn't exaustive).
-
-=over 4
-
-=item C<Email::Valid> - Validator
-
-=item C<SSN::Validate> - Validator
-
-=item C<Embperl::Form::Validate> - Validator
-
-=item C<Data::CGIForm> - Validator
-
-=item C<HTML::FillInForm> - Form filler-iner
-
-=item C<CGI> - CGI Getter. Form filler-iner
-
-=head1 TODO
-
-Add an integrated template toolkit interface.
-
-Add an integrated debug module.
-
=head1 MODULES
-See also L<CGI::Ex::Fill>.
+See also L<CGI::Ex::App>.
-See also L<CGI::Ex::Validate>.
+See also L<CGI::Ex::Auth>.
See also L<CGI::Ex::Conf>.
See also L<CGI::Ex::Die>.
-See also L<CGI::Ex::App>.
-
See also L<CGI::Ex::Dump>.
+See also L<CGI::Ex::Fill>.
+
+See also L<CGI::Ex::Template>.
+
+See also L<CGI::Ex::Validate>.
+
=head1 AUTHOR
Paul Seamons
package CGI::Ex::App;
-### CGI Extended Application
-
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# See the perldoc in CGI/Ex/App.pod
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
-
use strict;
-use vars qw($VERSION
- $EXT_PRINT $EXT_VAL $BASE_DIR_REL $BASE_DIR_ABS $BASE_NAME_MODULE
- $RECURSE_LIMIT
- %CLEANUP_EXCLUDE);
-
-$VERSION = '1.14';
-use CGI::Ex::Dump qw(debug);
+use vars qw($VERSION);
BEGIN {
- ### Default file locations
- ### these are used for the provided stub functions - if you are not
- ### using the stub functions - then you won't need to worry about these
- $EXT_PRINT ||= 'html';
- $EXT_VAL ||= 'val';
- $BASE_DIR_REL ||= ''; # relative path - stub methods will look in $BASE_DIR_REL/dir/of/content.html
- $BASE_DIR_ABS ||= ''; # content should be found at "$BASE_DIR_ABS/$BASE_DIR_REL/dir/of/content.html"
- $BASE_NAME_MODULE ||= ''; # the cgi name
+ $VERSION = '2.00';
- ### list of modules to exclude during cleanup
- ### this takes care of situations such as
- ### template toolkits rules area which contains
- ### a nested structure of rules and sub references.
- $CLEANUP_EXCLUDE{'Template::Parser'} = 1;
+ Time::HiRes->import('time') if eval {require Time::HiRes};
}
+sub croak {
+ my $msg = shift;
+ $msg = 'Something happened' if ! defined $msg;
+ die $msg if ref $msg || $msg =~ /\n\z/;
+ my ($pkg, $file, $line, $sub) = caller(1);
+ die "$msg in ${sub}() at $file line $line\n";
+}
###----------------------------------------------------------------###
sub new {
- my $class = shift || __PACKAGE__;
- my $self = ref($_[0]) ? shift : {@_};
- bless $self, $class;
- $self->init;
- return $self;
+ my $class = shift || croak "Usage: Package->new";
+ my $self = shift || {};
+ bless $self, $class;
+
+ $self->init;
+
+ return $self;
}
sub init {}
###----------------------------------------------------------------###
sub navigate {
- my $self = shift;
- my $args = ref($_[0]) ? shift : {@_};
- $self = $self->new($args) if ! ref $self;
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
- eval {
+ $self->{'_time'} = time;
- ### a chance to do things at the very beginning
- return $self if $self->pre_navigate;
-
- ### run the step loop
eval {
- local $self->{'__morph_lineage_start_index'} = $#{$self->{'__morph_lineage'} || []};
- $self->nav_loop;
- };
- if ($@) {
- ### rethrow the error unless we long jumped out of recursive nav_loop calls
- die $@ if $@ ne "Long Jump\n";
- }
+ ### allow for authentication
+ my $ref = $self->require_auth;
+ if ($ref && ! ref $ref) {
+ return $self if ! $self->get_valid_auth;
+ }
- ### one chance to do things at the very end
- $self->post_navigate;
+ ### a chance to do things at the very beginning
+ return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate;
+
+ ### run the step loop
+ eval {
+ local $self->{'__morph_lineage_start_index'} = $#{$self->{'__morph_lineage'} || []};
+ $self->nav_loop;
+ };
+ if ($@) {
+ ### rethrow the error unless we long jumped out of recursive nav_loop calls
+ croak $@ if $@ ne "Long Jump\n";
+ }
+
+ ### one chance to do things at the very end
+ $self->post_navigate if ! $self->{'_no_post_navigate'};
- };
- ### catch errors - if any
- if ($@) {
- $self->handle_error($@);
- }
+ };
+ $self->handle_error($@) if $@; # catch any errors
+
+ $self->{'_time'} = time;
- return $self;
+ return $self;
}
sub nav_loop {
- my $self = shift;
+ my $self = shift;
- ### keep from an infinate nesting
- local $self->{recurse} = $self->{recurse} || 0;
- if ($self->{recurse} ++ >= $self->recurse_limit) {
- my $err = "recurse_limit reached (".$self->recurse_limit.")";
- $err .= " number of jumps (".$self->{jumps}.")" if ($self->{jumps} || 0) > 1;
- die $err;
- }
-
- ### get the path (simple arrayref based thing)
- my $path = $self->path;
-
- ### allow for an early return
- return if $self->pre_loop($path); # a true value means to abort the navigate
-
- ### get a hash of valid paths (if any)
- my $valid_steps = $self->valid_steps;
-
- ### iterate on each step of the path
- foreach ($self->{path_i} ||= 0;
- $self->{path_i} <= $#$path;
- $self->{path_i} ++) {
- my $step = $path->[$self->{path_i}];
- next if $step !~ /^[a-zA-Z_]\w*$/; # don't process the step if it contains odd characters
-
- ### check if this is an allowed step
- if ($valid_steps) {
- if (! $valid_steps->{$step}
- && $step ne $self->default_step
- && $step ne 'forbidden') {
- $self->stash->{'forbidden_step'} = $step;
- $self->replace_path('forbidden');
- next;
- }
+ ### keep from an infinate nesting
+ local $self->{'recurse'} = $self->{'recurse'} || 0;
+ if ($self->{'recurse'} ++ >= $self->recurse_limit) {
+ my $err = "recurse_limit (".$self->recurse_limit.") reached";
+ $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1;
+ croak $err;
}
- ### allow for becoming another package (allows for some steps in external files)
- $self->morph($step);
-
- ### run the guts of the step
- my $status = $self->run_hook('run_step', $step);
+ my $path = $self->path;
- $self->unmorph($step);
+ ### allow for an early return
+ return if $self->pre_loop($path); # a true value means to abort the navigate
- ### Allow for the run_step to intercept.
- ### A true status means the run_step took over navigation.
- return if $status;
- }
+ my $req_auth = ref($self->require_auth) ? $self->require_auth : undef;
- ### allow for one exit point after the loop
- return if $self->post_loop($path); # a true value means to abort the navigate
-
- ### run the default step as a last resort
- $self->insert_path($self->default_step);
- $self->nav_loop; # go recursive
+ ### iterate on each step of the path
+ foreach ($self->{'path_i'} ||= 0;
+ $self->{'path_i'} <= $#$path;
+ $self->{'path_i'} ++) {
+ my $step = $path->[$self->{'path_i'}];
+ if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters
+ $self->stash->{'forbidden_step'} = $step;
+ $self->replace_path($self->forbidden_step);
+ next;
+ }
+ $step = $1; # untaint
- return;
-}
+ ### allow for per-step authentication
+ if ($req_auth
+ && $req_auth->{$step}
+ && ! $self->get_valid_auth) {
+ return;
+ }
-sub pre_navigate {}
+ ### allow for becoming another package (allows for some steps in external files)
+ $self->morph($step);
-sub post_navigate {}
+ ### run the guts of the step
+ my $status = $self->run_hook('run_step', $step);
-sub recurse_limit { shift->{'recurse_limit'} || $RECURSE_LIMIT || 15 }
+ $self->unmorph($step);
-sub run_step {
- my $self = shift;
- my $step = shift;
+ ### Allow for the run_step to intercept.
+ ### A true status means the run_step took over navigation.
+ return if $status;
+ }
- ### if the pre_step exists and returns true, exit the nav_loop
- return 1 if $self->run_hook('pre_step', $step);
+ ### allow for one exit point after the loop
+ return if $self->post_loop($path); # a true value means to abort the navigate
- ### allow for skipping this step (but stay in the nav_loop)
- return 0 if $self->run_hook('skip', $step);
+ ### run the default step as a last resort
+ $self->insert_path($self->default_step);
+ $self->nav_loop; # go recursive
- ### see if we have complete valid information for this step
- ### if so, do the next step
- ### if not, get necessary info and print it out
- if ( ! $self->run_hook('prepare', $step, 1)
- || ! $self->run_hook('info_complete', $step)
- || ! $self->run_hook('finalize', $step, 1)) {
+ return;
+}
- ### show the page requesting the information
- $self->run_hook('prepared_print', $step);
+sub pre_navigate { 0 } # true means to not enter nav_loop
- ### a hook after the printing process
- $self->run_hook('post_print', $step);
+sub post_navigate {}
- return 2;
- }
+sub pre_loop { 0 } # true value means to abort the nav_loop routine
- ### a hook before end of loop
- ### if the post_step exists and returns true, exit the nav_loop
- return 1 if $self->run_hook('post_step', $step);
+sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse
- ### let the nav_loop continue searching the path
- return 0;
-}
+sub recurse_limit { shift->{'recurse_limit'} || 15 }
-### standard functions for printing - gather information
-sub prepared_print {
+### default die handler - show what happened and die (so its in the error logs)
+sub handle_error {
my $self = shift;
- my $step = shift;
-
- my $hash_base = $self->run_hook('hash_base', $step);
- my $hash_comm = $self->run_hook('hash_common', $step);
- my $hash_form = $self->run_hook('hash_form', $step);
- my $hash_fill = $self->run_hook('hash_fill', $step);
- my $hash_swap = $self->run_hook('hash_swap', $step);
- my $hash_errs = $self->run_hook('hash_errors', $step);
- $_ ||= {} foreach $hash_base, $hash_comm, $hash_form, $hash_fill, $hash_swap, $hash_errs;
-
- ### fix up errors
- $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
- foreach keys %$hash_errs;
- $hash_errs->{has_errors} = 1 if scalar keys %$hash_errs;
-
- ### layer hashes together
- my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
- my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
- $fill = {} if $self->no_fill($step);
+ my $err = shift;
- ### run the print hook - passing it the form and fill info
- $self->run_hook('print', $step, undef,
- $swap, $fill);
+ die $err;
}
-sub no_fill { shift->{'no_fill'} }
-
-sub exit_nav_loop {
- my $self = shift;
-
- ### undo morphs
- if (my $ref = $self->{'__morph_lineage'}) {
- ### use the saved index - this allows for early "morphers" to only get rolled back so far
- my $index = $self->{'__morph_lineage_start_index'};
- $index = -1 if ! defined $index;
- $self->unmorph while $#$ref != $index;
- }
+###----------------------------------------------------------------###
- ### long jump back
- die "Long Jump\n";
-}
+sub default_step { shift->{'default_step'} || 'main' }
-sub jump {
- my $self = shift;
- my $i = ($#_ == -1) ? 1 : shift;
- my $path = $self->path;
- my $path_i = $self->{path_i};
- die "Can't jump if nav_loop not started" if ! defined $path_i;
-
- ### validate where we are jumping to
- if ($i =~ /^\w+$/) {
- if ($i eq 'FIRST') {
- $i = - $path_i - 1;
- } elsif ($i eq 'LAST') {
- $i = $#$path - $path_i;
- } elsif ($i eq 'NEXT') {
- $i = 1;
- } elsif ($i eq 'CURRENT') {
- $i = 0;
- } elsif ($i eq 'PREVIOUS') {
- $i = -1;
- } else { # look for a step by that name
- for (my $j = $#$path; $j >= 0; $j --) {
- if ($path->[$j] eq $i) {
- $i = $j - $path_i;
- last;
- }
- }
- }
- }
- if ($i !~ /^-?\d+$/) {
- require Carp;
- Carp::croak("Invalid jump index ($i)");
- }
-
- ### manipulate the path to contain the new jump location
- my @replace;
- my $cut_i = $path_i + $i;
- if ($cut_i > $#$path) {
- push @replace, $self->default_step;
- } elsif ($cut_i < 0) {
- push @replace, @$path;
- } else {
- push @replace, @$path[$cut_i .. $#$path];
- }
- $self->replace_path(@replace);
-
- ### record the number of jumps
- $self->{jumps} ||= 0;
- $self->{jumps} ++;
-
- ### run the newly fixed up path (recursively)
- $self->{path_i} ++; # move along now that the path is updated
- $self->nav_loop;
- $self->exit_nav_loop;
-}
-
-sub default_step {
- my $self = shift;
- return $self->{'default_step'} || 'main';
-}
+sub js_step { shift->{'js_step'} || 'js' }
-###----------------------------------------------------------------###
+sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' }
-sub step_key {
- my $self = shift;
- return $self->{'step_key'} || 'step';
-}
+sub step_key { shift->{'step_key'} || 'step' }
-### determine the path to follow
sub path {
- my $self = shift;
- return $self->{path} ||= do {
- my @path = (); # default to empty path
- my $step_key = $self->step_key;
-
- if (my $step = $self->form->{$step_key}) {
- push @path, $step;
- } elsif ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|) {
- push @path, lc($1);
+ my $self = shift;
+ if (! $self->{'path'}) {
+ my $path = $self->{'path'} = []; # empty path
+
+ my $step = $self->form->{ $self->step_key };
+ $step = lc($1) if ! $step && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|;
+
+ ### make sure the step is valid
+ if (defined $step) {
+ if ($step =~ /^_/) { # can't begin with _
+ $self->stash->{'forbidden_step'} = $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;
+ } else {
+ push @$path, $step;
+ }
+ }
}
- \@path; # return of the do
- };
+ return $self->{'path'};
}
-### really should only be used during initialization
sub set_path {
- my $self = shift;
- my $path = $self->{path} ||= [];
- die "Cannot call set_path after the navigation loop has begun" if $self->{path_i};
- splice @$path, 0, $#$path + 1, @_; # change entries in the ref
+ my $self = shift;
+ my $path = $self->{'path'} ||= [];
+ croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'};
+ splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref)
}
### legacy - same as append_path
sub add_to_path {
- my $self = shift;
- push @{ $self->path }, @_;
+ my $self = shift;
+ push @{ $self->path }, @_;
}
-### append entries onto the end
sub append_path {
- my $self = shift;
- push @{ $self->path }, @_;
+ my $self = shift;
+ push @{ $self->path }, @_;
}
-### replace all entries that are left
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
- }
+ 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
+ }
}
-### insert more steps into the current path
sub insert_path {
- my $self = shift;
- my $ref = $self->path;
- my $i = $self->{path_i} || 0;
- if ($i + 1 > $#$ref) {
- push @$ref, @_;
- } else {
- splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
- }
+ my $self = shift;
+ my $ref = $self->path;
+ my $i = $self->{'path_i'} || 0;
+ if ($i + 1 > $#$ref) {
+ push @$ref, @_;
+ } else {
+ splice(@$ref, $i + 1, 0, @_); # insert a path at the current location
+ }
}
-### a hash of paths that are allowed, default undef is all
+### a hash of paths that are allowed, default undef is all are allowed
sub valid_steps {}
###----------------------------------------------------------------###
-### allow for checking where we are in the path
+### allow for checking where we are in the path and for jumping around
+
+sub exit_nav_loop {
+ my $self = shift;
+
+ ### undo morphs
+ if (my $ref = $self->{'__morph_lineage'}) {
+ ### use the saved index - this allows for early "morphers" to only get rolled back so far
+ my $index = $self->{'__morph_lineage_start_index'};
+ $index = -1 if ! defined $index;
+ $self->unmorph while $#$ref != $index;
+ }
+
+ ### long jump back
+ die "Long Jump\n";
+}
+
+sub jump {
+ my $self = shift;
+ my $i = @_ == 1 ? shift : 1;
+ my $path = $self->path;
+ my $path_i = $self->{'path_i'};
+ croak "Can't jump if nav_loop not started" if ! defined $path_i;
+
+ ### validate where we are jumping to
+ if ($i =~ /^\w+$/) {
+ if ($i eq 'FIRST') {
+ $i = - $path_i - 1;
+ } elsif ($i eq 'LAST') {
+ $i = $#$path - $path_i;
+ } elsif ($i eq 'NEXT') {
+ $i = 1;
+ } elsif ($i eq 'CURRENT') {
+ $i = 0;
+ } elsif ($i eq 'PREVIOUS') {
+ $i = -1;
+ } else { # look for a step by that name
+ for (my $j = $#$path; $j >= 0; $j --) {
+ if ($path->[$j] eq $i) {
+ $i = $j - $path_i;
+ last;
+ }
+ }
+ }
+ }
+ if ($i !~ /^-?\d+$/) {
+ require Carp;
+ Carp::croak("Invalid jump index ($i)");
+ }
+
+ ### manipulate the path to contain the new jump location
+ my @replace;
+ my $cut_i = $path_i + $i;
+ if ($cut_i > $#$path) {
+ push @replace, $self->default_step;
+ } elsif ($cut_i < 0) {
+ push @replace, @$path;
+ } else {
+ push @replace, @$path[$cut_i .. $#$path];
+ }
+ $self->replace_path(@replace);
+
+ ### record the number of jumps
+ $self->{'jumps'} ||= 0;
+ $self->{'jumps'} ++;
+
+ ### run the newly fixed up path (recursively)
+ $self->{'path_i'} ++; # move along now that the path is updated
+ $self->nav_loop;
+ $self->exit_nav_loop;
+}
sub step_by_path_index {
- my $self = shift;
- my $i = shift || 0;
- my $ref = $self->path;
- return '' if $i < 0;
- return $self->default_step if $i > $#$ref;
- return $ref->[$i];
+ my $self = shift;
+ my $i = shift || 0;
+ my $ref = $self->path;
+ return '' if $i < 0;
+ return $self->default_step if $i > $#$ref;
+ return $ref->[$i];
}
sub previous_step {
- my $self = shift;
- die "previous_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) - 1 );
+ my $self = shift;
+ croak "previous_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 );
}
sub current_step {
- my $self = shift;
- die "current_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) );
+ my $self = shift;
+ croak "current_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( ($self->{'path_i'} || 0) );
}
sub next_step {
- my $self = shift;
- die "next_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( ($self->{path_i} || 0) + 1 );
+ my $self = shift;
+ croak "next_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 );
}
sub last_step {
- my $self = shift;
- die "last_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( $#{ $self->path } );
+ my $self = shift;
+ croak "last_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( $#{ $self->path } );
}
sub first_step {
- my $self = shift;
- die "first_step is readonly" if $#_ != -1;
- return $self->step_by_path_index( 0 );
+ my $self = shift;
+ croak "first_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( 0 );
}
###----------------------------------------------------------------###
+### hooks and history
+
+sub find_hook {
+ my $self = shift;
+ my $hook = shift || do { require Carp; Carp::confess("Missing hook name") };
+ my $step = shift || '';
+ my $code;
+ if ($step && ($code = $self->can("${step}_${hook}"))) {
+ return [$code, "${step}_${hook}"],
+
+ } elsif ($code = $self->can($hook)) {
+ return [$code, $hook];
+
+ } else {
+ return [];
+
+ }
+}
-sub pre_loop {}
-sub post_loop {}
-
-### return the appropriate hook to call
-sub hook {
- my $self = shift;
- my $hook = shift || do { require Carp; Carp::confess("Missing hook name") };
- my $step = shift || '';
- my $default = shift;
- my $hist = $self->history;
- my $code;
- if ($step && ($code = $self->can("${step}_${hook}"))) {
- push @$hist, "$step - $hook - ${step}_${hook}";
- return $code;
- } elsif ($code = $self->can($hook)) {
- push @$hist, "$step - $hook - $hook";
- return $code;
- } elsif (UNIVERSAL::isa($default, 'CODE')) {
- push @$hist, "$step - $hook - DEFAULT CODE";
- return $default;
- } elsif ($default) {
- push @$hist, "$step - $hook - DEFAULT";
- return sub { return $default };
- } else {
- return sub {};
- }
-}
-
-### get and call the appropriate hook
sub run_hook {
- my $self = shift;
- my $hook = shift;
- my $step = shift;
- my $default = shift;
- my $code = $self->hook($hook, $step, $default);
- return $self->$code($step, @_);
+ my $self = shift;
+ my $hook = shift;
+ my $step = shift;
+
+ my ($code, $found) = @{ $self->find_hook($hook, $step) };
+ if (! $code) {
+ croak "Could not find a method named ${step}_${hook} or ${hook}";
+ }
+
+
+ ### record history
+ my $hist = {
+ step => $step,
+ meth => $hook,
+ found => $found,
+ time => time,
+ };
+
+ push @{ $self->history }, $hist;
+
+ $hist->{'level'} = $self->{'_level'};
+ local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
+
+ $hist->{'elapsed'} = time - $hist->{'time'};
+
+ my $resp = $self->$code($step, @_);
+
+ $hist->{'elapsed'} = time - $hist->{'time'};
+ $hist->{'response'} = $resp;
+
+ return $resp;
}
sub history {
return shift->{'history'} ||= [];
}
-### default die handler - show what happened and die (so its in the error logs)
-sub handle_error {
- my $self = shift;
- my $err = shift;
- debug $err, $self->path, $self->history;
- die $err;
+sub dump_history {
+ my $self = shift;
+ my $all = shift || 0;
+ my $hist = $self->history;
+ my $dump = [];
+ push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
+
+ ### show terse - yet informative info
+ foreach my $row (@$hist) {
+ if (! ref($row)
+ || ref($row) ne 'HASH'
+ || ! exists $row->{'elapsed'}) {
+ push @$dump, $row;
+ } else {
+ my $note = (' ' x ($row->{'level'} || 0))
+ . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
+ my $resp = $row->{'response'};
+ if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
+ $note .= ' - {}';
+ } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
+ $note .= ' - []';
+ } elsif (! ref $resp || ! $all) {
+ my $max = $self->{'history_max'} || 30;
+ if (length($resp) > $max) {
+ $resp = substr($resp, 0, $max);
+ $resp =~ s/\n.+//s;
+ $resp = "$resp ...";
+ }
+ $note .= " - $resp";
+ } else {
+ $note = [$note, $resp];
+ }
+
+ push @$dump, $note;
+ }
+ }
+
+ return $dump;
}
###----------------------------------------------------------------###
-### utility modules for jeckyl/hyde on self
+### utility methods to allow for storing separate steps in other modules
sub allow_morph {
my $self = shift;
}
sub morph {
- my $self = shift;
- my $step = shift || return;
- return if ! (my $allow = $self->allow_morph); # not true
-
- ### place to store the lineage
- 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 $hist = $self->history;
- push @$hist, "$step - morph - morph";
- my $sref = \$hist->[-1]; # get ref so we can add more info in a moment
-
- if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
- $$sref .= " - not allowed to morph to that step";
- return;
- }
-
- ### make sure we haven't already been reblessed
- if ($#$lin != 0 # is this the second morph call
- && (! ($allow = $self->allow_nested_morph) # not true
- || (ref($allow) && ! $allow->{$step}) # hash - but no step
- )) {
- $$sref .= $allow ? " - not allowed to nested_morph to that step" : " - nested_morph disabled";
- return; # just return - don't die so that we can morph early
- }
-
- ### if we are not already that package - bless us there
- my $new = $self->run_hook('morph_package', $step);
- if ($cur ne $new) {
- my $file = $new .'.pm';
- $file =~ s|::|/|g;
- if (UNIVERSAL::can($new, 'can') # check if the package space exists
- || eval { require $file }) { # check for a file that holds this package
- ### become that package
- bless $self, $new;
- $$sref .= " - changed $cur to $new";
- if (my $method = $self->can('fixup_after_morph')) {
- $self->$method($step);
- }
- } else {
- if ($@) {
- if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
- $$sref .= " - failed from $cur to $new: $1";
+ my $self = shift;
+ my $step = shift || return;
+ return if ! (my $allow = $self->allow_morph($step));
+
+ ### place to store the lineage
+ 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 $hist = {
+ step => $step,
+ meth => 'morph',
+ found => 'morph',
+ time => time,
+ elapsed => 0,
+ };
+ push @{ $self->history }, $hist;
+
+ if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
+ $hist->{'found'} .= " (not allowed to morph to that step)";
+ return;
+ }
+
+ ### 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; # just return - don't die so that we can morph early
+ }
+
+ ### if we are not already that package - bless us there
+ my $new = $self->run_hook('morph_package', $step);
+ if ($cur ne $new) {
+ my $file = $new .'.pm';
+ $file =~ s|::|/|g;
+ if (UNIVERSAL::can($new, 'can') # check if the package space exists
+ || eval { require $file }) { # check for a file that holds this package
+ ### become that package
+ bless $self, $new;
+ $hist->{'found'} .= " (changed $cur to $new)";
+ $self->fixup_after_morph($step);
} else {
- $$sref .= " - failed from $cur to $new: $@";
- my $err = "Trouble while morphing to $file: $@";
- debug $err;
- warn $err;
+ if ($@) {
+ if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened
+ $hist->{'found'} .= " (failed from $cur to $new: $1)";
+ } else {
+ $hist->{'found'} .= " (failed from $cur to $new: $@)";
+ my $err = "Trouble while morphing to $file: $@";
+ warn $err;
+ }
+ }
}
- }
}
- }
}
sub unmorph {
- my $self = shift;
- my $step = shift || '__no_step';
- my $lin = $self->{'__morph_lineage'} || return;
- my $cur = ref $self;
- my $prev = pop(@$lin) || die "unmorph called more times than morph - current ($cur)";
-
- ### if we are not already that package - bless us there
- my $hist = $self->history;
- if ($cur ne $prev) {
- if (my $method = $self->can('fixup_before_unmorph')) {
- $self->$method($step);
+ my $self = shift;
+ my $step = shift || '__no_step';
+ my $lin = $self->{'__morph_lineage'} || return;
+ my $cur = ref $self;
+
+ my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
+ delete $self->{'__morph_lineage'} if ! @$lin;
+
+ ### if we are not already that package - bless us there
+ my $hist = {
+ step => $step,
+ meth => 'unmorph',
+ found => 'unmorph',
+ time => time,
+ elapsed => 0,
+ };
+ push @{ $self->history }, $hist;
+
+ if ($cur ne $prev) {
+ $self->fixup_before_unmorph($step);
+ bless $self, $prev;
+ $hist->{'found'} .= " (changed from $cur to $prev)";
+ } else {
+ $hist->{'found'} .= " (already isa $cur)";
}
- bless $self, $prev;
- push @$hist, "$step - unmorph - unmorph - changed from $cur to $prev";
- } else {
- push @$hist, "$step - unmorph - unmorph - already isa $cur";
- }
- return $self;
+ return $self;
}
+sub fixup_after_morph {}
+
+sub fixup_before_unmorph {}
+
###----------------------------------------------------------------###
-### allow for cleanup including deep nested objects
+### allow for authentication
-sub cleanup {
- my $self = shift;
- ref($self)->cleanup_cross_references($self);
-}
-
-sub cleanup_cross_references {
- my $class = shift;
- my $self = shift;
- my $seen = shift || {};
- return if $seen->{$self}; # prevent recursive checking
- $seen->{$self} = 1;
- return if $CLEANUP_EXCLUDE{ ref($self) };
- if (UNIVERSAL::isa($self, 'HASH')) {
- require Scalar::Util; # first self will always be hash
- foreach my $key (keys %$self) {
- next if ! $self->{$key};
- $class->cleanup_cross_references($self->{$key}, $seen);
- # weaken and remove blessed objects
- # this will clober objects in global caches that are referenced in the structure
- # so beware (that means weaken your cached references)
- if (Scalar::Util::blessed($self->{$key})
- && ! Scalar::Util::isweak($self->{$key})) {
- Scalar::Util::weaken($self->{$key});
- $self->{$key} = undef;
- } elsif (UNIVERSAL::isa($self->{$key}, 'CODE')) {
- $self->{$key} = undef;
- }
- }
- } elsif (UNIVERSAL::isa($self, 'ARRAY')) {
- for my $key (0 .. $#$self) {
- next if ! $self->[$key];
- $class->cleanup_cross_references($self->[$key], $seen);
- if (Scalar::Util::blessed($self->[$key])
- && ! Scalar::Util::isweak($self->[$key])) {
- Scalar::Util::weaken($self->[$key]);
- $self->[$key] = undef;
- } elsif (UNIVERSAL::isa($self->[$key], 'CODE')) {
- $self->[$key] = undef;
- }
- }
- }
+sub navigate_authenticated {
+ my ($self, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
+
+ $self->require_auth(1);
+
+ return $self->navigate;
}
+sub require_auth {
+ my $self = shift;
+ $self->{'require_auth'} = shift if @_ == 1;
+ return $self->{'require_auth'};
+}
+
+sub is_authed { shift->auth_data }
+
+sub auth_data {
+ my $self = shift;
+ $self->{'auth_data'} = shift if @_ == 1;
+ return $self->{'auth_data'};
+}
+
+sub get_valid_auth {
+ my $self = shift;
+ return 1 if $self->is_authed;
+
+ ### augment the args with sensible defaults
+ my $args = $self->auth_args;
+ $args->{'cgix'} ||= $self->cgix;
+ $args->{'form'} ||= $self->form;
+ $args->{'cookies'} ||= $self->cookies;
+ $args->{'js_uri_path'} ||= $self->js_uri_path;
+ $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
+ $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
+ $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
+ $args->{'login_print'} ||= sub {
+ my ($auth, $template, $hash) = @_;
+ my $out = $self->run_hook('swap_template', '__login', $template, $hash);
+ $self->run_hook('fill_template', '__login', \$out, $hash);
+ $self->run_hook('print_out', '__login', $out);
+ };
+
+ require CGI::Ex::Auth;
+ my $obj = CGI::Ex::Auth->new($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
+
+ return ($resp && $data) ? 1 : 0;
+}
+
+sub auth_args { {} }
+
+sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
+sub cleanup_user { my ($self, $user) = @_; $user }
+sub verify_user { 1 }
+
###----------------------------------------------------------------###
### a few standard base accessors
sub form {
- my $self = shift;
- if ($#_ != -1) {
- $self->{form} = shift || die "Invalid form";
- }
- return $self->{form} ||= $self->cgix->get_form;
+ my $self = shift;
+ $self->{'form'} = shift if @_ == 1;
+ return $self->{'form'} ||= $self->cgix->get_form;
}
sub cookies {
- my $self = shift;
- if ($#_ != -1) {
- $self->{cookies} = shift || die "Invalid cookies";
- }
- return $self->{cookies} ||= $self->cgix->get_cookies;
+ my $self = shift;
+ $self->{'cookies'} = shift if @_ == 1;
+ return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
sub cgix {
- my $self = shift;
- return $self->{cgix} ||= do {
- my $args = shift || {};
- require CGI::Ex;
- CGI::Ex->new($args); # return of the do
- };
-}
-
-sub set_cgix {
- my $self = shift;
- $self->{cgix} = shift;
+ my $self = shift;
+ $self->{'cgix'} = shift if @_ == 1;
+ return $self->{'cgix'} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new; # return of the do
+ };
}
sub vob {
- my $self = shift;
- return $self->{vob} ||= do {
- my $args = shift || {};
- $args->{cgix} ||= $self->cgix;
- require CGI::Ex::Validate;
- CGI::Ex::Validate->new($args); # return of the do
- };
-}
-
-sub set_vob {
- my $self = shift;
- $self->{vob} = shift;
-}
-
-sub auth {
- my $self = shift;
- return $self->{auth} ||= do {
- my $args = shift || {};
- $args->{cgix} ||= $self->cgix,
- $args->{form} ||= $self->form,
- $args->{cookies} ||= $self->cookies,
- require CGI::Ex::Auth;
- CGI::Ex::Auth->new($args); # return of the do
- };
+ my $self = shift;
+ $self->{'vob'} = shift if @_ == 1;
+ return $self->{'vob'} ||= do {
+ require CGI::Ex::Validate;
+ CGI::Ex::Validate->new($self->vob_args); # return of the do
+ };
}
-sub set_auth {
- my $self = shift;
- $self->{auth} = shift;
+sub vob_args {
+ my $self = shift;
+ return {
+ cgix => $self->cgix,
+ };
}
### provide a place for placing variables
sub stash {
- my $self = shift;
- return $self->{'stash'} ||= {};
-}
-
-### allow for adding arbitrary values to self
-sub add_property {
- my $self = shift;
- my $prop = shift;
- my $key = '__prop_'. $prop;
- my $name = __PACKAGE__ ."::". $prop;
- no strict 'refs';
- *$name = sub : lvalue {
my $self = shift;
- $self->{$key} = shift() if $#_ != -1;
- $self->{$key};
- } if ! defined &$name;
- $self->$prop(shift()) if $#_ != -1;
+ return $self->{'stash'} ||= {};
}
###----------------------------------------------------------------###
-### js_validation items
+### default hook implementations
-### creates javascript suitable for validating the form
-sub js_validation {
- my $self = shift;
- my $step = shift;
- return '' if $self->ext_val eq 'htm'; # let htm validation do it itself
+sub run_step {
+ my $self = shift;
+ my $step = shift;
- my $form_name = shift || $self->run_hook('form_name', $step);
- my $hash_val = shift || $self->run_hook('hash_validation', $step, {});
- my $js_uri = $self->js_uri_path;
- return '' if UNIVERSAL::isa($hash_val, 'HASH') && ! scalar keys %$hash_val
- || UNIVERSAL::isa($hash_val, 'ARRAY') && $#$hash_val == -1;
+ ### if the pre_step exists and returns true, exit the nav_loop
+ return 1 if $self->run_hook('pre_step', $step);
- return $self->vob->generate_js($hash_val, $form_name, $js_uri);
-}
+ ### allow for skipping this step (but stay in the nav_loop)
+ return 0 if $self->run_hook('skip', $step);
-### where to find the javascript files
-### default to using this script as a handler
-sub js_uri_path {
- my $self = shift;
- my $script = $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME";
- return ($self->can('path') == \&CGI::Ex::App::path)
- ? $script . '/js' # try to use a cache friendly URI (if path is our own)
- : $script . '?'.$self->step_key.'=js&js='; # use one that works with more paths
-}
+ ### see if we have complete valid information for this step
+ ### if so, do the next step
+ ### if not, get necessary info and print it out
+ if ( ! $self->run_hook('prepare', $step)
+ || ! $self->run_hook('info_complete', $step)
+ || ! $self->run_hook('finalize', $step)) {
-### name to attach js validation to
-sub form_name { 'theform' }
+ ### show the page requesting the information
+ $self->run_hook('prepared_print', $step);
-### provide some rudimentary javascript support
-### if valid_steps is defined - it should include "js"
-sub js_run_step {
- my $self = shift;
+ ### a hook after the printing process
+ $self->run_hook('post_print', $step);
- ### make sure path info looks like /js/CGI/Ex/foo.js
- my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
- $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
+ return 1;
+ }
- $self->cgix->print_js($file);
- return 1; # intercepted
+ ### a hook before end of loop
+ ### if the post_step exists and returns true, exit the nav_loop
+ return 1 if $self->run_hook('post_step', $step);
+
+ ### let the nav_loop continue searching the path
+ return 0;
}
-###----------------------------------------------------------------###
-### implementation specific subs
+sub prepared_print {
+ my $self = shift;
+ my $step = shift;
-sub template_args {
- my $self = shift;
- my $step = shift;
- return {
- INCLUDE_PATH => $self->base_dir_abs,
- };
+ my $hash_base = $self->run_hook('hash_base', $step) || {};
+ my $hash_comm = $self->run_hook('hash_common', $step) || {};
+ my $hash_form = $self->run_hook('hash_form', $step) || {};
+ my $hash_fill = $self->run_hook('hash_fill', $step) || {};
+ my $hash_swap = $self->run_hook('hash_swap', $step) || {};
+ my $hash_errs = $self->run_hook('hash_errors', $step) || {};
+
+ ### fix up errors
+ $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
+ foreach keys %$hash_errs;
+ $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
+
+ ### layer hashes together
+ my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
+ my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
+
+ ### run the print hook - passing it the form and fill info
+ $self->run_hook('print', $step, $swap, $fill);
}
sub print {
- my $self = shift;
- my $step = shift;
- my $swap = shift;
- my $fill = shift;
+ my ($self, $step, $swap, $fill) = @_;
- ### get a filename relative to base_dir_abs
- my $file = $self->run_hook('file_print', $step);
+ my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs
- require Template;
- my $t = Template->new($self->template_args($step));
+ my $out = $self->run_hook('swap_template', $step, $file, $swap);
- ### process the document
- my $out = '';
- my $status = $t->process($file, $swap, \$out) || die $Template::ERROR;
+ $self->run_hook('fill_template', $step, \$out, $fill);
- ### fill in any forms
- $self->cgix->fill(\$out, $fill) if $fill && ! $self->{no_fill};
-
- ### now print
- $self->cgix->print_content_type();
- print $out;
+ $self->run_hook('print_out', $step, $out);
}
-sub base_dir_rel {
- my $self = shift;
- $self->{base_dir_rel} = shift if $#_ != -1;
- return $self->{base_dir_rel} ||= $BASE_DIR_REL;
-}
+sub print_out {
+ my ($self, $step, $out) = @_;
-sub base_dir_abs {
- my $self = shift;
- $self->{base_dir_abs} = shift if $#_ != -1;
- return $self->{base_dir_abs} || $BASE_DIR_ABS
- || die "\$BASE_DIR_ABS not set for use in stub functions";
+ $self->cgix->print_content_type();
+ print $out;
}
-sub ext_val {
- my $self = shift;
- $self->{ext_val} = shift if $#_ != -1;
- return $self->{ext_val} || $EXT_VAL || die "\$EXT_VAL not set for use in stub functions";
-}
+sub swap_template {
+ my ($self, $step, $file, $swap) = @_;
-sub ext_print {
- my $self = shift;
- $self->{ext_print} = shift if $#_ != -1;
- return $self->{ext_print} || $EXT_PRINT || die "\$EXT_PRINT not set for use in stub functions";
+ require CGI::Ex::Template;
+ my $args = $self->run_hook('template_args', $step);
+ my $t = CGI::Ex::Template->new($args);
+
+ my $out = '';
+ $t->process($file, $swap, \$out) || die $t->error;
+
+ return $out;
}
-sub has_errors {
- my $self = shift;
- return 1 if scalar keys %{ $self->hash_errors };
+sub template_args {
+ my $self = shift;
+ my $step = shift;
+ return {
+ INCLUDE_PATH => sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" },
+ };
}
-sub format_error {
- my $self = shift;
- my $error = shift;
-# return $error if $error =~ /<span/i;
-# return "<span class=\"error\">$error</span>";
+sub fill_template {
+ my ($self, $step, $outref, $fill) = @_;
+
+ return if ! $fill;
+
+ my $args = $self->run_hook('fill_args', $step);
+ local $args->{'text'} = $outref;
+ local $args->{'form'} = $fill;
+
+ require CGI::Ex::Fill;
+ CGI::Ex::Fill::fill($args);
}
-###----------------------------------------------------------------###
-### default stub subs
+sub fill_args { {} }
-### used for looking up a module to morph into
-sub morph_package {
- my $self = shift;
- my $step = shift || '';
- my $cur = ref $self; # default to using self as the base for morphed modules
- my $new = $cur .'::'. $step;
- $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
- return $new;
+sub pre_step { 0 } # success indicates we handled step (don't continue step or loop)
+sub skip { 0 } # success indicates to skip the step (and continue loop)
+sub prepare { 1 } # failure means show step
+sub finalize { 1 } # failure means show step
+sub post_print { 0 } # success indicates we handled step (don't continue loop)
+sub post_step { 0 } # success indicates we handled step (don't continue step or loop)
+
+sub name_step {
+ my ($self, $step) = @_;
+ return $step;
}
-sub base_name_module {
- my $self = shift;
- $self->{base_name_module} = shift if $#_ != -1;
- return $self->{base_name_module} ||= $BASE_NAME_MODULE;
+sub morph_package {
+ my $self = shift;
+ my $step = shift || '';
+ my $cur = ref $self; # default to using self as the base for morphed modules
+ my $new = $cur .'::'. $step;
+ $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName
+ return $new;
}
-### used for looking up template content
sub name_module {
- my $self = shift;
- my $step = shift || '';
- my $name;
- if ($name = $self->base_name_module) {
- return $name;
- } else {
- return ($0 =~ m/(\w+)(\.\w+)?$/) ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl
- : die "Couldn't determine module name from \"name_module\" lookup ($step)";
- }
+ my $self = shift;
+ my $step = shift || '';
+
+ return $self->{'name_module'} ||= do {
+ # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo"
+ my $script = $ENV{'SCRIPT_NAME'} || $0;
+ $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)";
+ $1; # return of the do
+ };
}
-### which file is used for templating
sub file_print {
- my $self = shift;
- my $step = shift;
+ my $self = shift;
+ my $step = shift;
- my $base_dir_rel = $self->base_dir_rel;
- my $module = $self->run_hook('name_module', $step);
- my $_step = $self->run_hook('name_step', $step, $step);
- my $ext = $self->ext_print;
+ my $base_dir = $self->base_dir_rel;
+ my $module = $self->run_hook('name_module', $step);
+ my $_step = $self->run_hook('name_step', $step) || die "Missing name_step";
+ $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/;
- return "$base_dir_rel/$module/$_step.$ext";
+ foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
+
+ return $base_dir . $module . $_step;
}
-### which file is used for validation
sub file_val {
- my $self = shift;
- my $step = shift;
+ my $self = shift;
+ my $step = shift;
- my $base_dir = $self->base_dir_rel;
- my $module = $self->run_hook('name_module', $step);
- my $_step = $self->run_hook('name_step', $step, $step);
- my $ext = $self->ext_val;
+ my $abs = $self->base_dir_abs || return {};
+ my $base_dir = $self->base_dir_rel;
+ my $module = $self->run_hook('name_module', $step);
+ my $_step = $self->run_hook('name_step', $step);
+ $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/;
- ### get absolute if necessary
- if ($base_dir !~ m|^/|) {
- $base_dir = $self->base_dir_abs . "/$base_dir";
- }
+ foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| }
- return "$base_dir/$module/$_step.$ext";
+ return $abs . $base_dir . $module . $_step;
}
-
sub info_complete {
- my $self = shift;
- my $step = shift;
-
- return 0 if ! $self->run_hook('ready_validate', $step);
+ my $self = shift;
+ my $step = shift;
- return $self->run_hook('validate', $step);
+ return 0 if ! $self->run_hook('ready_validate', $step);
+ return 0 if ! $self->run_hook('validate', $step);
+ return 1;
}
sub ready_validate {
- my $self = shift;
- my $step = shift;
+ my $self = shift;
+ my $step = shift;
- ### could do a slightly more complex test
- return 0 if ! $ENV{REQUEST_METHOD} || $ENV{REQUEST_METHOD} ne 'POST';
- return 1;
+ return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0;
}
sub set_ready_validate {
- my $self = shift;
- my $ready = shift;
- $ENV{REQUEST_METHOD} = ($ready) ? 'POST' : 'GET';
+ my ($self, $ready) = @_;
+ $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET';
}
sub validate {
- my $self = shift;
- my $step = shift;
- my $form = shift || $self->form;
- my $hash = $self->run_hook('hash_validation', $step, {});
- my $what_was_validated = [];
-
- my $eob = eval { $self->vob->validate($form, $hash, $what_was_validated) };
- if (! $eob && $@) {
- die "Step $step: $@";
- }
-
- ### had an error - store the errors and return false
- if ($eob) {
- $self->add_errors($eob->as_hash({
- as_hash_join => "<br>\n",
- as_hash_suffix => '_error',
- }));
- return 0;
- }
-
- ### allow for the validation to give us some redirection
- my $val;
- OUTER: foreach my $ref (@$what_was_validated) {
- foreach my $method (qw(append_path replace_path insert_path)) {
- next if ! ($val = $ref->{$method});
- $self->$method(ref $val ? @$val : $val);
- last OUTER;
+ my $self = shift;
+ my $step = shift;
+ my $form = shift || $self->form;
+ my $hash = $self->run_hook('hash_validation', $step);
+ my $what_was_validated = [];
+
+ my $err_obj = eval { $self->vob->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;
}
- }
- return 1;
+ ### 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;
+}
+
+### creates javascript suitable for validating the form
+sub js_validation {
+ my $self = shift;
+ my $step = shift;
+ return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself
+
+ my $form_name = shift || $self->run_hook('form_name', $step);
+ my $hash_val = shift || $self->run_hook('hash_validation', $step);
+ my $js_uri = $self->js_uri_path;
+ return '' if UNIVERSAL::isa($hash_val, 'HASH') && ! scalar keys %$hash_val
+ || UNIVERSAL::isa($hash_val, 'ARRAY') && ! @$hash_val;
+
+ return $self->vob->generate_js($hash_val, $form_name, $js_uri);
}
-### allow for using ConfUtil instead of yaml
+sub form_name { 'theform' }
+
sub hash_validation {
- my $self = shift;
- my $step = shift;
- return $self->{hash_validation}->{$step} ||= do {
- my $hash;
- my $file = $self->run_hook('file_val', $step);
+ my ($self, $step) = @_;
- ### allow for returning the validation hash in the filename
- ### a scalar ref means it is a yaml document to be read by get_validation
- if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
- $hash = $file;
+ return $self->{'hash_validation'}->{$step} ||= do {
+ my $hash;
+ my $file = $self->run_hook('file_val', $step);
- ### read the file - it it fails - errors should shown in the error logs
- } elsif ($file) {
- $hash = eval { $self->vob->get_validation($file) } || {};
+ ### allow for returning the validation hash in the filename
+ ### a scalar ref means it is a yaml document to be read by get_validation
+ if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) {
+ $hash = $file;
- } else {
- $hash = {};
- }
+ ### read the file - if it fails - errors should be in the webserver error logs
+ } elsif ($file) {
+ $hash = eval { $self->vob->get_validation($file) } || {};
+
+ } else {
+ $hash = {};
+ }
- $hash; # return of the do
+ $hash; # return of the do
};
}
sub hash_base {
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{'SCRIPT_NAME'} || $0,
- path_info => $ENV{'PATH_INFO'} || '',
- js_validation => sub { $self->run_hook('js_validation', $step, shift) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
+ my ($self, $step) = @_;
+
+ return $self->{'hash_base'} ||= do {
+ ### create a weak copy of self to use in closures
+ my $copy;
+ if (eval {require Scalar::Util} && defined &Scalar::Util::weaken) {
+ $copy = $self;
+ Scalar::Util::weaken($copy);
+ } else {
+ $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8)
+ }
+
+ my $hash = {
+ script_name => $ENV{'SCRIPT_NAME'} || $0,
+ path_info => $ENV{'PATH_INFO'} || '',
+ js_validation => sub { $copy->run_hook('js_validation', $step, shift) },
+ form_name => sub { $copy->run_hook('form_name', $step) },
+ $self->step_key => $step,
+ }; # return of the do
+ };
}
sub hash_common { shift->{'hash_common'} ||= {} }
sub hash_swap { shift->{'hash_swap'} ||= {} }
sub hash_errors { shift->{'hash_errors'} ||= {} }
+###----------------------------------------------------------------###
+### routines to support the base hooks
+
sub add_errors {
- my $self = shift;
- my $hash = $self->hash_errors;
- my $args = ref($_[0]) ? shift : {@_};
- foreach my $key (keys %$args) {
- my $_key = ($key =~ /error$/) ? $key : "${key}_error";
- if ($hash->{$_key}) {
- $hash->{$_key} .= '<br>' . $args->{$key};
- } else {
- $hash->{$_key} = $args->{$key};
+ my $self = shift;
+ my $hash = $self->hash_errors;
+ my $args = ref($_[0]) ? shift : {@_};
+ foreach my $key (keys %$args) {
+ my $_key = ($key =~ /error$/) ? $key : "${key}_error";
+ if ($hash->{$_key}) {
+ $hash->{$_key} .= '<br>' . $args->{$key};
+ } else {
+ $hash->{$_key} = $args->{$key};
+ }
}
- }
- $hash->{'has_errors'} = 1;
+ $hash->{'has_errors'} = 1;
+}
+
+sub has_errors { scalar keys %{ shift->hash_errors } }
+
+sub format_error {
+ my ($self, $error) = @_;
+ return $error;
}
sub add_to_errors { shift->add_errors(@_) }
sub add_to_base { my $self = shift; $self->add_to_hash($self->hash_base, @_) }
sub add_to_hash {
- my $self = shift;
- my $old = shift;
- my $new = shift;
- $new = {$new, @_} if ! ref $new; # non-hashref
- $old->{$_} = $new->{$_} foreach keys %$new;
+ my $self = shift;
+ my $old = shift;
+ my $new = shift;
+ $new = {$new, @_} if ! ref $new; # non-hashref
+ $old->{$_} = $new->{$_} foreach keys %$new;
}
-###----------------------------------------------------------------###
-
-sub forbidden_info_complete { 0 }
-sub forbidden_file_print {
- my $self = shift;
- my $step = $self->stash->{'forbidden_step'};
- my $str = "You do not have access to \"$step\"";
- return \$str;
+sub base_dir_rel {
+ my $self = shift;
+ $self->{'base_dir_rel'} = shift if $#_ != -1;
+ return $self->{'base_dir_rel'} || '';
}
-###----------------------------------------------------------------###
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI::Ex::App - Full featured (within reason) application builder.
-
-=head1 DESCRIPTION
-
-Fill in the blanks and get a ready made CGI. This module is somewhat
-similar in spirit to CGI::Application, CGI::Path, and CGI::Builder and any
-other "CGI framework." As with the others, CGI::Ex::App tries to do as
-much as possible, in a simple manner, without getting in the
-developer's way. Your milage may vary.
-
-=head1 SYNOPSIS
-
-More examples will come with time. Here are the basics for now.
-
- #!/usr/bin/perl -w
-
- MyApp->navigate;
- # OR you could do the following which cleans
- # circular references - useful for a mod_perl situation
- # MyApp->navigate->cleanup;
- exit;
-
- package MyApp;
- use strict;
- use base qw(CGI::Ex::App);
- use CGI::Ex::Dump qw(debug);
-
- sub valid_steps { return {success => 1, js => 1} }
- # default_step (main) is a valid path
- # note the inclusion of js step to allow the
- # javascript scripts in js_validation to function properly.
-
- # base_dir_abs is only needed if default print is used
- # template toolkit needs an INCLUDE_PATH
- sub base_dir_abs { '/tmp' }
-
- sub main_file_print {
- # reference to string means ref to content
- # non-reference means filename
- return \ "<h1>Main Step</h1>
- <form method=post name=[% form_name %]>
- <input type=text name=foo>
- <span style='color:red' id=foo_error>[% foo_error %]</span><br>
- <input type=submit>
- </form>
- [% js_validation %]
- <a href='[% script_name %]?step=foo'>Link to forbidden step</a>
- ";
- }
-
- sub post_print {
- debug shift->history;
- } # show what happened
-
- sub main_file_val {
- # reference to string means ref to yaml document
- # non-reference means filename
- return \ "foo:
- required: 1
- min_len: 2
- max_len: 20
- match: 'm/^([a-z]\\d)+[a-z]?\$/'
- match_error: Characters must alternate letter digit letter.
- \n";
- }
-
- sub main_finalize {
+sub base_dir_abs {
my $self = shift;
+ $self->{'base_dir_abs'} = shift if $#_ != -1;
+ return $self->{'base_dir_abs'} || '';
+}
- debug $self->form, "Do something useful with form here";
-
- ### add success step
- $self->add_to_swap({success_msg => "We did something"});
- $self->append_path('success');
- $self->set_ready_validate(0);
- return 1;
- }
-
- sub success_file_print {
- \ "<h1>Success Step</h1> All done.<br>
- ([% success_msg %])<br>
- (foo = [% foo %])";
- }
-
- ### not necessary - this is the default hash_base
- sub hash_base { # used to include js_validation
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{SCRIPT_NAME} || '',
- js_validation => sub { $self->run_hook('js_validation', $step) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
- }
-
- __END__
-
-Note: This example would be considerably shorter if the html file
-(file_print) and the validation file (file_val) had been placed in
-separate files. Though CGI::Ex::App will work "out of the box" as
-shown it is more probable that any platform using it will customize
-the various hooks to their own tastes (for example, switching print to
-use a system other than Template::Toolkit).
-
-=head1 HOOKS / METHODS
-
-CGI::Ex::App works on the principles of hooks which are essentially
-glorified method lookups. When a hook is called, CGI::Ex::App will
-look for a corresponding method call for that hook for the current
-step name. See the discussion under the method named "hook" for more
-details. The methods listed below are normal method calls.
-Hooks and methods are looked for in the following order:
-
-=over 4
-
-=item Method C<-E<gt>new>
-
-Object creator. Takes a hash or hashref.
-
-=item Method C<-E<gt>init>
-
-Called by the default new method. Allows for any object
-initilizations.
-
-=item Method C<-E<gt>form>
-
-Returns a hashref of the items passed to the CGI. Returns
-$self->{form}. Defaults to CGI::Ex::get_form.
-
-=item Method C<-E<gt>navigate>
-
-Takes a class name or a CGI::Ex::App object as arguments. If a class
-name is given it will instantiate an object by that class. All returns
-from navigate will return the object.
-
-The method navigate is essentially a safe wrapper around the ->nav_loop
-method. It will catch any dies and pass them to ->handle_error.
-
-=item Method C<-E<gt>nav_loop>
-
-This is the main loop runner. It figures out the current path
-and runs all of the appropriate hooks for each step of the path. If
-nav_loop runs out of steps to run (which happens if no path is set, or if
-all other steps run successfully), it will insert the ->default_step into
-the path and run nav_loop again (recursively). This way a step is always
-assured to run. There is a method ->recurse_limit (default 15) that
-will catch logic errors (such as inadvertently running the same
-step over and over and over).
-
-The basic outline of navigation is as follows (the default actions for hooks
-are shown):
-
- navigate {
- eval {
- ->pre_navigate
- ->nav_loop
- ->post_navigate
- }
- # dying errors will run the ->handle_error method
- }
-
-
- nav_loop {
- ->path (get the path steps)
- # DEFAULT ACTION
- # look in $ENV{'PATH_INFO'}
- # look in ->form for ->step_key
-
- ->pre_loop
- # navigation stops if true
-
- ->valid_steps (get list of valid paths)
-
- foreach step of path {
-
- # check that path is valid
-
- ->morph
- # DEFAULT ACTION
- # check ->allow_morph
- # check ->allow_nested_morph
- # ->morph_package (hook - get the package to bless into)
- # ->fixup_after_morph if morph_package exists
-
- ->run_step (hook)
-
- ->unmorph
- # DEFAULT ACTION
- # ->fixup_before_unmorph if blessed to previous package
-
- # exit loop if ->run_step returned true (intercepted)
-
- } end of step foreach
-
- ->post_loop
- # navigation stops if true
-
- ->default_step (inserted into path at current location)
- ->nav_loop (called again recursively)
-
- } end of nav_loop
-
-
- run_step {
- ->pre_step (hook)
- # exits nav_loop if true
-
- ->skip (hook)
- # skips this step if true (stays in nav_loop)
-
- ->prepare (hook - defaults to true)
-
- ->info_complete (hook - ran if prepare was true)
- # DEFAULT ACTION
- # ->ready_validate (hook)
- # return false if ! ready_validate
- # ->validate (hook)
- # ->hash_validation (hook)
- # ->file_val (hook - uses base_dir_rel, name_module, name_step, ext_val)
- # uses CGI::Ex::Validate to validate the hash
- # returns true if validate is true
-
- ->finalize (hook - defaults to true - ran if prepare and info_complete were true)
-
- if ! ->prepare || ! ->info_complete || ! ->finalize {
- ->prepared_print
- # DEFAULT ACTION
- # ->hash_base (hook)
- # ->hash_common (hook)
- # ->hash_form (hook)
- # ->hash_fill (hook)
- # ->hash_swap (hook)
- # ->hash_errors (hook)
- # merge form, base, common, and fill into merged fill
- # merge form, base, common, swap, and errors into merged swap
- # ->print (hook - passed current step, merged swap hash, and merged fill)
- # DEFAULT ACTION
- # ->file_print (hook - uses base_dir_rel, name_module, name_step, ext_print)
- # ->template_args
- # Processes the file with Template Toolkit
- # Fills the any forms with CGI::Ex::Fill
- # Prints headers and the content
-
- ->post_print (hook - used for anything after the print process)
-
- # return true to exit from nav_loop
- }
-
- ->post_step (hook)
- # exits nav_loop if true
-
- } end of run_step
-
-
-=item Method C<-E<gt>pre_navigate>
-
-Called from within navigate. Called before the nav_loop method is started.
-If a true value is returned then navigation is skipped (the nav_loop is never
-started).
-
-=item Method C<-E<gt>post_navigate>
-
-Called from within navigate. Called after the nav_loop has finished running.
-Will only run if there were no errors which died during the nav_loop
-process.
-
-=item Method C<-E<gt>handle_error>
-
-If anything dies during execution, handle_error will be called with
-the error that had happened. Default is to debug the error and path
-history.
-
-=item Method C<-E<gt>history>
-
-Returns an arrayref of which hooks of which steps of the path were ran.
-Useful for seeing what happened. In general - each line of the history
-will show the current step, the hook requested, and which hook was
-actually called. (hooks that don't find a method don't add to history)
-
-=item Method C<-E<gt>path>
-
-Return an arrayref (modifyable) of the steps in the path. For each
-step the remaining hooks can be run. Hook methods are looked up and
-ran using the method "run_hook" which uses the method "hook" to lookup
-the hook. A history of ran hooks is stored in the array ref returned
-by $self->history. Default will be a single step path looked up in
-$form->{path} or in $ENV{PATH_INFO}. By default, path will look for
-$ENV{'PATH_INFO'} or the value of the form by the key step_key. For
-the best functionality, the arrayref returned should be the same
-reference returned for every call to path - this ensures that other
-methods can add to the path (and will most likely break if the
-arrayref is not the same). If navigation runs out of steps to run,
-the default step found in default_step will be run.
-
-=item Method C<-E<gt>default_step>
-
-Step to show if the path runs out of steps. Default value is the
-'default_step' property or the value 'main'.
-
-=item Method C<-E<gt>step_key>
-
-Used by default to determine which step to put in the path. The
-default path will only have one step within it
-
-=item Method C<-E<gt>set_path>
-
-Arguments are the steps to set. Should be called before navigation
-begins. This will set the path arrayref to the passed steps.
-
-=item Method C<-E<gt>append_path>
-
-Arguments are the steps to append. Can be called any time. Adds more
-steps to the end of the current path.
-
-=item Method C<-E<gt>replace_path>
-
-Arguments are the steps used to replace. Can be called any time.
-Replaces the remaining steps (if any) of the current path.
-
-=item Method C<-E<gt>insert_path>
-
-Arguments are the steps to insert. Can be called any time. Inserts
-the new steps at the current path location.
-
-=item Method C<-E<gt>jump>
-
-This method should not normally be used. 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 - but most of the time should be
-avoided)
-
-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 words
-"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 retured by ->path is modified to allow for the jumping.
-
- ### 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');
-
-=item Method C<-E<gt>exit_nav_loop>
-
-This method should not normally used. It 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 unmorphed before returning.
-
-=item Method C<-E<gt>recurse_limit>
-
-Default 15. Maximum number of times to allow nav_loop to call itself.
-If ->jump is used alot - 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.
-
-=item Method C<-E<gt>valid_steps>
-
-Returns a hashref of path steps that are allowed. If step found in
-default method path is not in the hash, the method path will return a
-single step "forbidden" and run its hooks. If no hash or undef is
-returned, all paths are allowed (default). A key "forbidden_step"
-containing the step that was not valid will be placed in the stash.
-Often the valid_steps method does not need to be defined as arbitrary
-method calls are not possible with CGI::Ex::App.
-
-=item Method C<-E<gt>previous_step, -E<gt>current_step, -E<gt>next_step, -E<gt>last_step, -E<gt>first_step>
-
-Return the previous, current, next, last, and first step name - useful for figuring
-out where you are in the path. Note that first_step may not be the same
-thing as default_step if the path was overridden.
-
-=item Method C<-E<gt>pre_loop>
-
-Called right before the navigation loop is started. At this point the
-path is set (but could be modified). The only argument is a reference
-to the path array. If it returns a true value - the navigation
-routine is aborted.
-
-=item Method C<-E<gt>run_hook>
-
-Calls "hook" to get a code ref which it then calls and returns the
-result. Arguments are the same as that for "hook".
-
-=item Method C<-E<gt>hook>
-
-Arguments are a hook name, a pathstep name, and an optional code sub
-or default value (default value will be turned to a sub) (code sub
-will be called as method of $self).
-
- my $code = $self->hook('main', 'info_complete', sub {return 0});
- ### will look first for $self->main_info_complete;
- ### will then look for $self->info_complete;
- ### will then run $self->$default_passed_sub; # sub {return 0}
-
-This system is used to allow for multiple steps to be in the same
-file and still allow for moving some steps out to external sub classed
-packages. If the application has successfully morphed then it is not
-necessary to add the step name to the beginning of the method name as
-the morphed packages method will override the base package (it is still
-OK to use the full method name "${step}_hookname").
-
-If a hook is found (or a default value is found) then an entry is added
-to the arrayref contained in ->history.
-
-=item Method C<-E<gt>morph>
-
-Allows for temporarily "becoming" another object type for the
-execution of the current step. This allows for separating some steps
-out into their own packages. Morph will only run if the method
-allow_morph returns true. Additionally if the allow_morph returns a hash
-ref, morph will only run if the step being morphed to is in the hash.
-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:
-call the hook morph_package (which would default to returning
-Foo::Bar::MyStep in this case), translate this to a package filename
-(Foo/Bar/MyStep.pm) and try and require it, if the file can be
-required, the object is blessed into that package. If that package
-has a "fixup_after_morph" method, it is called. The navigate loop
-then continues for the current step. At any exit point of the loop,
-the unmorph call is made which reblesses the object into the original
-package.
-
-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 {
+sub ext_val {
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;
- }
+ $self->{'ext_val'} = shift if $#_ != -1;
+ return $self->{'ext_val'} || 'val';
+}
- sub post_navigate {
+sub ext_print {
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;
- # OR - for mod_perl resident programs
- Base->navigate->cleanup;
- # OR
- sub post_navigate { shift->cleanup }
-
-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).
-
-=item Method C<-E<gt>unmorph>
-
-Allows for returning an object back to its previous blessed state.
-This only happens if the object was previously morphed into another
-object type. Before the object is reblessed the method
-"fixup_before_unmorph" is called if it exists.
-
-=item Method C<-E<gt>allow_morph>
-
-Boolean value. Specifies whether or not morphing is allowed.
-Defaults to the property "allow_morph" if found, otherwise false.
-For more granularity, if true value is a hash, the step being
-morphed to must be in the hash.
-
-=item Method C<-E<gt>allow_nested_morph>
-
-Boolean value. Specifies whether or not nested morphing is allowed.
-Defaults to the property "allow_nested_morph" if found, otherwise
-false. For more granularity, if true value is a hash, the step being
-morphed to must be in the hash.
-
-=item Hook C<-E<gt>morph_package>
-
-Used by morph. Return the package name to morph into during a morph
-call. Defaults to using the current object type as a base. For
-example, if the current object running is a Foo::Bar object and the
-step running is my_step, then morph_package will return
-Foo::Bar::MyStep.
-
-=item Hook C<-E<gt>run_step>
-
-Runs all of the hooks specific to each step, beginning with pre_step
-and ending with post_step. Called after ->morph($step) has been
-run. If this returns true, the nav_loop is exited (meaning the
-run_step hook displayed the information). If it returns false,
-the nav_loop continues on to run the next step. This is essentially
-the same thing as a method defined in CGI::Applications ->run_modes.
-
-=item Hook C<-E<gt>pre_step>
-
-Ran at the beginning of the loop before prepare, info_compelete, and
-finalize are called. If it returns true, execution of nav_loop is
-returned and no more steps are processed.
-
-=item Hook C<-E<gt>skip>
-
-Ran at the beginning of the loop before prepare, info_compelete, and
-finalize are called. If it returns true, nav_loop moves on to the
-next step (the current step is skipped).
-
-=item Hook C<-E<gt>prepare>
-
-Defaults to true. A hook before checking if the info_complete is true.
-
-=item Hook C<-E<gt>info_complete>
-
-Checks to see if all the necessary form elements have been passed in.
-Calls hooks ready_validate, and validate. Will not be run unless
-prepare returns true (default).
-
-=item Hook C<-E<gt>finalize>
-
-Defaults to true. Used to do whatever needs to be done with the data once
-prepare has returned true and info_complete has returned true. On failure
-the print operations are ran. On success navigation moves on to the next
-step.
-
-=item Hook C<-E<gt>ready_validate>
-
-Should return true if enough information is present to run validate.
-Default is to look if $ENV{'REQUEST_METHOD'} is 'POST'. A common
-usage is to pass a common flag in the form such as 'processing' => 1
-and check for its presence - such as the following:
-
- sub ready_validate { shift->form->{'processing'} }
+ $self->{'ext_print'} = shift if $#_ != -1;
+ return $self->{'ext_print'} || 'html';
+}
-=item Method C<-E<gt>set_ready_validate>
+### where to find the javascript files
+### default to using this script as a handler
+sub js_uri_path {
+ my $self = shift;
+ my $script = $ENV{'SCRIPT_NAME'} || return '';
+ my $js_step = $self->js_step;
+ return ($self->can('path') == \&CGI::Ex::App::path)
+ ? $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
+}
-Sets that the validation is ready to validate. Should set the value
-checked by the hook ready_validate. The following would complement the
-processing flag above:
+###----------------------------------------------------------------###
+### a simple step that allows for printing javascript libraries that
+### are stored in perls @INC. Which ever step is in js_step should do something similar.
- sub set_ready_validate {
+sub js_run_step {
my $self = shift;
- if (shift) {
- $self->form->{'processing'} = 1;
- } else {
- delete $self->form->{'processing'};
- }
- }
-
-Note thate for this example the form key "processing" was deleted. This
-is so that the call to fill in any html forms won't swap in a value of
-zero for form elements named "processing."
-
-=item Hook C<-E<gt>validate>
-
-Runs validation on the information posted in $self->form. Uses
-CGI::Ex::Validate for the validation. Calls the hook hash_validation
-to load validation information. Should return true if enough
-information is present to run validate. Errors are stored as a hash
-in $self->{hash_errors} via method add_errors and can be checked for
-at a later time with method has_errors (if the default validate was
-used).
-
-Upon success, it will look through all of the items which
-were validated, if any of them contain the keys append_path, insert_path,
-or replace_path, that method will be called with the value as arguments.
-This allows for the validation to apply redirection to the path. A
-validation item of:
-
- {field => 'foo', required => 1, append_path => ['bar', 'baz']}
-
-would append 'bar' and 'baz' to the path should all validation succeed.
-=item Hook C<-E<gt>hash_validation>
-
-Returns a hash of the validation information to check form against.
-By default, will look for a filename using the hook file_val and will
-pass it to CGI::Ex::Validate::get_validation. If no file_val is
-returned or if the get_validation fails, an empty hash will be returned.
-Validation is implemented by ->vob which loads a CGI::Ex::Validate object.
-
-=item Hook C<-E<gt>file_val>
-
-Returns a filename containing the validation. Adds method
-base_dir_rel to hook name_module, and name_step and adds on the
-default file extension found in $self->ext_val which defaults to the
-global $EXT_VAL (the property $self->{ext_val} may also be set). File
-should be readible by CGI::Ex::Validate::get_validation.
-
-=item Hook C<-E<gt>js_validation>
-
-Requires YAML.pm.
-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 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
-yaml_load.js and 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 either the hash_base, hash_common, hash_swap or
-hash_form hook (see examples of hash_base used in this doc).
-
-=item Hook C<-E<gt>form_name>
-
-Return the name of the form to attach the js validation to. Used by
-js_validation.
-
-=item Method C<-E<gt>js_uri_path>
-
-Return the URI path where the CGI/Ex/yaml_load.js and
-CGI/Ex/validate.js files can be found. This will default to
-"$ENV{SCRIPT_NAME}/js" if the path method has not been overridden,
-otherwise it will default to "$ENV{SCRIPT_NAME}?step=js&js=" (the
-latter is more friendly with overridden paths). A default handler for
-the "js" step has been provided in "js_run_step" (this handler will
-nicely print out the javascript found in the js files which are
-included with this distribution - if valid_steps is defined, it must
-include the step "js" - js_run_step will work properly with the
-default "path" handler.
-
-=item Hook C<-E<gt>hash_swap>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any items needed to be swapped
-into the html during print. Will be merged with hash_base, hash_common, hash_form,
-and hash_errors. Can be populated by passing a hash to ->add_to_swap.
-
-=item Hook C<-E<gt>hash_form>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Defaults to ->form. Can be populated by passing a hash
-to ->add_to_form.
-
-=item Hook C<-E<gt>hash_fill>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any items needed to be filled
-into the html form during print. Items from hash_form, hash_base, and hash_common
-will be layered on top during a print cycle. Can be populated by passing
-a hash to ->add_to_fill.
-
-By default - forms are sticky and data from previous requests will
-try and populate the form. There is a method called ->no_fill which
-will turn off sticky forms.
-
-=item Method C<-E<gt>no_fill>
-
-Passed the current step. Should return boolean value of whether or not
-to fill in the form on the printed page. (prevents sticky forms)
-
-=item Hook C<-E<gt>hash_errors>
-
-Called in preparation for print after failed prepare, info_complete,
-or finalize. Should contain a hash of any errors that occured. Will
-be merged into hash_form before the pass to print. Eash error that
-occured will be passed to method format_error before being added to
-the hash. If an error has occurred, the default validate will
-automatically add {has_errors =>1}. To the error hash at the time of
-validation. has_errors will also be added during the merge incase the
-default validate was not used. Can be populated by passing a hash to
-->add_to_errors or ->add_errors.
-
-=item Hook C<-E<gt>hash_common>
-
-Almost identical in function and purpose to hash_base. It is
-intended that hash_base be used for common items used in various
-scripts inheriting from a common CGI::Ex::App type parent. Hash_common
-is more intended for step level populating of both swap and fill.
+ ### make sure path info looks like /js/CGI/Ex/foo.js
+ my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || '';
+ $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : '';
-=item Hook C<-E<gt>hash_base>
-
-A hash of base items to be merged with hash_form - such as pulldown
-menues. It will now also be merged with hash_fill, so it can contain
-default fillins. Can be populated by passing a hash to ->add_to_base.
-By default the following sub is what is used for hash_common (or something
-similiar). Note the use of values that are code refs - so that the
-js_validation and form_name hooks are only called if requested:
-
- sub hash_base {
- my ($self, $step) = @_;
- return $self->{hash_base} ||= {
- script_name => $ENV{SCRIPT_NAME},
- js_validation => sub { $self->run_hook('js_validation', $step) },
- form_name => sub { $self->run_hook('form_name', $step) },
- };
- }
-
-=item Hook C<-E<gt>name_module>
-
-Return the name (relative path) that should be prepended to name_step
-during the default file_print and file_val lookups. Defaults to
-base_name_module.
-
-=item Hook C<-E<gt>name_step>
-
-Return the step (appended to name_module) that should used when
-looking up the file in file_print and file_val lookups. Defaults to
-the current step.
-
-=item Hook C<-E<gt>file_print>
-
-Returns a filename of the content to be used in the default print
-hook. Adds method base_dir_rel to hook name_module, and name_step and
-adds on the default file extension found in $self->ext_print which
-defaults to the global $EXT_PRINT (the property $self->{ext_print} may
-also be set). Should be a file that can be handled by hook print.
-
-=item Hook C<-E<gt>print>
+ $self->cgix->print_js($file);
+ $self->{'_no_post_navigate'} = 1;
+ return 1;
+}
-Take the information generated by prepared_print, format it, and print it out.
-Default incarnation uses Template::Toolkit. Arguments are: step name, form hashref,
-and fill hashref.
+###----------------------------------------------------------------###
+### a step that will be used if a valid_steps is defined
+### and the current step of the path is not in valid_steps
+### or if the step is a "hidden" step that begins with _
+### or if the step name contains \W
-=item Hook C<-E<gt>prepared_print>
+sub __forbidden_info_complete { 0 }
-Called when any of prepare, info_complete, or finalize fail. Prepares
-a form hash and a fill hash to pass to print. The form hash is primarily
-intended for use by the templating system. The fill hash is intended
-to be used to fill in any html forms.
+sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} }
-=item Hook C<-E<gt>post_print>
+sub __forbidden_file_print { \ "<h1>Denied</h1>You do not have access to the step <b>\"[% forbidden_step %]\"</b>" }
-A hook which occurs after the printing has taken place. Is only run
-if the information was not complete. Useful for printing rows of a
-database query.
-
-=item Hook C<-E<gt>post_step>
+###----------------------------------------------------------------###
-Ran at the end of the step's loop if prepare, info_complete, and
-finalize all returned true. Allows for cleanup. If a true value is
-returned, execution of navigate is returned and no more steps are
-processed.
-
-=item Method C<-E<gt>post_loop>
+1;
-Ran after all of the steps in the loop have been processed (if
-prepare, info_complete, and finalize were true for each of the steps).
-If it returns a true value the navigation loop will be aborted. If it
-does not return true, navigation continues by then inserting the step
-$self->default_step and running $self->nav_loop again (recurses) to
-fall back to the default step.
-
-=item Method C<-E<gt>stash>
-
-Returns a hashref that can store arbitrary user space data without
-clobering the internals of the application.
-
-=item Method C<-E<gt>add_property>
-
-Takes the property name as an argument. Creates an accessor that can
-be used to access a new property. If there were additional arguments
-they will call the new accessor. Calling the new accessor with an
-argument will set the property. Using the accessor in an assignment
-will also set the property (it is an lvalue). Calling the accessor in
-any other way will return the value.
-
-=item Method C<-E<gt>cleanup>
-
-Can be used at the end of execution to tear down the structure.
-Default method starts a cleanup_cross_references call.
-
-=item Method C<-E<gt>cleanup_cross_references>
-
-Used to destroy links in nested structures. Will spider through the
-data structure of the passed object and remove any blessed objects
-that are no weakly referenced. This means if you have a reference to
-an object in a global cache, that object should have its reference
-weakened in the global cache. Requires Scalar::Util to function. Use
-of this function is highly recommended in mod_perl environments to
-make sure that there are no dangling objects in memory. There are
-some global caches that can't be fixed (such as Template::Parser's
-reference to Template::Grammar in the Template::Toolkit). For these
-situations there is a %CLEANUP_EXCLUDE hash that contains the names of
-Object types to exclude from the cleanup process. Add any such global
-hashes (or objects with references to the global hashes) there.
-
-=back
-
-=head1 OTHER APPLICATION MODULES
-
-The concepts used in CGI::Ex::App are not novel or unique. However, they
-are all commonly used and very useful. All application builders were
-built because somebody observed that there are common design patterns
-in CGI building. CGI::Ex::App differs in that it has found more common design
-patterns of CGI's.
-
-CGI::Ex::App is intended to be sub classed, and sub sub classed, and each step
-can choose to be sub classed or not. CGI::Ex::App tries to remain simple
-while still providing "more than one way to do it." It also tries to avoid
-making any sub classes have to call ->SUPER::.
-
-There are certainly other modules for building CGI applications. The
-following is a short list of other modules and how CGI::Ex::App is
-different.
-
-=over 4
-
-=item C<CGI::Application>
-
-Seemingly the most well know of application builders.
-CGI::Ex::App is different in that it:
-
- * Uses Template::Toolkit by default
- CGI::Ex::App can easily use another toolkit by simply
- overriding the ->print method.
- CGI::Application uses HTML::Template.
- * Offers integrated data validation.
- CGI::Application has had custom addons created that
- add some of this functionality. CGI::Ex::App has the benefit
- that once validation is created,
- * Allows the user to print at any time (so long as proper headers
- are sent. CGI::Application requires data to be pipelined.
- * Offers hooks into the various phases of each step ("mode" in
- CGI::Application lingo). CGI::Application essentially
- provides ->runmode
- * Support for easily jumping around in navigation steps.
- * Support for storing some steps in another package.
-
-CGI::Ex::App and CGI::Application are similar in that they take care
-of handling headers and they allow for calling other "runmodes" from
-within any given runmode. CGI::Ex::App's ->run_step is essentially
-equivalent to a method call defined in CGI::Application's ->run_modes.
-The ->run method of CGI::Application starts the application in the same
-manner as CGI::Ex::App's ->navigate call. Many of the hooks around
-CGI::Ex::App's ->run_step call are similar in nature to those provided by
-CGI::Application.
-
-=item C<CGI::Prototype>
-
-There are actually many simularities. 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::Tookit as the default template system.
-CGI::Ex::App is differrent in that it:
-
- * Offers integrated data validation.
- CGI::Application has had custom addons created that
- add some of this functionality. CGI::Ex::App has the benefit
- that once validation is created,
- * Offers more hooks into the various phases of each step.
- * Support for easily jumping around in navigation steps.
- * Support for storing some steps in another package.
-
-=item C<CGI::Path>
-
-CGI::Path and CGI::Ex::App are fairly similar in may ways as they
-were created under similar lines of thought. The primary difference
-in these two is that CGI::Ex::App:
-
- * Does not provide "automated path following" based on
- validated key information. CGI::Path works well for
- wizard based applications. CGI::Ex::App assumes that
- the application will chose it's own path (it works very
- well in non-linear paths - it also works fine in
- linear paths but it doesn't provide some of magic that
- CGI::Path provides).
- * Does not provide integrated session support. CGI::Path
- requires it for path navigation. CGI::Ex::App assumes that
- if session support or authentication is needed by an
- application, a custom Application layer that inherits
- from CGI::Ex::App will be written to provide this support.
- * Offers more granularity in the navigation phase. CGI::Path
- has successfully been used as a sub class of CGI::Ex::App
- with limited modifications.
-
-=back
-
-=head1 BUGS
-
-Uses CGI::Ex for header support by default - which means that support
-for mod_perl 2 is limited at this point.
-
-There are a lot of hooks. Actually this is not a bug. Some may
-prefer not calling as many hooks - they just need to override
-methods high in the chain and subsequent hooks will not be called.
-
-=head1 THANKS
-
-Bizhosting.com - giving a problem that fit basic design patterns.
-Earl Cahill - pushing the idea of more generic frameworks.
-Adam Erickson - design feedback, bugfixing, feature suggestions.
-James Lance - design feedback, bugfixing, feature suggestions.
-
-=head1 AUTHOR
-
-Paul Seamons
-
-=cut
+### See the perldoc in CGI/Ex/App.pod
--- /dev/null
+=head1 NAME
+
+CGI::Ex::App - Anti-framework application framework.
+
+=head1 DESCRIPTION
+
+Fill in the blanks and get a ready made web application. This module
+is somewhat similar in spirit to CGI::Application, CGI::Path, and
+CGI::Builder and any other "CGI framework." As with the others,
+CGI::Ex::App tries to do as much of the mundane things, in a simple
+manner, without getting in the developer's way. Your mileage may vary.
+
+If you build applications that submit user information, validate it,
+re-display it, fill in forms, or separate logic into separate modules,
+then this module may be for you. If all you need is a dispatch
+engine, then this still may be for you. If all want is to look at
+user passed information, then this may still be for you. If you like
+writing bare metal code, this could still be for you. If you don't want
+to write any code, this module will help - but you still need to
+provide you key actions.
+
+
+=head1 SYNOPSIS (A LONG "SYNOPSIS")
+
+More examples will come with time. Here are the basics for now.
+This example script would most likely be in the form of a cgi, accessible via
+the path http://yourhost.com/cgi-bin/my_app (or however you do CGIs on
+your system. About the best way to get started is to paste the following
+code into a cgi script (such as cgi-bin/my_app) and try it out. A detailed
+walk-through follows in the next section. There is also a longer recipe
+database example at the end of this document that covers other topics including
+making your module a mod_perl handler.
+
+ ### File: /var/www/cgi-bin/my_app (depending upon Apache configuration)
+ ### --------------------------------------------
+ #!/usr/bin/perl -w
+
+ use strict;
+ use base qw(CGI::Ex::App);
+ use CGI::Ex::Dump qw(debug);
+
+ __PACKAGE__->navigate;
+ # OR
+ # my $obj = __PACKAGE__->new;
+ # $obj->navigate;
+
+ exit;
+
+ ###------------------------------------------###
+
+ sub post_navigate {
+ # show what happened
+ debug shift->dump_history;
+ }
+
+ sub main_hash_validation {
+ return {
+ 'general no_alert' => 1,
+ 'general no_confirm' => 1,
+ 'group order' => [qw(username password password2)],
+ username => {
+ required => 1,
+ min_len => 3,
+ max_len => 30,
+ match => 'm/^\w+$/',
+ match_error => 'You may only use letters and numbers.',
+ },
+ password => {
+ required => 1,
+ min_len => 6,
+ },
+ password2 => {
+ equals => 'password',
+ },
+ };
+ }
+
+ sub main_file_print {
+ # reference to string means ref to content
+ # non-reference means filename
+ return \ "<h1>Main Step</h1>
+ <form method=post name=[% form_name %]>
+ <input type=hidden name=step>
+ <table>
+ <tr>
+ <td><b>Username:</b></td>
+ <td><input type=text name=username><span style='color:red' id=username_error>[% username_error %]</span></td>
+ </tr><tr>
+ <td><b>Password:</b></td>
+ <td><input type=text name=password><span style='color:red' id=password_error>[% password_error %]</span></td>
+ </tr><tr>
+ <td><b>Verify Password:</b></td>
+ <td><input type=text name=password2><span style='color:red' id=password2_error>[% password2_error %]</span></td>
+ </tr>
+ <tr><td colspan=2 align=right><input type=submit></td></tr>
+ </table>
+ </form>
+ [% js_validation %]
+ ";
+ }
+
+ sub main_finalize {
+ my $self = shift;
+
+ if ($self->form->{'username'} eq 'bar') {
+ $self->add_errors(username => 'A trivial check to say the username cannot be "bar"');
+ return 0;
+ }
+
+ debug $self->form, "Do something useful with form here in the finalize hook.";
+
+ ### add success step
+ $self->add_to_swap({success_msg => "We did something"});
+ $self->append_path('success');
+ $self->set_ready_validate(0);
+ return 1;
+ }
+
+ sub success_file_print {
+ \ "<div style=background:lightblue>
+ <h1>Success Step - [% success_msg %]</h1>
+ Username: <b>[% username %]</b><br>
+ Password: <b>[% password %]</b><br>
+ </div>
+ ";
+ }
+
+ __END__
+
+Note: This example would be considerably shorter if the html file
+(file_print) and the validation file (file_val) had been placed in
+separate files. Though CGI::Ex::App will work "out of the box" as
+shown it is more probable that any platform using it will customize
+the various hooks to their own tastes (for example, switching print to
+use a templating system other than CGI::Ex::Template).
+
+=head1 SYNOPSIS STEP BY STEP
+
+This section goes step by step over the previous example.
+
+Well - we start out with the customary CGI introduction.
+
+ #!/usr/bin/perl -w
+
+ use strict;
+ use base qw(CGI::Ex::App);
+ use CGI::Ex::Dump qw(debug);
+
+Note: the "use base" is not normally used in the "main" portion of a script.
+It does allow us to just do __PACKAGE__->navigate.
+
+Now we need to invoke the process:
+
+ __PACKAGE__->navigate;
+ # OR
+ # my $obj = __PACKAGE__->new;
+ # $obj->navigate;
+ exit;
+
+Note: the "exit" isn't necessary - but it is kind of nice to infer
+that program flow doesn't go beyond the ->navigate call.
+
+The navigate routine is now going to try and "run" through a series of
+steps. Navigate will call the ->path method which should return an
+arrayref containing the valid steps. By default, if path method has
+not been overridden, the path method will default first to the step
+found in form key named ->step_name, then it will fall to the contents
+of $ENV{'PATH_INFO'}. If navigation runs out of steps to run it will
+run the step found in ->default_step which defaults to 'main'. So the
+URI '/cgi-bin/my_app' would run the step 'main' first by default. The
+URI '/cgi-bin/my_app?step=foo' would run the step 'foo' first. The
+URI '/cgi-bin/my_app/bar' would run the step 'bar' first.
+
+CGI::Ex::App allows for running steps in a preset path. The navigate
+method will go through a step of the path at a time and see if it is
+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,
+insert_path, and replace_path methods).
+
+During development it would be nice to see what happened during the
+course of our navigation. This is stored in the arrayref contained in
+->history. There is a method that is called after all of the navigation
+has taken place called "post_navigate". This chunk will display history after we
+have printed the content.
+
+ sub post_navigate {
+ debug shift->dump_history;
+ } # show what happened
+
+Ok. Finally we are looking at the methods used by each step of the path. The
+hook mechanism of CGI::Ex::App will look first for a method ${step}_${hook_name}
+called before falling back to the method named $hook_name. Internally in the
+code there is a call that looks like $self->run_hook('hash_validation', $step). In
+this case the step is main. The dispatch mechanism finds our method at the following
+chunk of code.
+
+ sub main_hash_validation { ... }
+
+The process flow will see if the data is ready to validate. Once it is ready
+(usually when the user presses the submit button) the data will be validated. The
+hash_validation hook is intended to describe the data and will be tested
+using CGI::Ex::Validate. See the CGI::Ex::Validate perldoc for more
+information about the many types of validation available.
+
+ sub main_file_print { ... }
+
+The navigation process will see if user submitted information (the form)
+is ready for validation. If not, or if validation fails, the step needs to
+be printed. Eventually the file_print hook is called. This hook should
+return either the filename of the template to be printed, or a reference
+to the actual template content. In this example we return a reference
+to the content to be printed (this is useful for prototyping applications
+and is also fine in real world use - but generally production applications
+use external html templates).
+
+A few things to note about the template:
+
+First, we add a hidden form field called step. This will be filled in
+at a later point with the current step we are on.
+
+We provide locations to swap in inline errors.
+
+ <span style="color:red" id="username_error">[% username_error %]</span>
+
+As part of the error html we name each span with the name of the error. This
+will allow for us to have Javascript update the error spots when the javascript
+finds an error.
+
+At the very end we add the TT variable [% js_validation %]. This swap in is
+provided by the default hash_base hook and will provide for form data to be
+validated using javascript.
+
+Once the process flow has deemed that the data is validated, it then calls
+the finalize hook. Finalize is where the bulk of operations should go.
+We'll look at it more in depth.
+
+ sub main_finalize {
+ my $self = shift;
+ my $form = $self->form;
+
+At this point, all of the validated data is in the $form hashref.
+
+ if ($form->{'username'} eq 'bar') {
+ $self->add_errors(username => 'A trivial check to say the username cannot be "bar"');
+ return 0;
+ }
+
+It is most likely that though the data is of the correct type and formatting,
+it still isn't completely correct. This previous section shows a hard coded
+test to see if the username was 'bar'. If it was then an appropriate error will
+be set, the routine returns 0 and the run_step process knows that it needs to
+redisplay the form page for this step. The username_error will be shown inline.
+The program could do more complex things such as checking to see if the username
+was already taken in a database.
+
+ debug $form, "Do something useful with form here in the finalize hook.";
+
+This debug $form piece is simply a place holder. It is here that the program would
+do something useful such as add the information to a database.
+
+ ### add success step
+ $self->add_to_swap({success_msg => "We did something"});
+
+Now that we have finished finalize, we add a message that will be passed to the template
+engine.
+
+ $self->append_path('success');
+ $self->set_ready_validate(0);
+
+The program now needs to move on to the next step. In this case we want to
+follow with a page that informs us we succeeded. So, we append a step named "success".
+We also call set_ready_validate(0) to inform the navigation control that the
+form is no longer ready to validate - which will cause the success page to
+print without trying to validate the data. It is normally a good idea
+to set this as leaving the engine in a "ready to validate" state can result
+in an recursive loop (that will be caught).
+
+ return 1;
+ }
+
+We then return 1 which tells the engine that we completed this step successfully
+and it needs to move on to the next step.
+
+Finally we run the "success" step because we told it to. That step isn't
+ready to validate so it prints out the template page.
+
+For more of a real world example, it would be good to read the sample recipe db
+application included at the end of this document.
+
+=head1 DEFAULT PROGRAM FLOW
+
+The following pseudo-code describes the process flow
+of the CGI::Ex::App framework. Several portions of the flow
+are encapsulated in hooks which may be completely overridden to give
+different flow. All of the default actions are shown. It may look
+like a lot to follow, but if the process is broken down into the
+discrete operations of step iteration, data validation, and template
+printing the flow feels more natural.
+
+The process starts off by calling ->navigate.
+
+ navigate {
+ eval {
+ ->pre_navigate
+ ->nav_loop
+ ->post_navigate
+ }
+ # dying errors will run the ->handle_error method
+ }
+
+The nav_loop method will run as follows:
+
+ nav_loop {
+ ->path (get the array of path steps)
+ # look in $ENV{'PATH_INFO'}
+ # look in ->form for ->step_key
+ # make sure step is in ->valid_steps (if defined)
+
+ ->pre_loop($path)
+ # navigation stops if true
+
+ foreach step of path {
+
+ ->morph
+ # check ->allow_morph
+ # 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
+
+ ->run_step (hook)
+
+ ->unmorph
+ # only called if morph worked
+ # ->fixup_before_unmorph if blessed to current package
+
+ # exit loop if ->run_step returned true (page printed)
+
+ } end of foreach step
+
+ ->post_loop
+ # navigation stops if true
+
+ ->default_step
+ ->insert_path (puts the default step into the path)
+ ->nav_loop (called again recursively)
+
+ } end of nav_loop
+
+For each step of the path the following methods will be run
+during the run_step hook.
+
+ run_step {
+ ->pre_step (hook)
+ # exits nav_loop if true
+
+ ->skip (hook)
+ # skips this step if true (stays in nav_loop)
+
+ ->prepare (hook - defaults to true)
+
+ ->info_complete (hook - ran if prepare was true)
+ ->ready_validate (hook)
+ return false if ! ready_validate
+ ->validate (hook - uses CGI::Ex::Validate to validate form info)
+ ->hash_validation (hook)
+ ->file_val (hook)
+ ->base_dir_abs
+ ->base_dir_rel
+ ->name_module
+ ->name_step
+ ->ext_val
+ returns true if validate is true or if nothing to validate
+
+ ->finalize (hook - defaults to true - ran if prepare and info_complete were true)
+
+ if ! ->prepare || ! ->info_complete || ! ->finalize {
+ ->prepared_print
+ ->hash_base (hook)
+ ->hash_common (hook)
+ ->hash_form (hook)
+ ->hash_fill (hook)
+ ->hash_swap (hook)
+ ->hash_errors (hook)
+ # merge form, base, common, and fill into merged fill
+ # 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)
+ ->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)
+
+ ->post_print (hook - used for anything after the print process)
+
+ # return true to exit from nav_loop
+ }
+
+ ->post_step (hook)
+ # exits nav_loop if true
+
+ } end of run_step
+
+It is important to learn the function and placement of each of the
+hooks in the process flow in order to make the most of CGI::Ex::App.
+It is enough to begin by learning a few common hooks - such as
+hash_validation, hash_swap, and finalize, and then learn about other
+hooks as needs arise. Sometimes, it is enough to simply override the
+run_step hook and take care of processing the entire step yourself.
+
+Because of the hook based system, and because CGI::Ex::App uses
+sensible defaults, it is very easy to override a little or a lot which
+ends up giving the developer a lot of flexibility.
+
+Consequently, it should be possible to use CGI::Ex::App with the other
+frameworks such as CGI::Application or CGI::Prototype. For these you
+could simple let each "runmode" call the run_step hook of CGI::Ex::App
+and you will instantly get all of the common process flow for free.
+
+=head1 AVAILABLE METHODS / HOOKS
+
+CGI::Ex::App's dispatch system works on the principles of hooks (which
+are essentially glorified method lookups). When the run_hook method
+is called, CGI::Ex::App will look for a corresponding method call for
+that hook for the current step name. It is perhaps easier to show than
+to explain.
+
+If we are calling the "print" hook for the step "edit" we would call
+run_hook like this:
+
+ $self->run_hook('print', 'edit', $template, \%swap, \%fill);
+
+This would first look for a method named "edit_print". If it is unable to
+find a method by that name, it will look for a method named "print". If it
+is unable to find this method - it will die.
+
+If allow_morph is set to true, the same methods are searched for but it becomes
+possible to move some of those methods into an external package.
+
+See the discussions under the methods named "find_hook" and "run_hook" for more details.
+
+The following is the alphabetical list of methods and hooks.
+
+=over 4
+
+=item allow_morph (method)
+
+Should return true if this step is allowed to "morph" the current App
+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.
+
+To enable morphing for all steps, add the following:
+
+ sub allow_morph { 1 }
+
+To enable morph on specific steps, do either of the following:
+
+ sub allow_morph {
+ return {
+ edit => 1,
+ delete => 1,
+ };
+ }
+
+ # OR
+
+ sub allow_morph {
+ my ($self, $step) = @_;
+ return $step =~ /^(edit|delete)$/;
+ }
+
+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
+steps to the end of the current path.
+
+=item auth_args (method)
+
+Should return a hashref that will be passed to the new method of CGI::Ex::Auth.
+It is augmented with arguments that integrate it into CGI::Ex::App.
+
+See the get_valid_auth method and the CGI::Ex::Auth documentation.
+
+ sub auth_args {
+ return {
+ login_header => '<h1>My login header</h1>',
+ login_footer => '[% TRY %][% INCLUDE login/login_footer.htm %][% CATCH %]<!-- [% error %] -->[% END %]',
+ secure_hash_keys => [qw(aaaaaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc 2222222222222)],
+ # use_blowfish => 'my_blowfish_key',
+ };
+ }
+
+=item auth_data (method)
+
+Contains authentication data stored during the get_valid_auth method.
+The data is normally blessed into the CGI::Ex::Auth::Data package which
+evaluates to false if there was an error and true if the authentication
+was successful - so this data can be defined but false.
+
+See the get_valid_auth method.
+
+=item cleanup_user (method)
+
+Installed as a hook during get_valid_auth. Allows for cleaning
+up the username. See the get_valid_auth method.
+
+ sub cleanup_user {
+ my ($self, $user) = @_;
+ return lc $user;
+ }
+
+=item current_step (method)
+
+Returns the current step that the nav_loop is functioning on.
+
+=item default_step (method)
+
+Step to show if the path runs out of steps. Default value is the
+'default_step' property which defaults to 'main'.
+
+If nav_loop runs of the end of the path (runs out of steps), this
+method is called, the step is added to the path, and nav_loop calls
+itself recursively.
+
+=item dump_history (method)
+
+Show simplified trace information of which steps were called, the
+order they were called in, the time they took to run, and a brief list
+of the output (to see the full response returned by each hook, pass a
+true value as the only argument to dump_history -
+$self->dump_history(1)). Indentation is also applied to show which
+hooks called other hooks.
+
+
+The first line shows the amount of time elapsed for the entire
+navigate execution. Subsequent lines contain:
+
+ Step - the name of the current step.
+ Hook - the name of the hook being called.
+ Found - the name of the method that was found.
+ Time - the total elapsed seconds that method took to run.
+ Output - the response of the hook - shown in shortened form.
+
+Note - to get full output responses - pass a true value to
+dump_history - or just call ->history. Times displayed are to 5
+decimal places - this accuracy can only be provided if the Time::HiRes
+module is installed on your system (it will only be used if installed).
+
+It is usually best to print this history during the post_navigate
+method as in the following:
+
+ use CGI::Ex::Dump qw(debug);
+ sub post_navigate { debug shift->dump_history }
+
+The following is a sample output of dump_history called from the
+sample recipe application at the end of this document. The step
+called is "view".
+
+ debug: admin/Recipe.pm line 14
+ shift->dump_history = [
+ "Elapsed: 0.00562",
+ "view - run_step - run_step - 0.00488 - 1",
+ " view - pre_step - pre_step - 0.00003 - 0",
+ " view - skip - view_skip - 0.00004 - 0",
+ " view - prepare - prepare - 0.00003 - 1",
+ " view - info_complete - info_complete - 0.00010 - 0",
+ " view - ready_validate - ready_validate - 0.00004 - 0",
+ " view - prepared_print - prepared_print - 0.00441 - 1",
+ " view - hash_base - hash_base - 0.00009 - HASH(0x84ea6ac)",
+ " view - hash_common - view_hash_common - 0.00148 - HASH(0x8310a20)",
+ " view - hash_form - hash_form - 0.00004 - HASH(0x84eaa78)",
+ " view - hash_fill - hash_fill - 0.00003 - {}",
+ " view - hash_swap - hash_swap - 0.00003 - {}",
+ " view - hash_errors - hash_errors - 0.00003 - {}",
+ " view - print - print - 0.00236 - 1",
+ " view - file_print - file_print - 0.00024 - recipe/view.html",
+ " view - name_module - name_module - 0.00007 - recipe",
+ " view - name_step - name_step - 0.00004 - view",
+ " view - swap_template - swap_template - 0.00161 - <html> ...",
+ " view - template_args - template_args - 0.00008 - HASH(0x865abf8)",
+ " view - fill_template - fill_template - 0.00018 - 1",
+ " view - fill_args - fill_args - 0.00003 - {}",
+ " view - print_out - print_out - 0.00015 - 1",
+ " view - post_print - post_print - 0.00003 - 0"
+ ];
+
+=item exit_nav_loop (method)
+
+This method should not normally used but there is no problem with
+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
+unmorphed before returning. Also - the post_navigate method will
+still be called.
+
+=item first_step (method)
+
+Returns the first step of the path. Note that first_step may not be the same
+thing as default_step if the path was overridden.
+
+=item form (method)
+
+Returns a hashref of the items passed to the CGI. Returns
+$self->{form} which defaults to CGI::Ex::get_form.
+
+=item handle_error (method)
+
+If anything dies during execution, handle_error will be called with
+the error that had happened. Default action is to die with that error.
+
+=item history (method)
+
+Returns an arrayref which contains trace history of which hooks of
+which steps were ran. Useful for seeing what happened. In general -
+each line of the history will show the current step, the hook
+requested, and which hook was actually called.
+
+The dump_history method shows a short condensed version of this
+history which makes it easier to see what path was followed.
+
+In general, the arrayref is free for anything to push onto which will
+help in tracking other occurrences in the program as well.
+
+=item init (method)
+
+Called by the default new method. Allows for any object
+initilizations that may need to take place. Default action does
+nothing.
+
+=item fill_args (hook)
+
+Returns a hashref of args that will be passed to the CGI::Ex::Fill::fill.
+It is augmented with the template to swap and the fill hash. This
+could be useful if you needed to only swap a particular form on the template
+page. Arguments are passed directly to the fill function.
+
+ sub fill_args { {target => 'my_form'} }
+
+=item fill_template (hook)
+
+Arguments are a template and a hashref. Takes the template that was
+prepared using swap_template, and swaps html form fields using the
+passed hashref. Overriding this method can control the fill behavior.
+
+Calls the fill_args hook prior to calling CGI::Ex::Fill::fill
+
+=item file_print (hook)
+
+Returns a filename of the content to be used in the default print
+hook. Adds method base_dir_rel to hook name_module, and name_step and
+adds on the default file extension found in $self->ext_print which
+defaults to the property $self->{ext_print} which will default to
+".html". Should return a filename relative to base_dir_abs that can be
+swapped using CGI::Ex::Template, or should be a scalar reference to
+the template content that can be swapped. This will be used by the
+hook print.
+
+ sub base_dir_abs { '/var/www/templates' }
+ sub base_dir_rel { 'content' }
+ sub name_module { 'recipe' }
+ sub ext_print { 'html' } # default
+
+ # ->file_print('this_step')
+ # would return 'content/recipe/this_step.html'
+ # the template engine would look in '/var/www/templates'
+ # for a file by that name
+
+It may also return a reference to a string containing the html template.
+This is useful for prototyping applications and/or keeping all of
+the data for the application in a single location.
+
+=item file_val (hook)
+
+Returns a filename containing the validation. Performs the same
+as file_print, but uses ext_val to get the extension, and it adds
+base_dir_abs onto the returned value (file_print is relative to
+base_dir_abs, while file_val is fully qualified with base_dir_abs)
+
+The file should be readable by CGI::Ex::Validate::get_validation.
+
+This hook is only necessary if the hash_validation hook has not been
+overridden.
+
+This method an also return a hashref containing the validation - but
+then you may have wanted to override the hash_validation hook.
+
+=item finalize (hook)
+
+Defaults to true. Used to do whatever needs to be done with the data once
+prepare has returned true and info_complete has returned true. On failure
+the print operations are ran. On success navigation moves on to the next
+step.
+
+This is normally were there core logic of a script will occur (such as
+adding to a database, or updating a record). At this point, the data
+should be validated. It is possible to do additional validation
+and return errors using code such as the following.
+
+ if (! $user_is_unique) {
+ $self->add_errors(username => 'The username was already used');
+ return 0;
+ }
+
+=item find_hook (method)
+
+Called by run_hook. Arguments are a hook name, a step name. It
+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->hook('finalize', 'main');
+ ### will look first for $self->main_finalize;
+ ### will then look for $self->finalize;
+
+This system is used to allow for multiple steps to be in the same
+file and still allow for moving some steps out to external sub classed
+packages (if desired).
+
+If the application has successfully morphed via the morph method and
+allow_morph then it is not necessary to add the step name to the
+beginning of the method name as the morphed packages method will
+override the base package (it is still OK to use the full method name
+"${step}_hookname").
+
+See the run_hook method and the morph method for more details.
+
+=item forbidden_step (method)
+
+Defaults to "__forbidden". The name of a step to run should the current
+step name be invalid, or if a step found by the default path method
+is invalid. See the path method.
+
+=item form_name (hook)
+
+Return the name of the form to attach the js validation to. Used by
+js_validation.
+
+=item get_pass_by_user (method)
+
+This method is passed a username and the authentication object. It
+should return the password for the given user. See the get_pass_by_user
+method of CGI::Ex::Auth for more information. Installed as a hook
+to the authentication object during the get_valid_auth method.
+
+=item get_valid_auth (method)
+
+If require_auth is true at either the application level or at the
+step level, get_valid_auth will be called.
+
+It will call auth_args to get some default args to pass to
+CGI::Ex::Auth->new. It augments the args with sensible defaults that
+App already provides (such as form, cookies, and template facilities).
+It also installs hooks for the get_pass_by_user, cleanup_user, and verify_user
+hooks of CGI::Ex::Auth.
+
+It stores the $auth->last_auth_data in $self->auth_data for later use. For
+example, to get the authenticated user:
+
+ sub require_auth { 1 }
+
+ sub cleanup_user {
+ my ($self, $user) = @_;
+ return lc $user;
+ }
+
+ sub get_pass_by_user {
+ my ($self, $user) = @_;
+ my $pass = $self->some_method_to_get_the_pass($user);
+ return $pass;
+ }
+
+ sub auth_args {
+ return {
+ login_header => '<h1>My login header</h1>',
+ login_footer => '[% TRY %][% INCLUDE login/login_footer.htm %][% CATCH %]<!-- [% error %] -->[% END %]',
+ };
+ }
+
+ sub main_hash_swap {
+ my $self = shift;
+ my $user = $self->auth_data->{'user'};
+ return {user => $user};
+ }
+
+Successful authentication is cached for the duration of the
+nav_loop so multiple steps will run the full authentication routine
+only once.
+
+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 hash_base (hook)
+
+A hash of base items to be merged with hash_form - such as pulldown
+menus, javascript validation, etc. It will now also be merged with
+hash_fill, so it can contain default fillins as well. It can be
+populated by passing a hash to ->add_to_base. By default a sub
+similar to the following is what is used for hash_common. Note the
+use of values that are code refs - so that the js_validation and
+form_name hooks are only called if requested:
+
+ sub hash_base {
+ my ($self, $step) = @_;
+ return $self->{hash_base} ||= {
+ script_name => $ENV{SCRIPT_NAME},
+ js_validation => sub { $self->run_hook('js_validation', $step) },
+ form_name => sub { $self->run_hook('form_name', $step) },
+ };
+ }
+
+=item hash_common (hook)
+
+Almost identical in function and purpose to hash_base. It is
+intended that hash_base be used for common items used in various
+scripts inheriting from a common CGI::Ex::App type parent. Hash_common
+is more intended for step level populating of both swap and fill.
+
+=item hash_errors (hook)
+
+Called in preparation for print after failed prepare, info_complete,
+or finalize. Should contain a hash of any errors that occurred. Will
+be merged into hash_form before the pass to print. Each error that
+occurred will be passed to method format_error before being added to
+the hash. If an error has occurred, the default validate will
+automatically add {has_errors =>1}. To the error hash at the time of
+validation. has_errors will also be added during the merge in case the
+default validate was not used. Can be populated by passing a hash to
+->add_to_errors or ->add_errors.
+
+=item hash_fill (hook)
+
+Called in preparation for print after failed prepare, info_complete,
+or finalize. Should contain a hash of any items needed to be filled
+into the html form during print. Items from hash_form, hash_base, and
+hash_common will be layered together. Can be populated by passing a
+hash to ->add_to_fill.
+
+By default - forms are sticky and data from previous requests will try
+and populate the form. You can use the fill_template hook to disable
+templating on a single page or on all pages.
+
+This method can be used to pre-populate the form as well (such as on an
+edit step). If a form fails validation, hash_fill will also be called
+and will only want the submitted form fields to be sticky. You can
+use the ready_validate hook to prevent pre-population in these cases as
+follows:
+
+ sub edit_hash_fill {
+ my $self = shift;
+ my $step = shift;
+ return {} if $self->run_hook('ready_validate', $step);
+
+ my %hash;
+
+ ### get previous values from the database
+
+ return \%hash;
+ }
+
+=item hash_form (hook)
+
+Called in preparation for print after failed prepare, info_complete,
+or finalize. Defaults to ->form. Can be populated by passing a hash
+to ->add_to_form.
+
+=item hash_swap (hook)
+
+Called in preparation for print after failed prepare, info_complete,
+or finalize. Should contain a hash of any items needed to be swapped
+into the html during print. Will be merged with hash_base,
+hash_common, hash_form, and hash_errors. Can be populated by passing
+a hash to ->add_to_swap.
+
+The hash will be passed as the second argument to swap_template.
+
+=item hash_validation (hook)
+
+Returns a hash of the validation information to check form against.
+By default, will look for a filename using the hook file_val and will
+pass it to CGI::Ex::Validate::get_validation. If no file_val is
+returned or if the get_validation fails, an empty hash will be returned.
+Validation is implemented by ->vob which loads a CGI::Ex::Validate object.
+
+=item info_complete (hook)
+
+Calls the ready_validate hook to see if data is ready to validate. If
+so it calls the validate hook to validate the data. Should make
+sure the data is ready and valid. Will not be run unless
+prepare returns true (default).
+
+=item insert_path (method)
+
+Arguments are the steps to insert. Can be called any time. Inserts
+the new steps at the current path location.
+
+=item is_authed (method)
+
+Returns true if the object has successful authentication data. It
+returns false if the object has not been authenticated.
+
+=item js_uri_path (method)
+
+Return the URI path where the CGI/Ex/yaml_load.js and
+CGI/Ex/validate.js files can be found. This will default to
+"$ENV{SCRIPT_NAME}/js" if the path method has not been overridden,
+otherwise it will default to "$ENV{SCRIPT_NAME}?step=js&js=" (the
+latter is more friendly with overridden paths). A default handler for
+the "js" step has been provided in "js_run_step" (this handler will
+nicely print out the javascript found in the js files which are
+included with this distribution. js_run_step will work properly with the
+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.
+
+=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');
+
+=item last_step (method)
+
+Returns the last step of the path. Can be used to jump to the last step.
+
+=item morph (method)
+
+Allows for temporarily "becoming" another object type for the
+execution of the current step. This allows for separating some steps
+out into their own packages.
+
+Morph will only run if the method allow_morph returns true.
+Additionally if the allow_morph returns a hash ref, morph will only
+run if the step being morphed to is in the hash. Morph also passes
+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:
+
+ Call the morph_package hook (which would default to returning
+ Foo::Bar::MyStep in this case)
+
+ Translate this to a package filename (Foo/Bar/MyStep.pm) and try
+ and require it, if the file can be required, the object is blessed
+ into that package.
+
+ Call the fixup_after_morph method.
+
+ Continue on with the run_step for the current step.
+
+At any exit point of the loop, the unmorph call is made which
+re-blesses the object into the original package.
+
+Samples of allowing morph:
+
+ sub allow_morph { 1 }
+
+ 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
+call. Defaults to using the current object type as a base. For
+example, if the current object running is a Foo::Bar object and the
+step running is my_step, then morph_package will return
+Foo::Bar::MyStep.
+
+Because of the way that run_hook works, it is possible that several
+steps could be located in the same external file and overriding morph_package
+could allow for this to happen.
+
+See the morph method.
+
+=item name_module (hook)
+
+Return the name (relative path) that should be pre-pended to name_step
+during the default file_print and file_val lookups. Defaults to
+the value in $self->{name_module} which in turn defaults to the name
+of the current script.
+
+ cgi-bin/my_app.pl => my_app
+ cgi/my_app => my_app
+
+This method is provided so that each cgi or mod_perl application can
+have its own directory for storing html for its steps.
+
+See the file_print method for more information.
+
+=item name_step (hook)
+
+Return the step (appended to name_module) that should used when
+looking up the file in file_print and file_val lookups. Defaults to
+the current step.
+
+=item nav_loop (method)
+
+This is the main loop runner. It figures out the current path
+and runs all of the appropriate hooks for each step of the path. If
+nav_loop runs out of steps to run (which happens if no path is set, or if
+all other steps run successfully), it will insert the ->default_step into
+the path and run nav_loop again (recursively). This way a step is always
+assured to run. There is a method ->recurse_limit (default 15) that
+will catch logic errors (such as inadvertently running the same
+step over and over and over because there is either no hash_validation,
+or the data is valid but the set_ready_validate(0) method was not called).
+
+=item navigate (method)
+
+Takes a class name or a CGI::Ex::App object as arguments. If a class
+name is given it will call the "new" method to instantiate an object
+by that class (passing any extra arguments to the new method). All
+returns from navigate will return the object.
+
+The method navigate is essentially a safe wrapper around the ->nav_loop
+method. It will catch any dies and pass them to ->handle_error.
+
+This starts the process flow for the path and its steps.
+
+=item navigate_authenticated (method)
+
+Same as the method navigate but sets require_auth(1) before
+running. See the require_auth method.
+
+=item new (class method)
+
+Object creator. Takes a hashref of arguments that will become the
+initial properties of the object. Calls the init method once the
+object has been blessed to allow for any other initilizations.
+
+ my $app = MyApp->new({name_module => 'my_app'});
+
+=item next_step (method)
+
+Returns the next step in the path. If there is no next step, it
+returns the default_step.
+
+=item path (method)
+
+Return an arrayref (modifiable) of the steps in the path. For each
+step the run_step hook and all of its remaining hooks will be run.
+
+Hook methods are looked up and ran using the method "run_hook" which
+uses the method "find_hook" to lookup the hook. A history of ran
+hooks is stored in the array ref returned by $self->history.
+
+If path has not been defined, the method will look first in the form
+for a key by the name found in ->step_key. It will then look in
+$ENV{'PATH_INFO'}. It will use this step to create a path with that
+one step as its contents. If a step is passed in via either of these
+ways, the method will call valid_steps to make sure that the step
+is valid (by default valid_steps returns undef - which means that
+any step is valid). Any step beginning with _ can not be passed in
+and are intended for use on private paths. If a non-valid step is
+found, then path will be set to contain a single step of ->forbidden_step.
+
+For the best functionality, the arrayref returned should be the same
+reference returned for every call to path - this ensures that other
+methods can add to the path (and will most likely break if the
+arrayref is not the same).
+
+If navigation runs out of steps to run, the default step found in
+default_step will be run. This is what allows for us to default
+to the "main" step for many applications.
+
+=item post_loop (method)
+
+Ran after all of the steps in the loop have been processed (if
+prepare, info_complete, and finalize were true for each of the steps).
+If it returns a true value the navigation loop will be aborted. If it
+does not return true, navigation continues by then inserting the step
+$self->default_step and running $self->nav_loop again (recurses) to
+fall back to the default step.
+
+=item post_navigate (method)
+
+Called from within navigate. Called after the nav_loop has finished
+running but within the eval block to catch errors. Will only run if
+there were no errors which died during the nav_loop process.
+
+It can be disabled from running by setting the _no_post_navigate
+property.
+
+If per-step authentication is enabled and authentication fails,
+the post_navigate method will still be called (the post_navigate
+method can check the ->is_authed method to change behavior). If
+application level authentication is enabled and authentication
+fails, none of the pre_navigate, nav_loop, or post_navigate methods
+will be called.
+
+=item post_print (hook)
+
+A hook which occurs after the printing has taken place. Is only run
+if the information was not complete. Useful for cases such as
+printing rows of a database query after displaying a query form.
+
+=item post_step (hook)
+
+Ran at the end of the step's loop if prepare, info_complete, and
+finalize all returned true. Allows for cleanup. If a true value is
+returned, execution of navigate is returned and no more steps are
+processed.
+
+=item pre_loop (method)
+
+Called right before the navigation loop is started (at the beginning
+of nav_loop). At this point the path is set (but could be modified).
+The only argument is a reference to the path array. If it returns a
+true value - the navigation routine is aborted.
+
+=item pre_navigate (method)
+
+Called at the very beginning of the navigate method, but within the
+eval block to catch errors. Called before the nav_loop method is
+started. If a true value is returned then navigation is skipped (the
+nav_loop is never started).
+
+=item pre_step (hook)
+
+Ran at the beginning of the loop before prepare, info_compelete, and
+finalize are called. If it returns true, execution of nav_loop is
+returned and no more steps are processed..
+
+=item prepare (hook)
+
+Defaults to true. A hook before checking if the info_complete is true.
+Intended to be used to cleanup the form data.
+
+=item prepared_print (hook)
+
+Called when any of prepare, info_complete, or finalize fail. Prepares
+a form hash and a fill hash to pass to print. The form hash is primarily
+intended for use by the templating system. The fill hash is intended
+to be used to fill in any html forms.
+
+=item previous_step (method)
+
+List the step previous to this one. Will return '' if there is no previous step.
+
+=item print (hook)
+
+Take the information generated by prepared_print, format it, and print it out.
+Default incarnation uses CGI::Ex::Template which is compatible with
+Template::Toolkit. 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
+
+=item ready_validate (hook)
+
+Should return true if enough information is present to run validate.
+Default is to look if $ENV{'REQUEST_METHOD'} is 'POST'. A common
+usage is to pass a common flag in the form such as 'processing' => 1
+and check for its presence - such as the following:
+
+ sub ready_validate { shift->form->{'processing'} }
+
+Changing the behavior of ready_validate can help in making wizard type
+applications.
+
+=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 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
+quickly. It is safe to raise this as high as is necessary - so long
+as it is intentional.
+
+Often the limit is reached if a step did not have a validation hash,
+or if the set_ready_validate(0) method was not called once the data
+had been successfully validated and acted upon.
+
+=item replace_path (method)
+
+Arguments are the steps used to replace. Can be called any time.
+Replaces the remaining steps (if any) of the current path.
+
+=item require_auth (method)
+
+Default undef. Can return either a true value or a hashref of step names.
+
+If a hashref of stepnames is returned, authentication will be turned on
+at the step level. In this mode if any step is accessed, the get_valid_auth
+method will be called. If it fails, then the nav_loop will be stopped
+(the post_navigate method will be called - use the is_authed method to perform
+different functions). Any step of the path not in the hash will not require
+authentication. For example, to add authentication to add authentication
+to the add, edit and delete steps you could do:
+
+ sub require_auth { {add => 1, edit => 1, delete => 1} }
+
+If a non-hash true value is returned from the require_auth method then
+authentication will take place before the pre_navigation or the nav_loop methods.
+If authentication fails the navigation process is exited (the post_navigate
+method will not be called).
+
+ sub require_auth { 1 }
+
+Alternatively you can also could do either of the following:
+
+ __PACKAGE__->navigate_authenticated; # instead of __PACKAGE__->navigate;
+
+ # OR
+
+ sub init { shift->require_auth(1) }
+
+ # OR
+
+ __PACKAGE__->new({require_auth => 1}->navigate;
+
+If get_valid_auth returns true, in either case, the is_authed method will
+return true and the auth_data will contain the authenticated user's data.
+If it returns false, auth_data may possibly contain a defined but false
+data object with details as to why authentication failed.
+
+See the get_valid_auth method.
+
+=item run_hook (method)
+
+Arguments are a hook name and the step to find the hook for. Calls
+the find_hook method to get a code ref which it then calls and returns
+the result passing any extra arguments to run_hook as arguments to the
+code ref.
+
+Each call to run_hook is logged in the arrayref returned by the
+history method. This information is summarized in the dump_history
+method and is useful for tracing the flow of the program.
+
+The run_hook method is part of the core of CGI::Ex::App. It allows
+for an intermediate layer in normal method calls. Because of
+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_step (hook)
+
+Runs all of the hooks specific to each step, beginning with pre_step
+and ending with post_step (for a full listing of steps, see the
+section on process flow). Called after ->morph($step) has been run.
+If this hook returns true, the nav_loop is exited (meaning the
+run_step hook displayed a printed page). If it returns false, the
+nav_loop continues on to run the next step.
+
+This hook performs the same base functionality as a method defined in
+CGI::Applications ->run_modes. The default run_step method provides
+much more granular control over the flow of the CGI.
+
+=item set_path (method)
+
+Arguments are the steps to set. Should be called before navigation
+begins. This will set the path arrayref to the passed steps.
+
+This method is not normally used.
+
+=item set_ready_validate (method)
+
+Sets that the validation is ready to validate. Should set the value
+checked by the hook ready_validate. The following would complement the
+processing flag above:
+
+ sub set_ready_validate {
+ my $self = shift;
+ if (shift) {
+ $self->form->{'processing'} = 1;
+ } else {
+ delete $self->form->{'processing'};
+ }
+ }
+
+Note that for this example the form key "processing" was deleted. This
+is so that the call to fill in any html forms won't swap in a value of
+zero for form elements named "processing."
+
+=item skip (hook)
+
+Ran at the beginning of the loop before prepare, info_complete, and
+finalize are called. If it returns true, nav_loop moves on to the
+next step (the current step is skipped).
+
+=item stash (method)
+
+Returns a hashref that can store arbitrary user space data without
+worrying about overwriting the internals of the application.
+
+=item step_key (method)
+
+Should return the keyname that will be used by the default "path"
+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).
+
+Arguments are the template and the swap hashref. The template can be either a
+scalar reference to the actual content, or the filename of the content. If the
+filename is specified - it should be relative to base_dir_abs.
+
+=item template_args (hook)
+
+Returns a hashref of args that will be passed to the "new" method of CGI::Ex::Template.
+By default this hashref contains INCLUDE_PATH which is set equal to base_dir_abs.
+It can be augmented with any arguments that CGI::Ex::Template would understand.
+
+ sub template_args {
+ return {
+ INCLUDE_PATH => '/my/own/include/path',
+ WRAPPER => 'wrappers/main_wrapper.html',
+ };
+ }
+
+=item unmorph (method)
+
+Allows for returning an object back to its previous blessed state if
+the "morph" method was successful in morphing the App object. This
+only happens if the object was previously morphed into another object
+type. Before the object is re-blessed the method fixup_before_unmorph
+is called.
+
+See allow_morph and morph.
+
+=item valid_steps (method)
+
+Called by the default path method. Should return a hashref of path
+steps that are allowed. If the current step is not found in the hash
+(or is not the default_step or js_step) the path method will return a
+single step of ->forbidden_step and run its hooks. If no hash or undef is
+returned, all paths are allowed (default). A key "forbidden_step"
+containing the step that was not valid will be placed in the stash.
+Often the valid_steps method does not need to be defined as arbitrary
+method calls are not possible with CGI::Ex::App.
+
+Any steps that begin with _ are also "not" valid for passing in via the form
+or path info. See the path method.
+
+Also, the pre_step, skip, prepare, and info_complete hooks allow for validating
+the data before running finalize.
+
+=item validate (hook)
+
+Runs validation on the information posted in $self->form. Uses
+CGI::Ex::Validate for the default validation. Calls the hook
+hash_validation to load validation information. Should return true if
+the form passed validation and false otherwise. Errors are stored as
+a hash in $self->{hash_errors} via method add_errors and can be
+checked for at a later time with method has_errors (if the default
+validate was used).
+
+There are many ways and types to validate the data. Please see the L<CGI::Ex::Validate>
+module.
+
+Upon success, it will look through all of the items which were
+validated, if any of them contain the keys append_path, insert_path,
+or replace_path, that method will be called with the value as
+arguments. This allows for the validation to apply redirection to the
+path. A validation item of:
+
+ {field => 'foo', required => 1, append_path => ['bar', 'baz']}
+
+would append 'bar' and 'baz' to the path should all validation succeed.
+
+=item verify_user (method)
+
+Installed as a hook to CGI::Ex::App during get_valid_auth. Should return
+true if the user is ok. Default is to always return true. This can be
+used to abort early before the get_pass_by_user hook is called.
+
+ sub verify_user {
+ my ($self, $user) = @_;
+ return 0 if $user eq 'paul'; # don't let paul in
+ return 1; # let anybody else in
+ }
+
+=back
+
+=head1 OTHER APPLICATION MODULES
+
+The concepts used in CGI::Ex::App are not novel or unique. However, they
+are all commonly used and very useful. All application builders were
+built because somebody observed that there are common design patterns
+in CGI building. CGI::Ex::App differs in that it has found more common design
+patterns of CGI's than some and tries to get in the way less than others.
+
+CGI::Ex::App is intended to be sub classed, and sub sub classed, and each step
+can choose to be sub classed or not. CGI::Ex::App tries to remain simple
+while still providing "more than one way to do it." It also tries to avoid
+making any sub classes have to call ->SUPER:: (although that is fine too).
+
+There are certainly other modules for building CGI applications. The
+following is a short list of other modules and how CGI::Ex::App is
+different.
+
+=over 4
+
+=item C<CGI::Application>
+
+Seemingly the most well know of application builders.
+CGI::Ex::App is different in that it:
+
+ * Uses Template::Toolkit compatible CGI::Ex::Template by default
+ CGI::Ex::App can easily use another toolkit by simply
+ overriding the ->swap_template method.
+ CGI::Application uses HTML::Template.
+ * Offers integrated data validation.
+ CGI::Application has had custom plugins created that
+ add some of this functionality. CGI::Ex::App has the benefit
+ that validation is automatically available in javascript as well.
+ * Allows the user to print at any time (so long as proper headers
+ are sent. CGI::Application requires data to be pipelined.
+ * Offers hooks into the various phases of each step ("mode" in
+ CGI::Application lingo). CGI::Application provides only ->runmode
+ which is only a dispatch.
+ * Support for easily jumping around in navigation steps.
+ * Support for storing some steps in another package.
+
+CGI::Ex::App and CGI::Application are similar in that they take care
+of handling headers and they allow for calling other "runmodes" from
+within any given runmode. CGI::Ex::App's ->run_step is essentially
+equivalent to a method call defined in CGI::Application's ->run_modes.
+The ->run method of CGI::Application starts the application in the same
+manner as CGI::Ex::App's ->navigate call. Many of the hooks around
+CGI::Ex::App's ->run_step call are similar in nature to those provided by
+CGI::Application.
+
+=item C<CGI::Prototype>
+
+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).
+CGI::Ex::App is differrent in that it:
+
+ * Offers integrated data validation.
+ CGI::Application has had custom addons created that
+ add some of this functionality. CGI::Ex::App has the benefit
+ that once validation is created,
+ * Offers more hooks into the various phases of each step.
+ * Support for easily jumping around in navigation steps.
+ * Support for storing only some steps in another package.
+
+=back
+
+
+=head1 SIMPLE EXTENDED EXAMPLE
+
+The following example shows the creation of a basic recipe
+database. It requires the use of DBD::SQLite, but that is all.
+Once you have configured the db_file and base_dir_abs methods
+of the "recipe" file, you will have a working script that
+does CRUD for the recipe table. The observant reader may ask - why
+not use Catalyst or Ruby on Rails? The observant programmer will
+reply that making a framework do something simple is easy, but making
+it do something complex is complex and any framework that tries to
+do the those complex things for you is too complex. CGI::Ex::App
+lets you write the complex logic but gives you the ability to
+not worry about the boring details such as template engines,
+or sticky forms, or cgi parameters, or data validation. Once
+you are setup and are running, you are only left with providing
+the core logic of the application.
+
+ ### File: /var/www/cgi-bin/recipe (depending upon Apache configuration)
+ ### --------------------------------------------
+ #!/usr/bin/perl -w
+
+ use lib qw(/var/www/lib);
+ use Recipe;
+ Recipe->navigate;
+
+
+ ### File: /var/www/lib/Recipe.pm
+ ### --------------------------------------------
+ package Recipe;
+
+ use strict;
+ use base qw(CGI::Ex::App);
+ use CGI::Ex::Dump qw(debug);
+
+ use DBI;
+ use DBD::SQLite;
+
+ ###------------------------------------------###
+
+ sub post_navigate {
+ # show what happened
+ debug shift->dump_history;
+ }
+
+ sub base_dir_abs { '/var/www/templates' }
+
+ sub base_dir_rel { 'content' }
+
+ sub db_file { '/var/www/recipe.sqlite' }
+
+ sub dbh {
+ my $self = shift;
+ if (! $self->{'dbh'}) {
+ my $file = $self->db_file;
+ my $exists = -e $file;
+ $self->{'dbh'} = DBI->connect("dbi:SQLite:dbname=$file", '', '',
+ {RaiseError => 1});
+ $self->create_tables if ! $exists;
+ }
+ return $self->{'dbh'};
+ }
+
+ sub create_tables {
+ my $self = shift;
+
+ $self->dbh->do("CREATE TABLE recipe (
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+ title VARCHAR(50) NOT NULL,
+ ingredients VARCHAR(255) NOT NULL,
+ directions VARCHAR(255) NOT NULL,
+ date_added VARCHAR(20) NOT NULL
+ )");
+ }
+
+ ###----------------------------------------------------------------###
+
+ sub main_info_complete { 0 }
+
+ sub main_hash_swap {
+ my $self = shift;
+
+ my $s = "SELECT id, title, date_added
+ FROM recipe
+ ORDER BY date_added";
+ my $data = $self->dbh->selectall_arrayref($s);
+ my @data = map {my %h; @h{qw(id title date_added)} = @$_; \%h} @$data;
+
+ return {
+ recipies => \@data,
+ };
+ }
+
+ ###----------------------------------------------------------------###
+
+ sub add_name_step { 'edit' }
+
+ sub add_hash_validation {
+ return {
+ 'group order' => [qw(title ingredients directions)],
+ title => {
+ required => 1,
+ max_len => 30,
+ },
+ ingredients => {
+ required => 1,
+ max_len => 255,
+ },
+ directions => {
+ required => 1,
+ max_len => 255,
+ },
+ };
+ }
+
+ sub add_finalize {
+ my $self = shift;
+ my $form = $self->form;
+
+ my $s = "SELECT COUNT(*) FROM recipe WHERE title = ?";
+ my ($count) = $self->dbh->selectrow_array($s, {}, $form->{'title'});
+ if ($count) {
+ $self->add_errors(title => 'A recipe by this title already exists');
+ return 0;
+ }
+
+ $s = "INSERT INTO recipe (title, ingredients, directions, date_added)
+ VALUES (?, ?, ?, ?)";
+ $self->dbh->do($s, {}, $form->{'title'},
+ $form->{'ingredients'},
+ $form->{'directions'},
+ scalar(localtime));
+
+ $self->add_to_form(success => "Recipe added to the database");
+
+ return 1;
+ }
+
+ ###----------------------------------------------------------------###
+
+ sub edit_skip { shift->form->{'id'} ? 0 : 1 }
+
+ sub edit_hash_common {
+ my $self = shift;
+ return {} if $self->ready_validate;
+
+ my $sth = $self->dbh->prepare("SELECT * FROM recipe WHERE id = ?");
+ $sth->execute($self->form->{'id'});
+ my $hash = $sth->fetchrow_hashref;
+
+ return $hash;
+ }
+
+ sub edit_hash_validation { shift->add_hash_validation(@_) }
+
+ sub edit_finalize {
+ my $self = shift;
+ my $form = $self->form;
+
+ my $s = "SELECT COUNT(*) FROM recipe WHERE title = ? AND id != ?";
+ my ($count) = $self->dbh->selectrow_array($s, {}, $form->{'title'}, $form->{'id'});
+ if ($count) {
+ $self->add_errors(title => 'A recipe by this title already exists');
+ return 0;
+ }
+
+ my $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?";
+ $self->dbh->do($s, {}, $form->{'title'},
+ $form->{'ingredients'},
+ $form->{'directions'},
+ $form->{'id'});
+
+ $self->add_to_form(success => "Recipe updated in the database");
+
+ return 1;
+ }
+
+ ###----------------------------------------------------------------###
+
+ sub view_skip { shift->edit_skip(@_) }
+
+ sub view_hash_common { shift->edit_hash_common(@_) }
+
+ ###----------------------------------------------------------------###
+
+ sub delete_skip { shift->edit_skip(@_) }
+
+ sub delete_info_complete { 1 }
+
+ sub delete_finalize {
+ my $self = shift;
+ $self->dbh->do("DELETE FROM recipe WHERE id = ?", {}, $self->form->{'id'});
+
+ $self->add_to_form(success => "Recipe deleted from the database");
+ return 1;
+ }
+
+ 1;
+
+ __END__
+
+
+
+ File: /var/www/templates/content/recipe/main.html
+ ### --------------------------------------------
+ <html>
+ <head>
+ <title>Recipe DB</title>
+ </head>
+ <h1>Recipe DB</h1>
+
+ [% IF success %]<span style="color:darkgreen"><h2>[% success %]</h2></span>[% END %]
+
+ <table style="border:1px solid blue">
+ <tr><th>#</th><th>Title</th><th>Date Added</th></tr>
+
+ [% FOR row IN recipies %]
+ <tr>
+ <td>[% loop.count %].</td>
+ <td><a href="[% script_name %]/view?id=[% row.id %]">[% row.title %]</a>
+ (<a href="[% script_name %]/edit?id=[% row.id %]">Edit</a>)
+ </td>
+ <td>[% row.date_added %]</td>
+ </tr>
+ [% END %]
+
+ <tr><td colspan=2 align=right><a href="[% script_name %]/add">Add new recipe</a></td></tr>
+ </table>
+
+ </html>
+
+
+ File: /var/www/templates/content/recipe/edit.html
+ ### --------------------------------------------
+ <html>
+ <head>
+ <title>[% step == 'add' ? "Add" : "Edit" %] Recipe</title>
+ </head>
+ <h1>[% step == 'add' ? "Add" : "Edit" %] Recipe</h1>
+
+ <form method=post name=[% form_name %]>
+ <input type=hidden name=step>
+
+ <table>
+
+ [% IF step != 'add' ~%]
+ <tr>
+ <td><b>Id:</b></td><td>[% id %]</td></tr>
+ <input type=hidden name=id>
+ </tr>
+ <tr>
+ <td><b>Date Added:</b></td><td>[% date_added %]</td></tr>
+ </tr>
+ [% END ~%]
+
+ <tr>
+ <td valign=top><b>Title:</b></td>
+ <td><input type=text name=title>
+ <span style='color:red' id=title_error>[% title_error %]</span></td>
+ </tr>
+ <tr>
+ <td valign=top><b>Ingredients:</b></td>
+ <td><textarea name=ingredients rows=10 cols=40 wrap=physical></textarea>
+ <span style='color:red' id=ingredients_error>[% ingredients_error %]</span></td>
+ </tr>
+ <tr>
+ <td valign=top><b>Directions:</b></td>
+ <td><textarea name=directions rows=10 cols=40 wrap=virtual></textarea>
+ <span style='color:red' id=directions_error>[% directions_error %]</span></td>
+ </tr>
+ <tr>
+ <td colspan=2 align=right>
+ <input type=submit value="[% step == 'add' ? 'Add' : 'Update' %]"></td>
+ </tr>
+ </table>
+ </form>
+
+ (<a href="[% script_name %]">Main Menu</a>)
+ [% IF step != 'add' ~%]
+ (<a href="[% script_name %]/delete?id=[% id %]">Delete this recipe</a>)
+ [%~ END %]
+
+ [% js_validation %]
+
+ </html>
+
+
+ File: /var/www/templates/content/recipe/view.html
+ ### --------------------------------------------
+ <html>
+ <head>
+ <title>[% title %] - Recipe DB</title>
+ </head>
+ <h1>[% title %]</h1>
+ <h3>Date Added: [% date_added %]</h3>
+
+ <h2>Ingredients</h2>
+ [% ingredients %]
+
+ <h2>Directions</h2>
+ [% directions %]
+
+ <hr>
+ (<a href="[% script_name %]">Main Menu</a>)
+ (<a href="[% script_name %]/edit?id=[% id %]">Edit this recipe</a>)
+
+ </html>
+
+ ### --------------------------------------------
+
+Notes:
+
+The dbh method returns an SQLite dbh handle and auto creates the
+schema. You will normally want to use MySQL or Oracle, or Postgres
+and you will want your schema to NOT be auto-created.
+
+This sample uses hand rolled SQL. Class::DBI or a similar module
+might make this example shorter. However, more complex cases that
+need to involve two or three or four tables would probably be better
+off using the hand crafted SQL.
+
+This sample uses SQL. You could write the application to use whatever
+storage you want - or even to do nothing with the submitted data.
+
+We had to write our own HTML (Catalyst and Ruby on Rails do this for
+you). For most development work - the HTML should be in a static
+location so that it can be worked on by designers. It is nice that
+the other frameworks give you stub html - but that is all it is. It
+is worth about as much as copying and pasting the above examples. All
+worthwhile HTML will go through a non-automated design/finalization
+process.
+
+The add step used the same template as the edit step. We did
+this using the add_name_step hook which returned "edit". The template
+contains IF conditions to show different information if we were in
+add mode or edit mode.
+
+We reused code, validation, and templates. Code and data reuse is a
+good thing.
+
+The edit_hash_common returns an empty hashref if the form was ready to
+validate. When hash_common is called and the form is ready to
+validate, that means the form failed validation and is now printing
+out the page. To let us fall back and use the "sticky" form fields
+that were just submitted, we need to not provide values in the
+hash_common method.
+
+We use hash_common. Values from hash_common are used for both
+template swapping and filling. We could have used hash_swap and
+hash_fill independently.
+
+The hook main_info_complete is hard coded to 0. This basically says
+that we will never try and validate or finalize the main step - which
+is most often the case.
+
+=head1 SEPARATING STEPS INTO SEPARATE FILES
+
+It may be useful sometimes to separate some or all of the steps of an
+application into separate files. This is the way that CGI::Prototype
+works. This is useful in cases were some steps and their hooks are
+overly large - or are seldom used.
+
+The following modifications can be made to the previous "recipe db"
+example that would move the "delete" step into its own file. Similar
+actions can be taken to break other steps into their own file as well.
+
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add the following line:
+ ### --------------------------------------------
+
+ sub allow_morph { 1 }
+
+
+ ### File: /var/www/lib/Recipe/Delete.pm
+ ### Remove the delete_* subs from lib/Recipe.pm
+ ### --------------------------------------------
+ package Recipe::Delete;
+
+ use strict;
+ use base qw(Recipe);
+
+ sub skip { shift->edit_skip(@_) }
+
+ sub info_complete { 1 }
+
+ sub finalize {
+ my $self = shift;
+ $self->dbh->do("DELETE FROM recipe WHERE id = ?", {}, $self->form->{'id'});
+
+ $self->add_to_form(success => "Recipe deleted from the database");
+ return 1;
+ }
+
+
+Notes:
+
+The hooks that are called (skip, info_complete, and finalize) do not
+have to be prefixed with the step name because they are now in their
+own individual package space. However, they could still be named
+delete_skip, delete_info_complete, and delete_finalize and the
+run_hook method will find them (this would allow several steps with
+the same "morph_package" to still be stored in the same external
+module).
+
+The method allow_morph is passed the step that we are attempting to
+morph to. If allow_morph returns true every time, then it will try
+and require the extra packages every time that step is ran. You could
+limit the morphing process to run only on certain steps by using code
+similar to the following:
+
+ sub allow_morph { return {delete => 1} }
+
+ # OR
+
+ sub allow_morph {
+ my ($self, $step) = @_;
+ return ($step eq 'delete') ? 1 : 0;
+ }
+
+The CGI::Ex::App temporarily blesses the object into the
+"morph_package" for the duration of the step and re-blesses it into the
+original package upon exit. See the morph method and allow_morph for more
+information.
+
+=head1 RUNNING UNDER MOD_PERL
+
+The previous samples are essentially suitable for running under flat CGI,
+Fast CGI, or mod_perl Registry or mod_perl PerlRun type environments. It
+is very easy to move the previous example to be a true mod_perl handler.
+
+To convert the previous recipe example, simply add the following:
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add the following lines:
+ ### --------------------------------------------
+
+ sub handler {
+ Recipe->navigate;
+ return;
+ }
+
+
+ ### File: apache2.conf - or whatever your apache conf file is.
+ ### --------------------------------------------
+ <Location /recipe>
+ SetHandler perl-script
+ PerlHandler Recipe
+ </Location>
+
+Notes:
+
+Both the /cgi-bin/recipe version and the /recipe version can co-exist.
+One of them will be a normal cgi and the other will correctly use
+mod_perl hooks for headers.
+
+Setting the location to /recipe means that the $ENV{SCRIPT_NAME} will
+also be set to /recipe. This means that name_module method will
+resolve to "recipe". If a different URI location is desired such as
+"/my_cool_recipe" but the program is to use the same template content
+(in the /var/www/templates/content/recipe directory), then we would
+need to explicitly set the "name_module" parameter. It could be done
+in either of the following ways:
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add the following line:
+ ### --------------------------------------------
+
+ sub name_module { 'recipe' }
+
+ # OR
+
+ sub init {
+ my $self = shift;
+ $self->{'name_module'} = 'recipe';
+ }
+
+In most use cases it isn't necessary to set name_module, but it also
+doesn't hurt and in all cases it is more descriptive to anybody who is
+going to maintain the code later.
+
+=head1 ADDING AUTHENTICATION TO THE ENTIRE APPLICATION
+
+Having authentication is sometimes a good thing. To force
+the entire application to be authenticated (require a valid username
+and password before doing anything) you could do the following.
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add
+ ### --------------------------------------------
+
+ sub get_pass_by_user {
+ my $self = shift;
+ my $user = shift;
+ my $pass = $self->lookup_and_cache_the_pass($user);
+ return $pass;
+ }
+
+
+ ### File: /var/www/cgi-bin/recipe (depending upon Apache configuration)
+ ### Change the line with ->navigate; to
+ ### --------------------------------------------
+
+ Recipe->navigate_authenticated;
+
+ # OR
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add
+ ### --------------------------------------------
+
+ sub require_auth { 1 }
+
+ # OR
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add
+ ### --------------------------------------------
+
+ sub init { shift->require_auth(1) }
+
+See the require_auth, get_valid_auth, and auth_args methods for more information.
+Also see the L<CGI::Ex::Auth> perldoc.
+
+=head1 ADDING AUTHENTICATION TO INDIVIDUAL STEPS
+
+Sometimes you may only want to have certain steps require
+authentication. For example, in the previous recipe example we
+might want to let the main and view steps be accessible to anybody,
+but require authentication for the add, edit, and delete steps.
+
+To do this, we would do the following to the original example (the
+navigation must start with ->navigate. Starting with ->navigate_authenticated
+will cause all steps to require validation):
+
+ ### File: /var/www/lib/Recipe.pm
+ ### Same as before but add
+ ### --------------------------------------------
+
+ sub get_pass_by_user {
+ my $self = shift;
+ my $user = shift;
+ my $pass = $self->lookup_and_cache_the_pass($user);
+ return $pass;
+ }
+
+ sub require_auth { {add => 1, edit => 1, delete => 1} }
+
+That's it. The add, edit, and delete steps will now require authentication.
+See the require_auth, get_valid_auth, and auth_args methods for more information.
+Also see the L<CGI::Ex::Auth> perldoc.
+
+=head1 THANKS
+
+ Bizhosting.com - giving a problem that fit basic design patterns.
+
+ Earl Cahill - pushing the idea of more generic frameworks.
+
+ Adam Erickson - design feedback, bugfixing, feature suggestions.
+
+ James Lance - design feedback, bugfixing, feature suggestions.
+
+=head1 AUTHOR
+
+Paul Seamons <paul at seamons dot com>
+
+=cut
package CGI::Ex::Auth;
-### CGI Extended Application
+=head1 NAME
+
+CGI::Ex::Auth - Handle logins nicely.
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
-
use strict;
-use vars qw($USE_PLAINTEXT
- $CHECK_CRYPTED
- $EXPIRE_LOGINS
- $FAILED_SLEEP
- $VERSION
- );
-
-use CGI::Ex::Dump qw(debug);
+use vars qw($VERSION);
+
use MIME::Base64 qw(encode_base64 decode_base64);
+use Digest::MD5 qw(md5_hex);
+use CGI::Ex;
-BEGIN {
- $VERSION = '0.10';
- $CHECK_CRYPTED = 1 if ! defined $CHECK_CRYPTED;
- $FAILED_SLEEP = 2 if ! defined $FAILED_SLEEP;
- $EXPIRE_LOGINS = 6 * 3600 if ! defined $EXPIRE_LOGINS;
- #if ($ENV{MOD_PERL}) {
- # require Digest::SHA1;
- # require Digest::MD5;
- #}
-}
+$VERSION = '2.00';
###----------------------------------------------------------------###
sub new {
- my $class = shift || __PACKAGE__;
- my $self = ref($_[0]) ? shift : {@_};
- bless $self, $class;
- $self->init();
- return $self;
+ my $class = shift || __PACKAGE__;
+ my $args = shift || {};
+ return bless {%$args}, $class;
}
-sub init {}
+sub get_valid_auth {
+ my $self = shift;
+ $self = $self->new(@_) if ! ref $self;
-###----------------------------------------------------------------###
+ ### 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" };
+ return;
+ }
-sub require_auth {
- my $self = shift;
- $self = __PACKAGE__->new($self) if ! UNIVERSAL::isa($self, __PACKAGE__);
+ my $form = $self->form;
+ my $cookies = $self->cookies;
+ my $key_l = $self->key_logout;
+ my $key_c = $self->key_cookie;
+ my $has_cookies = scalar %$cookies;
+
+ ### allow for logout
+ if ($form->{$key_l}) {
+ $self->delete_cookie({key => $key_c});;
+ $self->location_bounce($self->logout_redirect);
+ eval { die "Logging out" };
+ return;
+ }
- ### shortcut that will print a js file as needed
- if ($ENV{PATH_INFO} && $ENV{PATH_INFO} =~ m|^/js/(CGI/Ex/\w+\.js)$|) {
- $self->cgix->print_js($1);
- return 0;
- }
+ my $had_form_info;
+ foreach ([$form, $self->key_user, 1],
+ [$cookies, $key_c, 0],
+ ) {
+ my ($hash, $key, $is_form) = @$_;
+ next if ! defined $hash->{$key};
+ $had_form_info ++ if $is_form;
+
+ ### if it looks like a bare username (as in they didn't have javascript)- add in other items
+ my $data;
+ if ($is_form
+ && $hash->{$key} !~ m|^[^/]+/|
+ && defined $hash->{ $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,
+ payload => delete $hash->{ $self->key_payload } || '',
+ },
+ from => 'form',
+ }) || next;
+
+ } else {
+ $data = $self->verify_token({token => $hash->{$key}, from => ($is_form ? 'form' : 'cookie')}) || next;
+ delete $hash->{$key} if $is_form;
+ }
- my $form = $self->form;
- my $cookies = $self->cookies;
- my $key_l = $self->key_logout;
- my $key_c = $self->key_cookie;
- my $key_u = $self->key_user;
- my $key_p = $self->key_pass;
- my $key_chk = $self->key_cookie_check;
- my $had_form_info = 0;
-
- ### if they've passed us information - try and use it
- if ($form->{$key_l}) {
- $self->delete_cookie;
-
- } elsif (exists($form->{$key_u}) && exists($form->{$key_p})) {
- if ($self->verify_userpass($form->{$key_u}, $form->{$key_p})) {
- my $has_cookies = scalar keys %$cookies;
- my $user = $form->{$key_u};
- my $str = encode_base64(join(":", delete($form->{$key_u}), delete($form->{$key_p})), "");
- my $key_s = $self->key_save;
- $self->set_cookie($str, delete($form->{$key_s}));
- #return $self->success($user); # assume that cookies will work - if not next page will cause login
- #### this may actually be the nicer thing to do in the common case - except for the nasty looking
- #### url - all things considered - should really get location boucing to work properly while being
- #### able to set a cookie at the same time
-
- if ($has_cookies) {
- return $self->success($user); # assuming if they have cookies - the one we set will work
- } else {
- $form->{$key_chk} = time();
- my $key_r = $self->key_redirect;
- if (! $form->{$key_r}) {
- my $script = $ENV{SCRIPT_NAME} || die "Missing SCRIPT_NAME";
- my $info = $ENV{PATH_INFO} || '';
- my $query = $self->cgix->make_form($form);
- $form->{$key_r} = $script . $info . ($query ? "?$query" : "");
+ ### generate a fresh cookie if they submitted info on plaintext types
+ if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) {
+ $self->set_cookie({
+ key => $key_c,
+ val => $self->generate_token($data),
+ no_expires => ($data->{ $self->key_save } ? 0 : 1), # make it a session cookie unless they ask for saving
+ }) if $is_form; # only set the cookie if we found info in the form - the cookie will be a session cookie after that
+
+ ### always generate a cookie on types that have expiration
+ } else {
+ $self->set_cookie({
+ key => $key_c,
+ val => $self->generate_token($data),
+ no_expires => 0,
+ });
+ }
+
+ ### successful login
+
+ ### 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
+ } elsif ($has_cookies || $self->no_cookie_verify) {
+ return $self;
+
+ ### need to verify cookies are set-able
+ } elsif ($is_form) {
+ $form->{$self->key_verify} = $self->server_time;
+ my $query = $self->cgix->make_form($form);
+ my $url = $self->script_name . $self->path_info . ($query ? "?$query" : "");
+
+ $self->location_bounce($url);
+ eval { die "Success login - bouncing to test cookie" };
+ return;
}
- $self->location_bounce($form->{$key_r});
- return 0;
- }
- } else {
- $had_form_info = 1;
- $self->delete_cookie;
}
- ### otherwise look for an already set cookie
- } elsif ($cookies->{$key_c}) {
- my ($user, $pass) = split /:/, decode_base64($cookies->{$key_c}), 2;
- return $self->success($user) if $self->verify_userpass($user, $pass);
- $self->delete_cookie;
-
- ### cases to handle no cookies
- } elsif ($form->{$key_chk}) {
- my $value = delete $form->{$key_chk};
- if ($self->allow_htauth) {
- die "allow_htauth is not implemented - yet";
- } elsif (abs(time() - $value) < 3600) {
- # fail down to below where we ask for auth
- # this is assuming that all webservers in the cluster are within 3600 of each other
- } else {
- $self->hook_print("no_cookies", $form);
- return 0;
+ ### make sure the cookie is gone
+ $self->delete_cookie({key => $key_c}) if $cookies->{$key_c};
+
+ ### nothing found - see if they have cookies
+ if (my $value = delete $form->{$self->key_verify}) {
+ if (abs(time() - $value) < 15) {
+ $self->no_cookies_print;
+ return;
+ }
}
- }
- ### oh - you're still here - well then - ask for login credentials
- my $key_r = $self->key_redirect;
- if (! $form->{$key_r}) {
- my $script = $ENV{SCRIPT_NAME} || die "Missing SCRIPT_NAME";
- my $info = $ENV{PATH_INFO} || '';
- my $query = $self->cgix->make_form($form);
- $form->{$key_r} = $script . $info . ($query ? "?$query" : "");
- }
- $form->{login_error} = $had_form_info;
- $self->hook_print("get_login_info", $form);
- return 0;
+ ### oh - you're still here - well then - ask for login credentials
+ my $key_r = $self->key_redirect;
+ if (! $form->{$key_r}) {
+ my $query = $self->cgix->make_form($form);
+ $form->{$key_r} = $self->script_name . $self->path_info . ($query ? "?$query" : "");
+ }
+
+ $form->{'had_form_data'} = $had_form_info;
+ $self->login_print;
+ my $data = $self->last_auth_data;
+ eval { die defined($data) ? $data : "Requesting credentials" };
+ return;
}
###----------------------------------------------------------------###
-sub hook_print {
- my $self = shift;
- my $page = shift;
- my $form = shift;
-
- ### copy the form and add various pieces
- my $FORM = {%$form};
- $FORM->{payload} = $self->payload;
- $FORM->{error} = ($form->{login_error}) ? "Login Failed" : "";
- $FORM->{key_user} = $self->key_user;
- $FORM->{key_pass} = $self->key_pass;
- $FORM->{key_save} = $self->key_save;
- $FORM->{key_redirect} = $self->key_redirect;
- $FORM->{form_name} = $self->form_name;
- $FORM->{script_name} = $ENV{SCRIPT_NAME};
- $FORM->{path_info} = $ENV{PATH_INFO} || '';
- $FORM->{login_script} = $self->login_script($FORM);
- delete $FORM->{$FORM->{key_pass}};
-
- ### allow for custom hook
- if (my $meth = $self->{hook_print}) {
- $self->$meth($page, $FORM);
- return 0;
- }
+sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME" }
- ### no hook - give basic functionality
- my $content;
- if ($page eq 'no_cookies') {
- $content = qq{<div style="border: 2px solid black;background:red;color:white">You do not appear to have cookies enabled.</div>};
- } elsif ($page eq 'get_login_info') {
- $content = $self->basic_login_page($FORM);
- } else {
- $content = "No content for page \"$page\"";
- }
+sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
- $self->cgix->print_content_type();
- print $content;
- return 0;
-}
-
-###----------------------------------------------------------------###
+sub server_time { time }
-sub success {
- my $self = shift;
- my $user = shift;
- $self->{user} = $ENV{REMOTE_USER} = $user;
- $self->hook_success($user);
- return 1;
+sub cgix {
+ my $self = shift;
+ $self->{'cgix'} = shift if $#_ != -1;
+ return $self->{'cgix'} ||= CGI::Ex->new;
}
-sub user {
- my $self = shift;
- return $self->{user};
+sub form {
+ my $self = shift;
+ $self->{'form'} = shift if $#_ != -1;
+ return $self->{'form'} ||= $self->cgix->get_form;
}
-sub hook_success {
- my $self = shift;
- my $user = shift;
- my $meth;
- if ($meth = $self->{hook_success}) {
- $self->$meth($user);
- }
+sub cookies {
+ my $self = shift;
+ $self->{'cookies'} = shift if $#_ != -1;
+ return $self->{'cookies'} ||= $self->cgix->get_cookies;
}
-###----------------------------------------------------------------###
-
sub delete_cookie {
- my $self = shift;
- my $key_c = $self->key_cookie;
- $self->cgix->set_cookie({
- -name => $key_c,
- -value => '',
- -expires => '-10y',
- -path => '/',
- });
-}
+ my $self = shift;
+ my $args = shift;
+ my $key = $args->{'key'};
+ $self->cgix->set_cookie({
+ -name => $key,
+ -value => '',
+ -expires => '-10y',
+ -path => '/',
+ });
+ delete $self->cookies->{$key};
+}
sub set_cookie {
- my $self = shift;
- my $key_c = $self->key_cookie;
- my $value = shift || '';
- my $save_pass = shift;
- $self->cgix->set_cookie({
- -name => $key_c,
- -value => $value,
- ($save_pass ? (-expires => '+10y') : ()),
- -path => '/',
- });
+ my $self = shift;
+ my $args = shift;
+ my $key = $args->{'key'};
+ my $val = $args->{'val'};
+ $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 => '/',
+ });
+ $self->cookies->{$key} = $val;
}
sub location_bounce {
- my $self = shift;
- my $url = shift;
- return $self->cgix->location_bounce($url);
+ my $self = shift;
+ my $url = shift;
+ return $self->cgix->location_bounce($url);
}
###----------------------------------------------------------------###
-sub key_logout {
- my $self = shift;
- $self->{key_logout} = shift if $#_ != -1;
- return $self->{key_logout} ||= 'logout';
+sub key_logout { shift->{'key_logout'} ||= 'cea_logout' }
+sub key_cookie { shift->{'key_cookie'} ||= 'cea_user' }
+sub key_user { shift->{'key_user'} ||= 'cea_user' }
+sub key_pass { shift->{'key_pass'} ||= 'cea_pass' }
+sub key_time { shift->{'key_time'} ||= 'cea_time' }
+sub key_save { shift->{'key_save'} ||= 'cea_save' }
+sub key_expires_min { shift->{'key_expires_min'} ||= 'cea_expires_min' }
+sub form_name { shift->{'form_name'} ||= 'cea_form' }
+sub key_verify { shift->{'key_verify'} ||= 'cea_verify' }
+sub key_redirect { shift->{'key_redirect'} ||= 'cea_redirect' }
+sub key_payload { shift->{'key_payload'} ||= 'cea_payload' }
+sub secure_hash_keys { shift->{'secure_hash_keys'} ||= [] }
+sub no_cookie_verify { shift->{'no_cookie_verify'} ||= 0 }
+sub use_crypt { shift->{'use_crypt'} ||= 0 }
+sub use_blowfish { shift->{'use_blowfish'} ||= '' }
+sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} ||= 0) }
+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 logout_redirect {
+ my $self = shift;
+ return $self->{'logout_redirect'} || $self->script_name ."?loggedout=1";
}
-sub key_cookie {
- my $self = shift;
- $self->{key_cookie} = shift if $#_ != -1;
- return $self->{key_cookie} ||= 'ce_auth';
+sub js_uri_path {
+ my $self = shift;
+ return $self->{'js_uri_path'} ||= $self->script_name ."/js";
}
-sub key_cookie_check {
- my $self = shift;
- $self->{key_cookie_check} = shift if $#_ != -1;
- return $self->{key_cookie_check} ||= 'ccheck';
-}
+###----------------------------------------------------------------###
-sub key_user {
- my $self = shift;
- $self->{key_user} = shift if $#_ != -1;
- return $self->{key_user} ||= 'ce_user';
+sub no_cookies_print {
+ my $self = shift;
+ $self->cgix->print_content_type;
+ print qq{<div style="border: 2px solid black;background:red;color:white">You do not appear to have cookies enabled.</div>};
+ return 1;
}
-sub key_pass {
- my $self = shift;
- $self->{key_pass} = shift if $#_ != -1;
- return $self->{key_pass} ||= 'ce_pass';
-}
+sub login_print {
+ my $self = shift;
+ my $hash = $self->login_hash_common;
+ my $template = $self->login_template;
-sub key_save {
- my $self = shift;
- $self->{key_save} = shift if $#_ != -1;
- return $self->{key_save} ||= 'ce_save';
-}
+ ### allow for a hooked override
+ if (my $meth = $self->{'login_print'}) {
+ $meth->($self, $template, $hash);
+ return 0;
+ }
-sub key_redirect {
- my $self = shift;
- $self->{key_redirect} = shift if $#_ != -1;
- return $self->{key_redirect} ||= 'redirect';
-}
+ ### process the document
+ require CGI::Ex::Template;
+ my $cet = CGI::Ex::Template->new($self->template_args);
+ my $out = '';
+ $cet->process_simple($template, $hash, \$out) || die $cet->error;
+
+ ### fill in form fields
+ require CGI::Ex::Fill;
+ CGI::Ex::Fill::fill({text => \$out, form => $hash});
+
+ ### print it
+ $self->cgix->print_content_type;
+ print $out;
-sub form_name {
- my $self = shift;
- $self->{form_name} = shift if $#_ != -1;
- return $self->{form_name} ||= 'ce_form';
+ return 0;
}
-sub allow_htauth {
- my $self = shift;
- $self->{allow_htauth} = shift if $#_ != -1;
- return $self->{allow_htauth} ||= 0;
+sub template_args {
+ my $self = shift;
+ return $self->{'template_args'} ||= {
+ INCLUDE_PATH => $self->template_include_path,
+ };
}
-sub payload {
- my $self = shift;
- my $user = shift;
- my $time = shift || time();
- my $meth;
- my @payload = ($time);
- if ($meth = $self->{hook_payload}) {
- push @payload, $self->$meth($user);
- }
- return join "/", @payload;
+sub template_include_path { shift->{'template_include_path'} || '' }
+
+sub login_hash_common {
+ my $self = shift;
+ my $form = $self->form;
+ my $data = $self->last_auth_data;
+ $data = {} if ! defined $data;
+
+ return {
+ %$form,
+ error => ($form->{'had_form_data'}) ? "Login Failed" : "",
+ login_data => $data,
+ key_user => $self->key_user,
+ key_pass => $self->key_pass,
+ key_time => $self->key_time,
+ key_save => $self->key_save,
+ key_expires_min => $self->key_expires_min,
+ key_payload => $self->key_payload,
+ key_redirect => $self->key_redirect,
+ form_name => $self->form_name,
+ script_name => $self->script_name,
+ path_info => $self->path_info,
+ md5_js_path => $self->js_uri_path ."/CGI/Ex/md5.js",
+ use_plaintext => $self->use_plaintext,
+ $self->key_user => $data->{'user'} || '',
+ $self->key_pass => '', # don't allow for this to get filled into the form
+ $self->key_time => $self->server_time,
+ $self->key_payload => $self->generate_payload({%$data, login_form => 1}),
+ $self->key_expires_min => $self->expires_min,
+
+ };
}
###----------------------------------------------------------------###
-sub verify_userpass {
- my $self = shift;
- my $user = shift;
- my $pass = shift;
- my $host = shift || $self->host;
- my $meth;
- if ($meth = $self->{hook_verify_userpass}) {
- return $self->$meth($user, $pass, $host);
- } else {
- return $self->hook_verify_userpass($user, $pass, $host);
- }
-}
+sub verify_token {
+ my $self = shift;
+ my $args = shift;
+ my $token = delete $args->{'token'} || die "Missing token";
+ my $data = $self->{'_last_auth_data'} = $self->new_auth_data({token => $token, %$args});
+
+ ### token already parsed
+ if (ref $token) {
+ $data->add_data({%$token, armor => 'none'});
-sub hook_verify_userpass {
- my $self = shift;
- my $user = shift;
- my $pass_test = shift;
- my $host = shift || $self->host;
-
- return undef if ! defined $user;
- return undef if ! defined $pass_test;
- my $pass_real = $self->hook_get_pass_by_user($user, $host);
- return undef if ! defined $pass_real;
-
- my $type_real = ($pass_real =~ m/^(md5|sha1)\((.+)\)$/) ? $1 : 'plainorcrypt';
- my $hash_real = $2;
- my $type_test = ($pass_test =~ m/^(md5|sha1)\((.+)\)$/) ? $1 : 'plainorcrypt';
- my $hash_test = $2;
-
- ### if both types were plaintext - check if the equal
- if ($type_real eq 'plainorcrypt'
- && $type_test eq 'plainorcrypt') {
- return 1 if $pass_real eq $pass_test;
- if ($CHECK_CRYPTED && $pass_real =~ m|^([./0-9A-Za-z]{2})(.{,11})$|) {
- return 1 if crypt($pass_test, $1) eq $pass_real;
+ ### parse token for info
+ } else {
+ 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') ? decode_base64($token)
+ : ($key = $self->use_blowfish) ? decrypt_blowfish($token, $key)
+ : next;
+ if ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / (.*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) {
+ $data->add_data({
+ user => $1,
+ cram_time => $2,
+ expires_min => $3,
+ payload => $4,
+ test_pass => $5,
+ secure_hash => $6 || '',
+ armor => $armor,
+ });
+ $found = 1;
+ last;
+ } elsif ($copy =~ m|^ ([^/]+) / (.*) $|x) {
+ $data->add_data({
+ user => $1,
+ test_pass => $2,
+ armor => $armor,
+ });
+ $found = 1;
+ last;
+ }
+ }
+ if (! $found) {
+ $data->error('Invalid token');
+ return $data;
+ }
}
- return 0;
- } else {
- ### if test type is plaintext - then hash it and compare it alone
- if ($type_test eq 'plainorcrypt') {
- $pass_test = $self->enc_func($type_real, $pass_test); # encode same as real
- $pass_test = "$type_real($pass_test)";
- return $pass_test eq $pass_real;
-
- ### if real type is plaintext - then hash it to get ready for test
- } elsif ($type_real eq 'plainorcrypt') {
- $pass_real = $self->enc_func($type_test, $pass_real);
- $pass_real = "$type_test($pass_real)";
- $type_real = $type_test;
+
+ ### verify the user and get the pass
+ my $pass;
+ if (! defined($data->{'user'})) {
+ $data->error('Missing user');
+
+ } elsif (! defined $data->{'test_pass'}) {
+ $data->error('Missing test_pass');
+
+ } elsif (! $self->verify_user($data->{'user'} = $self->cleanup_user($data->{'user'}))) {
+ $data->error('Invalid user');
+
+ } elsif (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) {
+ $data->add_data({details => $@});
+ $data->error('Could not get pass');
}
-
- ### the types should be the same (unless a system stored sha1 and md5 passwords)
- if ($type_real ne $type_test) {
- warn "Test types for user \"$user\" are of two different types - very bad";
- return 0;
+ return $data if $data->error;
+
+
+ ### store - to allow generate_token to not need to relookup the pass
+ $data->add_data({real_pass => $pass});
+
+
+ ### looks like a secure_hash cram
+ if ($data->{'secure_hash'}) {
+ $data->add_data(type => 'secure_hash_cram');
+ my $array = eval {$self->secure_hash_keys };
+ if (! $array) {
+ $data->error('secure_hash_keys not found');
+ } elsif (! @$array) {
+ $data->error('secure_hash_keys empty');
+ } elsif ($data->{'secure_hash'} !~ /^sh\.(\d+)\.(\d+)$/ || $1 > $#$array) {
+ $data->error('Invalid secure hash');
+ } else {
+ my $rand1 = $1;
+ my $rand2 = $2;
+ my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
+ my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
+ my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
+ if ($data->{'expires_min'} > 0
+ && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
+ $data->error('Login expired');
+ } elsif (lc($data->{'test_pass'}) ne $sum) {
+ $data->error('Invalid login');
+ }
+ }
+
+ ### looks like a normal cram
+ } elsif ($data->{'cram_time'}) {
+ $data->add_data(type => 'cram');
+ my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
+ my $str = join("/", @{$data}{qw(user cram_time expires_min payload)});
+ my $sum = md5_hex($str .'/'. $real);
+ if ($data->{'expires_min'} > 0
+ && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) {
+ $data->error('Login expired');
+ } elsif (lc($data->{'test_pass'}) ne $sum) {
+ $data->error('Invalid login');
+ }
+
+ ### plaintext_crypt
+ } elsif ($data->{'real_pass'} =~ m|^([./0-9A-Za-z]{2})([./0-9A-Za-z]{11})$|
+ && crypt($data->{'test_pass'}, $1) eq $data->{'real_pass'}) {
+ $data->add_data(type => 'crypt', was_plaintext => 1);
+
+ ### failed plaintext crypt
+ } elsif ($self->use_crypt) {
+ $data->error('Invalid login');
+ $data->add_data(type => 'crypt', was_plaintext => ($data->{'test_pass'} =~ /^[a-f0-9]{32}$/ ? 0 : 1));
+
+ ### plaintext and md5
+ } else {
+ my $is_md5_t = $data->{'test_pass'} =~ /^[a-f0-9]{32}$/;
+ my $is_md5_r = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/;
+ my $test = $is_md5_t ? lc($data->{'test_pass'}) : md5_hex($data->{'test_pass'});
+ my $real = $is_md5_r ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'});
+ $data->add_data(type => ($is_md5_r ? 'md5' : 'plaintext'), was_plaintext => ($is_md5_t ? 0 : 1));
+ $data->error('Invalid login')
+ if $test ne $real;
}
- ### no payload - compare directly
- if ($hash_test !~ m|^(.+)/([^/]+)$|) {
- return lc($pass_test) eq lc($pass_real);
+ ### check the payload
+ if (! $data->error && ! $self->verify_payload($data->{'payload'})) {
+ $data->error('Invalid payload');
+ }
- ### and finally - check the payload (allows for expiring login)
+ return $data;
+}
+
+sub new_auth_data {
+ my $self = shift;
+ return CGI::Ex::Auth::Data->new(@_);
+}
+
+sub last_auth_data { shift->{'_last_auth_data'} }
+
+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;
+
+ my $token;
+
+ ### do kinds that require staying plaintext
+ if ( (defined($data->{'use_plaintext'}) ? $data->{'use_plaintext'} : $self->use_plaintext) # ->use_plaintext is true if ->use_crypt is
+ || (defined($data->{'use_crypt'}) && $data->{'use_crypt'})
+ || (defined($data->{'type'}) && $data->{'type'} eq 'crypt')) {
+ $token = $data->{'user'} .'/'. $data->{'real_pass'};
+
+ ### all other types go to cram - secure_hash_cram, cram, plaintext and md5
} else {
- my $payload = $1; # payload can be anything
- my $compare = $2; # a checksum which is the enc of the payload + '/' + enc of password
- my @payload = split /\//, $payload;
+ my $user = $data->{'user'} || die "Missing user";
+ my $real = defined($data->{'real_pass'}) ? ($data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}))
+ : die "Missing real_pass";
+ my $exp = defined($data->{'expires_min'}) ? $data->{'expires_min'} : $self->expires_min;
+ my $load = $self->generate_payload($data);
+ die "Payload can not contain a \"/\. Please escape it in generate_payload." if $load =~ m|/|;
+ die "User can not contain a \"/\." if $user =~ m|/|;
+
+ my $array;
+ if (! $data->{'prefer_cram'}
+ && ($array = eval { $self->secure_hash_keys })
+ && @$array) {
+ my $rand1 = int(rand @$array);
+ my $rand2 = int(rand 100000);
+ my $str = join("/", $user, $self->server_time, $exp, $load);
+ my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2));
+ $token = $str .'/'. $sum . '/sh.'.$rand1.'.'.$rand2;
+ } else {
+ my $str = join("/", $user, $self->server_time, $exp, $load);
+ my $sum = md5_hex($str .'/'. $real);
+ $token = $str .'/'. $sum;
+ }
+ }
- return 0 if $self->enc_func($type_test, "$payload/$hash_real") ne $compare;
+ if (my $key = $data->{'use_blowfish'} || $self->use_blowfish) {
+ $token = encrypt_blowfish($token, $key);
- ### if no save password && greater than expire time- expire
- if ($EXPIRE_LOGINS && ! $payload[1] && $payload[0] =~ m/^(\d+)/) {
- return 0 if time() > $1 + $EXPIRE_LOGINS;
- }
- return 1;
+ } elsif (defined($data->{'use_base64'}) ? $data->{'use_base64'} : $self->use_base64) {
+ $token = encode_base64($token, '');
}
- }
- return 0; # nothing should make it this far
-}
-
-sub enc_func {
- my $self = shift;
- my $type = shift;
- my $str = shift;
- if ($type eq 'md5') {
- require Digest::MD5;
- return &Digest::MD5::md5_hex($str);
- } elsif ($type eq 'sha1') {
- require Digest::SHA1;
- return &Digest::SHA1::sha1_hex($str);
- }
+
+ return $token;
}
-sub set_hook_get_pass_by_user {
- my $self = shift;
- $self->{hook_get_pass_by_user} = shift;
+sub generate_payload {
+ my $self = shift;
+ my $args = shift;
+ return defined($args->{'payload'}) ? $args->{'payload'} : '';
}
-sub hook_get_pass_by_user {
- my $self = shift;
- my $user = shift;
- my $host = shift || $self->host;
- my $meth;
- if ($meth = $self->{hook_get_pass_by_user}) {
- return $self->$meth($user, $host);
- }
- die "hook_get_pass_by_user is a virtual method - please override - or use set_hook_get_pass_by_user";
+sub verify_user {
+ my $self = shift;
+ my $user = shift;
+ if (my $meth = $self->{'verify_user'}) {
+ return $meth->($self, $user);
+ }
+ return 1;
}
-###----------------------------------------------------------------###
+sub cleanup_user {
+ my $self = shift;
+ my $user = shift;
+ if (my $meth = $self->{'cleanup_user'}) {
+ return $meth->($self, $user);
+ }
+ return $user;
+}
-sub cgix {
- my $self = shift;
- $self->{cgix} = shift if $#_ != -1;
- return $self->{cgix} ||= do {
- require CGI::Ex;
- CGI::Ex->new(); # return of the do
- };
+sub get_pass_by_user {
+ my $self = shift;
+ my $user = shift;
+ if (my $meth = $self->{'get_pass_by_user'}) {
+ return $meth->($self, $user);
+ }
+
+ die "Please override get_pass_by_user";
}
-sub form {
- my $self = shift;
- if ($#_ != -1) {
- $self->{form} = shift || die "Invalid form";
- }
- return $self->{form} ||= $self->cgix->get_form;
+sub verify_payload {
+ my $self = shift;
+ my $payload = shift;
+ if (my $meth = $self->{'verify_payload'}) {
+ return $meth->($self, $payload);
+ }
+ return 1;
}
-sub cookies {
- my $self = shift;
- if ($#_ != -1) {
- $self->{cookies} = shift || die "Invalid cookies";
- }
- return $self->{cookies} ||= $self->cgix->get_cookies;
-}
-
-sub host {
- my $self = shift;
- return $self->{host} = shift if $#_ != -1;
- return $self->{host} ||= do {
- my $host = $ENV{HTTP_HOST} || die "Missing \$ENV{HTTP_HOST}";
- $host = lc($host);
- $host =~ s/:\d*$//; # remove port number
- $host =~ s/\.+$//; # remove qualified dot
- $host =~ s/[^\w\.\-]//g; # remove odd characters
- $host; # return of the do
- };
+###----------------------------------------------------------------###
+
+sub encrypt_blowfish {
+ my ($str, $key) = @_;
+
+ require Crypt::Blowfish;
+ my $cb = Crypt::Blowfish->new($key);
+
+ $str .= (chr 0) x (8 - length($str) % 8); # pad to multiples of 8
+
+ my $enc = '';
+ $enc .= unpack "H16", $cb->encrypt($1) while $str =~ /\G(.{8})/g; # 8 bytes at a time
+
+ return $enc;
+}
+
+sub decrypt_blowfish {
+ my ($enc, $key) = @_;
+
+ require Crypt::Blowfish;
+ my $cb = Crypt::Blowfish->new($key);
+
+ my $str = '';
+ $str .= $cb->decrypt(pack "H16", $1) while $enc =~ /\G([A-Fa-f0-9]{16})/g;
+ $str =~ y/\00//d;
+
+ return $str
}
###----------------------------------------------------------------###
-sub basic_login_page {
- my $self = shift;
- my $form = shift;
+sub login_template {
+ my $self = shift;
+ return $self->{'login_template'} if $self->{'login_template'};
- my $text = $self->basic_login_template();
- $self->cgix->swap_template(\$text, $form);
- $self->cgix->fill(\$text, $form);
+ my $text = ""
+ . $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 %]<!-- [% error %] -->[% END ~%]
+ };
+}
- return $text;
+sub login_footer {
+ return shift->{'login_footer'} || q {
+ [%~ TRY ; PROCESS 'login_footer.tt' ; CATCH %]<!-- [% error %] -->[% END ~%]
+ };
}
-sub basic_login_template {
- return qq{
- [% header %]
- <div align="center">
- <span class="error" style="color:red">[% error %]</span>
- <form name="[% form_name %]" method="get" action="[% script_name %]">
- <table border="0" class="login_table">
- <tr>
+sub login_form {
+ return shift->{'login_form'} || q {
+ <div class="login_chunk">
+ <span class="login_error">[% error %]</span>
+ <form class="login_form" name="[% form_name %]" method="post" action="[% script_name %][% path_info %]">
+ <input type="hidden" name="[% key_redirect %]" value="">
+ <input type="hidden" name="[% key_payload %]" value="">
+ <input type="hidden" name="[% key_time %]" value="">
+ <input type="hidden" name="[% key_expires_min %]" value="">
+ <table class="login_table">
+ <tr class="login_username">
<td>Username:</td>
<td><input name="[% key_user %]" type="text" size="30" value=""></td>
</tr>
- <tr>
+ <tr class="login_password">
<td>Password:</td>
<td><input name="[% key_pass %]" type="password" size="30" value=""></td>
</tr>
- <tr>
+ <tr class="login_save">
<td colspan="2">
<input type="checkbox" name="[% key_save %]" value="1"> Save Password ?
</td>
</tr>
- <tr>
+ <tr class="login_submit">
<td colspan="2" align="right">
- <input type="hidden" name="[% key_redirect %]">
- <input type="hidden" name="payload">
<input type="submit" value="Submit">
</td>
</tr>
- [% extra_table %]
</table>
</form>
</div>
- [% login_script %]
- [% footer %]
- };
+};
}
-sub login_type {
- my $self = shift;
- if ($#_ != -1) {
- $self->{login_type} = defined($_[0]) ? lc(shift) : undef;
- }
- $self->{login_type} = do {
- my $type;
- if ($USE_PLAINTEXT) {
- $type = '';
- } elsif (eval {require Digest::SHA1}) {
- $type = 'sha1';
- } elsif (eval {require Digest::MD5}) {
- $type = 'md5';
- } else {
- $type = "";
- }
- $type; # return of the do
- } if ! defined $self->{login_type};
- return $self->{login_type};
-}
-
-
sub login_script {
- my $self = shift;
- my $form = shift;
- my $type = $self->login_type;
- return if ! $type || $type !~ /^(sha1|md5)$/;
-
- return qq{
- <script src="$form->{script_name}/js/CGI/Ex/$type.js"></script>
+ return q {
+ [%~ IF ! use_plaintext %]
+ <script src="[% md5_js_path %]"></script>
<script>
- function send_it () {
- var f = document.$form->{form_name};
- var s = (f.$form->{key_save}.checked) ? 1 : 0;
- var l = f.payload.value + '/' + s;
- var r = f.$form->{key_redirect}.value;
- var q = document.$form->{form_name}.action;
- var sum = document.${type}_hex(l+'/'+document.${type}_hex(f.$form->{key_pass}.value));
- q += '?$form->{key_user}='+escape(f.$form->{key_user}.value);
- q += '&$form->{key_save}='+escape(s);
- q += '&$form->{key_pass}='+escape('$type('+l+'/'+sum+')');
- location.href = q;
+ if (document.md5_hex) document.[% form_name %].onsubmit = function () {
+ var f = document.[% form_name %];
+ var u = f.[% key_user %].value;
+ var p = f.[% key_pass %].value;
+ var t = f.[% key_time %].value;
+ var s = f.[% key_save %] && f.[% key_save %].checked ? -1 : f.[% key_expires_min %].value;
+ var l = f.[% key_payload %].value;
+ var r = f.[% key_redirect %].value;
+
+ var str = u+'/'+t+'/'+s+'/'+l;
+ var sum = document.md5_hex(str +'/' + document.md5_hex(p));
+ var loc = f.action + '?[% key_user %]='+escape(str +'/'+ sum)+'&[% key_redirect %]='+escape(r);
+
+ location.href = loc;
return false;
}
- if (document.${type}_hex) document.$form->{form_name}.onsubmit = function () { return send_it() }
</script>
+ [% END ~%]
};
}
###----------------------------------------------------------------###
-### return arguments to add on to a url to allow login (for emails)
-sub auth_string_sha1 {
- my $self = shift;
- my $user = shift;
- my $pass = shift;
- my $save = shift || 0;
- my $time = shift || time;
- my $payload = $self->payload($time);
-
- require Digest::SHA1;
-
- if ($pass =~ /^sha1\((.+)\)$/) {
- $pass = $1;
- } else {
- $pass = &Digest::SHA1::sha1_hex($pass);
- }
- $pass = &Digest::SHA1::sha1_hex("$payload/$save/$pass");
+package CGI::Ex::Auth::Data;
- return $self->cgix->make_form({
- $self->key_user => $user,
- $self->key_pass => "sha1($payload/$save/$pass)",
- $self->key_save => $save,
- });
+use strict;
+use overload
+ 'bool' => sub { ! shift->error },
+ '0+' => sub { 1 },
+ '""' => sub { shift->as_string },
+ fallback => 1;
+
+sub new {
+ my ($class, $args) = @_;
+ return bless {%{ $args || {} }}, $class;
+}
+
+sub add_data {
+ my $self = shift;
+ my $args = @_ == 1 ? shift : {@_};
+ @{ $self }{keys %$args} = values %$args;
+}
+
+sub error {
+ my $self = shift;
+ if (@_ == 1) {
+ $self->{'error'} = shift;
+ $self->{'error_caller'} = [caller];
+ }
+ return $self->{'error'};
+}
+
+sub as_string {
+ my $self = shift;
+ return $self->error || ($self->{'user'} && $self->{'type'}) ? "Valid auth data" : "Unverified auth data";
}
###----------------------------------------------------------------###
__END__
-=head1 NAME
-
-CGI::Ex::Auth - Handle logins nicely.
-
=head1 SYNOPSIS
### authorize the user
- my $auth = $self->auth({
- hook_get_pass_by_user => \&get_pass_by_user,
- hook_print => \&my_print,
- login_type => 'sha1',
+ my $auth = $self->get_valid_auth({
+ get_pass_by_user => \&get_pass_by_user,
});
- ### login_type may be sha1, md5, or plaintext
sub get_pass_by_user {
my $auth = shift;
- my $username = shift;
- my $host = shift;
- my $password = some_way_of_getting_password;
- return $password;
- }
-
- sub my_print {
- my $auth = shift;
- my $step = shift;
- my $form = shift; # form includes login_script at this point
- my $content = get_content_from_somewhere;
- $auth->cgix->swap_template(\$content, $form);
- $auth->cgix->print_content_type;
- print $content;
+ my $user = shift;
+ my $pass = some_way_of_getting_password($user);
+ return $pass;
}
=head1 DESCRIPTION
-CGI::Ex::Auth allows for autoexpiring, safe logins. Auth uses
-javascript modules that perform SHA1 and MD5 encoding to encode
-the password on the client side before passing them through the
-internet.
-
-If SHA1 is used the storage of the password can be described by
-the following code:
+CGI::Ex::Auth allows for auto-expiring, safe and easy web based logins. Auth uses
+javascript modules that perform MD5 hashing to cram the password on
+the client side before passing them through the internet.
- my $pass = "plaintextpassword";
- my $save = ($save_the_password) ? 1 : 0;
- my $time = time;
- my $store = sha1_hex("$time/$save/" . sha1_hex($pass));
+For the stored cookie you can choose to use 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.
-This allows for passwords to be stored as sha1 in a database.
-Passwords stored in the database this way are still susceptible to bruteforce
-attack, but are much more secure than storing plain text.
-
-If MD5 is used, the above procedure is replaced with md5_hex.
-
-A downside to this module is that it does not use a session to preserve state
-so authentication has to happen on every request. A plus is that you don't
-need to use a session. With later releases, a method will be added to allow
-authentication to look inside of a stored session somewhat similar to
-CGI::Session::Auth.
+A downside to this module is that it does not use a session to
+preserve state so get_pass_by_user has to happen on every request (any
+authenticated area has to verify authentication each time). A plus is
+that you don't need to use a session if you don't want to. It is up
+to the interested reader to add caching to the get_pass_by_user
+method.
=head1 METHODS
=item C<new>
-Constructor. Takes a hash or hashref of properties as arguments.
-
-=item C<init>
-
-Called automatically near the end of new.
-
-=item C<require_auth>
+Constructor. Takes a hashref of properties as arguments.
+
+Many of the methods which may be overridden in a subclass,
+or may be passed as properties to the new constuctor such as in the following:
+
+ CGI::Ex::Auth->new({
+ get_pass_by_user => \&my_pass_sub,
+ key_user => 'my_user',
+ key_pass => 'my_pass',
+ login_template => \"<form><input name=my_user ... </form>",
+ });
+
+The following methods will look for properties of the same name. Each of these will be
+defined separately.
+
+ cgix
+ cleanup_user
+ cookies
+ expires_min
+ form
+ form_name
+ get_pass_by_user
+ js_uri_path
+ key_cookie
+ key_expires_min
+ key_logout
+ key_pass
+ key_payload
+ key_redirect
+ key_save
+ key_time
+ key_user
+ key_verify
+ login_footer
+ login_form
+ login_header
+ login_script
+ login_template
+ no_cookie_verify
+ path_info
+ script_name
+ secure_hash_keys
+ template_args
+ template_include_path
+ use_base64
+ use_blowfish
+ use_crypt
+ use_plaintext
+ verify_payload
+ verify_user
+
+=item C<generate_token>
+
+Takes either an auth_data object from a auth_data returned by verify_token,
+or a hashref of arguments.
+
+Possible arguments are:
+
+ user - the username we are generating the token for
+ real_pass - the password of the user (if use_plaintext is false
+ and use_crypt is false, the password can be an md5sum
+ of the user's password)
+ use_blowfish - indicates that we should use Crypt::Blowfish to protect
+ the generated token. The value of this argument is used
+ as the key. Default is false.
+ use_base64 - indicates that we should use Base64 encoding to protect
+ the generated token. Default is true. Will not be
+ used if use_blowfish is true.
+ use_plaintext - indicates that we should keep the password in plaintext
+ use_crypt - also indicates that we should keep the password in plaintext
+ expires_min - says how many minutes until the generated token expires.
+ Values <= 0 indicate to not ever expire. Used only on cram
+ types.
+ payload - a payload that will be passed to generate_payload and then
+ will be added to cram type tokens. It cannot contain a /.
+ prefer_cram - If the secure_hash_keys method returns keys, and it is a non-plaintext
+ token, generate_token will create a secure_hash_cram. Set
+ this value to true to tell it to use a normal cram. This
+ is generally only useful in testing.
+
+The following are types of tokens that can be generated by generate_token. Each type includes
+pseudocode and a sample of a generated that token.
+
+ plaintext:
+ user := "paul"
+ real_pass := "123qwe"
+ token := join("/", user, real_pass);
+
+ use_base64 := 0
+ token == "paul/123qwe"
+
+ use_base64 := 1
+ token == "cGF1bC8xMjNxd2U="
+
+ use_blowfish := "foobarbaz"
+ token == "6da702975190f0fe98a746f0d6514683"
+
+ Notes: This token will be used if either use_plaintext or use_crypt is set.
+ The real_pass can also be the md5_sum of the password. If real_pass is an md5_sum
+ of the password but the get_pass_by_user hook returns the crypt'ed password, the
+ token will not be able to be verified.
+
+ cram:
+ user := "paul"
+ real_pass := "123qwe"
+ server_time := 1148512991 # a time in seconds since epoch
+ expires_min := 6 * 60
+ payload := "something"
+
+ md5_pass := md5_sum(real_pass) # if it isn't already a 32 digit md5 sum
+ str := join("/", user, server_time, expires_min, payload, md5_pass)
+ md5_str := md5(sum_str)
+ token := join("/", user, server_time, expires_min, payload, md5_str)
+
+ use_base64 := 0
+ token == "paul/1148512991/360/something/16d0ba369a4c9781b5981eb89224ce30"
+
+ use_base64 := 1
+ token == "cGF1bC8xMTQ4NTEyOTkxLzM2MC9zb21ldGhpbmcvMTZkMGJhMzY5YTRjOTc4MWI1OTgxZWI4OTIyNGNlMzA="
+
+ Notes: use_blowfish is available as well
+
+ secure_hash_cram:
+ user := "paul"
+ real_pass := "123qwe"
+ server_time := 1148514034 # a time in seconds since epoch
+ expires_min := 6 * 60
+ payload := "something"
+ secure_hash := ["aaaa", "bbbb", "cccc", "dddd"]
+ rand1 := 3 # int(rand(length(secure_hash)))
+ rand2 := 39163 # int(rand(100000))
+
+ md5_pass := md5_sum(real_pass) # if it isn't already a 32 digit md5 sum
+
+ sh_str1 := join(".", "sh", secure_hash[rand1], rand2)
+ sh_str2 := join(".", "sh", rand1, rand2)
+ str := join("/", user, server_time, expires_min, payload, md5_pass, sh_str1)
+ md5_str := md5(sum_str)
+ token := join("/", user, server_time, expires_min, payload, md5_str, sh_str2)
+
+ use_base64 := 0
+ token == "paul/1148514034/360/something/06db2914c9fd4e11499e0652bcf67dae/sh.3.39163"
+
+ Notes: use_blowfish is available as well. The secure_hash keys need to be set in the
+ "secure_hash_keys" property of the CGI::Ex::Auth object.
+
+=item C<get_valid_auth>
+
+Performs the core logic. Returns an auth object on successful login.
+Returns false on errored login (with the details of the error stored in
+$@). If a false value is returned, execution of the CGI should be halted.
+get_valid_auth WILL NOT automatically stop execution.
+
+ $auth->get_valid_auth || exit;
+
+Optionally, the class and a list of arguments may be passed. This will create a
+new object using the passed arguments, and then run get_valid_auth.
+
+ CGI::Ex::Auth->get_valid_auth({key_user => 'my_user'}) || exit;
+
+=item C<login_print>
+
+Called if login errored. Defaults to printing a very basic (but
+adequate) page loaded from login_template..
-Performs the core logic. Returns true on successful login.
-Returns false on failed login. If a false value is returned,
-execution of the CGI should be halted. require_auth WILL
-NOT automatically stop execution.
-
- $auth->require_auth || exit;
-
-=item C<hook_print>
-
-Called if login failed. Defaults to printing a very basic page.
You will want to override it with a template from your own system.
The hook that is called will be passed the step to print (currently
only "get_login_info" and "no_cookies"), and a hash containing the
form variables as well as the following:
- payload - $self->payload
- error - The error that occurred (if any)
- key_user - $self->key_user;
- key_pass - $self->key_pass;
- key_save - $self->key_save;
- key_redirect - $self->key_redirect;
- form_name - $self->form_name;
- script_name - $ENV{SCRIPT_NAME}
- path_info - $ENV{PATH_INFO} || ''
- login_script - $self->login_script($FORM); # The javascript that does the login
-
-=item C<success>
-
-Method called on successful login. Sets $self->user as well as $ENV{REMOTE_USER}.
-
-=item C<user>
-
-Returns the user that was successfully logged in (undef if no success).
-
-=item C<hook_success>
-
-Called from success. May be overridden or a subref may be given as a property.
+=item C<login_hash_common>
+
+Passed to the template swapped during login_print.
+
+ %$form, # any keys passed to the login script
+ error # The text "Login Failed" if a login occurred
+ login_data # A login data object if they failed authentication.
+ key_user # $self->key_user, # the username fieldname
+ key_pass # $self->key_pass, # the password fieldname
+ key_time # $self->key_time, # the server time field name
+ key_save # $self->key_save, # the save password checkbox field name
+ key_payload # $self->key_payload, # the payload fieldname
+ key_redirect # $self->key_redirect, # the redirect fieldname
+ form_name # $self->form_name, # the name of the form
+ script_name # $self->script_name, # where the server will post back to
+ path_info # $self->path_info, # $ENV{PATH_INFO} if any
+ md5_js_path # $self->js_uri_path ."/CGI/Ex/md5.js", # script for cramming
+ use_plaintext # $self->use_plaintext, # used to avoid cramming
+ $self->key_user # $data->{'user'}, # the username (if any)
+ $self->key_pass # '', # intentional blankout
+ $self->key_time # $self->server_time, # the server's time
+ $self->key_payload # $data->{'payload'} # the payload (if any)
+ $self->key_expires_min # $self->expires_min # how many minutes crams are valid
=item C<key_logout>
-If a key is passed the form hash that matches this key, the current user will
-be logged out. Default is "logout".
+If the form hash contains a true value in this field name, the current user will
+be logged out. Default is "cea_logout".
=item C<key_cookie>
-The name of the auth cookie. Default is "ce_auth".
+The name of the auth cookie. Default is "cea_user".
-=item C<key_cookie_check>
+=item C<key_verify>
-A field name used during a bounce to see if cookies exist. Default is "ccheck".
+A field name used during a bounce to see if cookies exist. Default is "cea_verify".
=item C<key_user>
-The form field name used to pass the username. Default is "ce_user".
+The form field name used to pass the username. Default is "cea_user".
=item C<key_pass>
-The form field name used to pass the password. Default is "ce_pass".
+The form field name used to pass the password. Default is "cea_pass".
=item C<key_save>
-The form field name used to pass whether they would like to save the cookie for
-a longer period of time. Default is "ce_save". The value of this form field
-should be 1 or 0. If it is zero, the cookie installed will be a session cookie
-and will expire in $EXPIRE_LOGINS seconds (default of 6 hours).
+Works in conjunction with key_expires_min. If key_save is true, then
+the cookie will be set to be saved for longer than the current session
+(If it is a plaintext variety it will be given a 20 year life rather
+than being a session cookie. If it is a cram variety, the expires_min
+portion of the cram will be set to -1). If it is set to false, the cookie
+will be available only for the session (If it is a plaintext variety, the cookie
+will be session based and will be removed on the next loggout. If it is
+a cram variety then the cookie will only be good for expires_min minutes.
-=item C<form_name>
+Default is "cea_save".
-The name of the html login form to attach the javascript to. Default is "ce_form".
+=item C<key_expires_min>
-=item C<payload>
+The name of the form field that contains how long cram type cookies will be valid
+if key_save contains a false value.
-Additional variables to store in the cookie. Can be used for anything. Should be
-kept small. Default is time (should always use time as the first argument). Used
-for autoexpiring the cookie and to prevent bruteforce attacks.
+Default key name is "cea_expires_min". Default field value is 6 * 60 (six hours).
-=item C<verify_userpass>
+This value will have no effect when use_plaintext or use_crypt is set.
-Called to verify the passed form information or the stored cookie. Calls hook_verify_userpass.
+A value of -1 means no expiration.
-=item C<hook_verify_userpass>
+=item C<form_name>
-Called by verify_userpass. Arguments are the username, cookie or info to be tested,
-and the hostname. Default method calls hook_get_pass_by_user to get the real password.
-Then based upon how the real password is stored (sha1, md5, plaintext, or crypted) and
-how the login info was passed from the html form (or javascript), will attempt to compare
-the two and return success or failure. It should be noted that if the javascript method
-used is SHA1 and the password is stored crypted or md5'ed - the comparison will not work
-and the login will fail. SHA1 logins require either plaintext password or sha1 stored passwords.
-MD5 logins require either plaintext password or md5 stored passwords. Plaintext logins
-allow for SHA1 or MD5 or crypted or plaintext storage - but should be discouraged because
-they are plaintext and the users password can be discovered.
+The name of the html login form to attach the javascript to. Default is "cea_form".
-=item C<hook_get_pass_by_user>
+=item C<verify_token>
-Called by hook_verify_userpass. Arguments are the username and hostname. Should return
-a sha1 password, md5 password, plaintext password, or crypted password depending
-upon which system is being used to get the information from the user.
+This method verifies the token that was passed either via the form or via cookies.
+It will accept plaintext or crammed tokens (A listing of the available algorithms
+for creating tokes is listed below). It also allows for armoring the token with
+base64 encoding, or using blowfish encryption. A listing of creating these tokens
+can be found under generate_token.
-=item C<set_hook_get_pass_by_user>
+=item C<cleanup_user>
-Allows for setting the subref used by hook_get_pass_by_user.x
+Called by verify_token. Default is to do no modification. Allows for usernames to
+be lowercased, or canonized in some other way. Should return the cleaned username.
+
+=item C<verify_user>
+
+Called by verify_token. Single argument is the username. May or may not be an
+initial check to see if the username is ok. The username will already be cleaned at
+this point. Default return is true.
+
+=item C<get_pass_by_user>
+
+Called by verify_token. Given the cleaned, verified username, should return a
+valid password for the user. It can always return plaintext. If use_crypt is
+enabled, it should return the crypted password. If use_plaintext and use_crypt
+are not enabled, it may return the md5 sum of the password.
=item C<cgix>
The current cookies. Defaults to CGI::Ex::get_cookies.
-=item C<host>
-
-What host are we on. Defaults to a cleaned $ENV{HTTP_HOST}.
+=item C<login_template>
-=item C<basic_login_page>
+Should return either a template filename to use for the login template, or it
+should return a reference to a string that contains the template. The contents
+will be used in login_print and passed to the template engine.
-Calls the basic_login_template, swaps in the form variables (including
-form name, login_script, etc). Then prints content_type, the content, and
-returns.
+Default login_template is the values of login_header, login_form, login_script, and
+login_script concatenated together.
-=item C<basic_login_template>
+Values from login_hash_common will be passed to the template engine, and will
+also be used to fill in the form.
-Returns a bare essentials form that will handle the login. Has place
-holders for all of the form name, and login variables, and errors and
-login javascript. Variable place holders are of the form
-[% login_script %] which should work with Template::Toolkit or CGI::Ex::swap_template.
+The basic values are capable of handling most needs so long as appropriate
+headers and css styles are used.
-=item C<login_type>
+=item C<login_header>
-Either sha1, md5, or plaintext. If global $USE_PLAINTEXT is set,
-plaintext password will be used. login_type will then look for
-Digest::SHA1, then Digest::MD5, and then fail to plaintext.
+Should return a header to use in the default login_template. The default
+value will try to PROCESS a file called login_header.tt that should be
+located in directory specified by the template_include_path method.
-SHA1 comparison will work with passwords stored as plaintext password,
-or stored as the string "sha1(".sha1_hex($password).")".
+It should ideally supply css styles that format the login_form as desired.
-MD5 comparison will work with passwords stored as plaintext password,
-or stored as the string "md5(".md5_hex($password).")".
+=item C<login_footer>
-Plaintext comparison will work with passwords stored as sha1(string),
-md5(string), plaintext password string, or crypted password.
+Same as login_header - but for the footer. Will look for login_footer.tt by
+default.
-=item C<login_script>
-
-Returns a chunk of javascript that will encode the password before
-the html form is ever submitted. It does require that $ENV{PATH_TRANSLATED}
-is not modified before calling the require_auth method so that any
-external javascript files may be served (also by the require_auth).
-
-=item C<auth_string_sha1>
+=item C<login_form>
-Arguments are username, password, save_password, and time. This will
-return a valid login string. You probably will want to pass 1 for the
-save_password or else the login will only be good for 6 hours.
+An html chunk that contains the necessary form fields to login the user. The
+basic chunk has a username text entry, password text entry, save password checkbox,
+and submit button, and any hidden fields necessary for logging in the user.
- my $login = $self->auth->auth_string_sha1($user, $pass, 1);
- my $url = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?$login";
-
-=head1 TODO
+=item C<login_script>
-Using plaintext allows for the password to be passed in the querystring.
-It should at least be Base64 encoded. I'll add that soon - BUT - really
-you should be using the SHA1 or MD5 login types.
+Contains javascript that will attach to the form from login_form. This script
+is capable of taking the login_fields and creating an md5 cram which prevents
+the password from being passed plaintext.
=head1 AUTHORS
package CGI::Ex::Conf;
-### CGI Extended Conf Reader
+=head1 NAME
+
+CGI::Ex::Conf - Conf Reader/Writer for many different data format types
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
use strict;
+use base qw(Exporter);
+use Carp qw(croak);
use vars qw($VERSION
@DEFAULT_PATHS
$DEFAULT_EXT
$IMMUTABLE_KEY
%CACHE
$HTML_KEY
- $DEBUG_ON_FAIL
+ @EXPORT_OK
);
-use CGI::Ex::Dump qw(debug dex_warn);
+@EXPORT_OK = qw(conf_read conf_write);
-$VERSION = '0.03';
+$VERSION = '2.00';
$DEFAULT_EXT = 'conf';
%EXT_READERS = ('' => \&read_handler_yaml,
'conf' => \&read_handler_yaml,
+ 'json' => \&read_handler_json,
+ 'val_json' => \&read_handler_json,
'ini' => \&read_handler_ini,
'pl' => \&read_handler_pl,
'sto' => \&read_handler_storable,
%EXT_WRITERS = ('' => \&write_handler_yaml,
'conf' => \&write_handler_yaml,
'ini' => \&write_handler_ini,
+ 'json' => \&write_handler_json,
+ 'val_json' => \&write_handler_json,
'pl' => \&write_handler_pl,
'sto' => \&write_handler_storable,
'storable' => \&write_handler_storable,
sub new {
my $class = shift || __PACKAGE__;
- my $self = (@_ && ref($_[0])) ? shift : {@_};
+ my $args = shift || {};
- return bless $self, $class;
+ return bless {%$args}, $class;
}
sub paths {
###----------------------------------------------------------------###
-sub read_ref {
- my $self = shift;
+sub conf_read {
my $file = shift;
my $args = shift || {};
my $ext;
if (ref $file) {
if (UNIVERSAL::isa($file, 'SCALAR')) {
if ($$file =~ /^\s*</) {
- return &html_parse_yaml_load($$file, $self, $args); # allow for ref to a YAML string
+ return html_parse_yaml_load($$file, $args); # allow for ref to a YAML string
} else {
- return &yaml_load($$file); # allow for ref to a YAML string
+ return yaml_load($$file); # allow for ref to a YAML string
}
} else {
return $file;
}
+ ### allow for a pre-cached reference
+ } elsif (exists $CACHE{$file} && ! $args->{no_cache}) {
+ return $CACHE{$file};
+
### if contains a newline - treat it as a YAML string
} elsif (index($file,"\n") != -1) {
- return &yaml_load($file);
+ return yaml_load($file);
### otherwise base it off of the file extension
} elsif ($args->{file_type}) {
$ext = $1;
} else {
$ext = defined($args->{default_ext}) ? $args->{default_ext}
- : defined($self->{default_ext}) ? $self->{default_ext}
- : defined($DEFAULT_EXT) ? $DEFAULT_EXT : '';
+ : defined($DEFAULT_EXT) ? $DEFAULT_EXT
+ : '';
$file = length($ext) ? "$file.$ext" : $file;
}
- ### allow for a pre-cached reference
- if (exists $CACHE{$file} && ! $self->{no_cache}) {
- return $CACHE{$file};
- }
-
### determine the handler
- my $handler;
- if ($args->{handler}) {
- $handler = (UNIVERSAL::isa($args->{handler},'CODE'))
- ? $args->{handler} : $args->{handler}->{$ext};
- } elsif ($self->{handler}) {
- $handler = (UNIVERSAL::isa($self->{handler},'CODE'))
- ? $self->{handler} : $self->{handler}->{$ext};
- }
- if (! $handler) {
- $handler = $EXT_READERS{$ext} || die "Unknown file extension: $ext";
- }
+ my $handler = $EXT_READERS{$ext} || croak "Unknown file extension: $ext";
- return eval { scalar &$handler($file, $self, $args) } || do {
- debug "Couldn't read $file: $@" if $DEBUG_ON_FAIL;
- dex_warn "Couldn't read $file: $@" if ! $self->{no_warn_on_fail};
+ return eval { scalar $handler->($file, $args) } || do {
+ warn "Couldn't read $file: $@ " if ! $args->{no_warn_on_fail};
return undef;
};
}
+sub read_ref {
+ my $self = shift;
+ my $file = shift;
+ my $args = shift || {};
+ return conf_read($file, {%$self, %$args});
+}
+
### allow for different kinds of merging of arguments
### allow for key fallback on hashes
### allow for immutable values on hashes
$directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE);
$namespace =~ s|::|/|g; # allow perlish style namespace
my $paths = $args->{paths} || $self->paths
- || die "No paths found during read on $namespace";
+ || croak "No paths found during read on $namespace";
$paths = [$paths] if ! ref $paths;
if ($directive eq 'LAST') { # LAST shall be FIRST
$directive = 'FIRST';
### make sure we have at least one path
if ($#paths == -1) {
- die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
+ croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
}
-
+
### now loop looking for a ref
foreach my $path (@paths) {
my $ref = $self->read_ref($path, $args) || next;
} elsif (UNIVERSAL::isa($ref, 'HASH')) {
$REF = {};
} else {
- die "Unknown config type of \"".ref($ref)."\" for namespace $namespace";
+ croak "Unknown config type of \"".ref($ref)."\" for namespace $namespace";
}
} elsif (! UNIVERSAL::isa($ref, ref($REF))) {
- die "Found different reference types for namespace $namespace"
+ croak "Found different reference types for namespace $namespace"
. " - wanted a type ".ref($REF);
}
if (ref($REF) eq 'ARRAY') {
sub read_handler_ini {
my $file = shift;
require Config::IniHash;
- return &Config::IniHash::ReadINI($file);
+ return Config::IniHash::ReadINI($file);
}
sub read_handler_pl {
return ($#ref != 0) ? {@ref} : $ref[0];
}
+sub read_handler_json {
+ my $file = shift;
+ local *IN;
+ open (IN, $file) || die "Couldn't open $file: $!";
+ CORE::read(IN, my $text, -s $file);
+ close IN;
+ return scalar JSON::jsonToObj($text);
+}
+
sub read_handler_storable {
my $file = shift;
require Storable;
- return &Storable::retrieve($file);
+ return Storable::retrieve($file);
}
sub read_handler_yaml {
open (IN, $file) || die "Couldn't open $file: $!";
CORE::read(IN, my $text, -s $file);
close IN;
- return &yaml_load($text);
+ return yaml_load($text);
}
sub yaml_load {
my $text = shift;
require YAML;
- my @ret = eval { &YAML::Load($text) };
+ my @ret = eval { YAML::Load($text) };
if ($@) {
die "$@";
}
### is specified
sub read_handler_html {
my $file = shift;
- my $self = shift;
my $args = shift;
- if (! eval {require YAML}) {
+ if (! eval { require YAML }) {
my $err = $@;
my $found = 0;
my $i = 0;
CORE::read(IN, my $html, -s $file);
close IN;
- return &html_parse_yaml_load($html, $self, $args);
+ return html_parse_yaml_load($html, $args);
}
sub html_parse_yaml_load {
my $html = shift;
- my $self = shift || {};
my $args = shift || {};
- my $key = $args->{html_key} || $self->{html_key} || $HTML_KEY;
+ my $key = $args->{html_key} || $HTML_KEY;
return undef if ! $key || $key !~ /^\w+$/;
my $str = '';
if $str && $#order != -1 && $key eq 'validation';
return undef if ! $str;
- my $ref = eval {&yaml_load($str)};
+ my $ref = eval { yaml_load($str) };
if ($@) {
my $err = "$@";
if ($err =~ /line:\s+(\d+)/) {
last;
}
}
- debug $err;
die $err;
}
return $ref;
###----------------------------------------------------------------###
+sub conf_write {
+ my $file = shift;
+ my $conf = shift || croak "Missing conf";
+ my $args = shift || {};
+ my $ext;
+
+ if (ref $file) {
+ croak "Invalid filename for write: $file";
+
+ } elsif (index($file,"\n") != -1) {
+ croak "Cannot use a yaml string as a filename during write";
+
+ ### allow for a pre-cached reference
+ } elsif (exists $CACHE{$file} && ! $args->{no_cache}) {
+ warn "Cannot write back to a file that is in the cache";
+ return 0;
+
+ ### otherwise base it off of the file extension
+ } elsif ($args->{file_type}) {
+ $ext = $args->{file_type};
+ } elsif ($file =~ /\.(\w+)$/) {
+ $ext = $1;
+ } else {
+ $ext = defined($args->{default_ext}) ? $args->{default_ext}
+ : defined($DEFAULT_EXT) ? $DEFAULT_EXT
+ : '';
+ $file = length($ext) ? "$file.$ext" : $file;
+ }
+
+ ### determine the handler
+ my $handler;
+ if ($args->{handler}) {
+ $handler = (UNIVERSAL::isa($args->{handler},'CODE'))
+ ? $args->{handler} : $args->{handler}->{$ext};
+ }
+ if (! $handler) {
+ $handler = $EXT_WRITERS{$ext} || croak "Unknown file extension: $ext";
+ }
+
+ return eval { scalar $handler->($file, $conf, $args) } || do {
+ warn "Couldn't write $file: $@ " if ! $args->{no_warn_on_fail};
+ return 0;
+ };
+
+ return 1;
+}
+
+sub write_ref {
+ my $self = shift;
+ my $file = shift;
+ my $conf = shift;
+ my $args = shift || {};
+ conf_write($file, $conf, {%$self, %$args});
+}
+
### Allow for writing out conf values
### Allow for writing out the correct filename (if there is a path array)
### Allow for not writing out immutable values on hashes
sub write {
my $self = shift;
my $namespace = shift;
- my $conf = shift || die "Must pass hashref to write out"; # the info to write
+ my $conf = shift || croak "Must pass hashref to write out"; # the info to write
my $args = shift || {};
my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types
$directive = 'FIRST';
} elsif (index($namespace,"\n") != -1) { # yaml string - can't write that
- die "Cannot use a yaml string as a namespace for write";
+ croak "Cannot use a yaml string as a namespace for write";
### use the default directories
} else {
$directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE);
$namespace =~ s|::|/|g; # allow perlish style namespace
my $paths = $args->{paths} || $self->paths
- || die "No paths found during write on $namespace";
+ || croak "No paths found during write on $namespace";
$paths = [$paths] if ! ref $paths;
if ($directive eq 'LAST') { # LAST shall be FIRST
$directive = 'FIRST';
### make sure we have at least one path
if ($#paths == -1) {
- die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
+ croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths";
}
my $path;
} elsif ($directive eq 'LAST' || $directive eq 'MERGE') {
$path = $paths[-1];
} else {
- die "Unknown directive ($directive) during write of $namespace";
+ croak "Unknown directive ($directive) during write of $namespace";
}
### remove immutable items (if any)
return 1;
}
-sub write_ref {
- my $self = shift;
- my $file = shift;
- my $conf = shift || die "Missing conf";
- my $args = shift || {};
- my $ext;
-
- if (ref $file) {
- die "Invalid filename for write: $file";
-
- } elsif (index($file,"\n") != -1) {
- die "Cannot use a yaml string as a filename during write";
-
- ### otherwise base it off of the file extension
- } elsif ($args->{file_type}) {
- $ext = $args->{file_type};
- } elsif ($file =~ /\.(\w+)$/) {
- $ext = $1;
- } else {
- $ext = defined($args->{default_ext}) ? $args->{default_ext}
- : defined($self->{default_ext}) ? $self->{default_ext}
- : defined($DEFAULT_EXT) ? $DEFAULT_EXT : '';
- $file = length($ext) ? "$file.$ext" : $file;
- }
-
- ### allow for a pre-cached reference
- if (exists $CACHE{$file} && ! $self->{no_cache}) {
- warn "Cannot write back to a file that is in the cache";
- return 0;
- }
-
- ### determine the handler
- my $handler;
- if ($args->{handler}) {
- $handler = (UNIVERSAL::isa($args->{handler},'CODE'))
- ? $args->{handler} : $args->{handler}->{$ext};
- } elsif ($self->{handler}) {
- $handler = (UNIVERSAL::isa($self->{handler},'CODE'))
- ? $self->{handler} : $self->{handler}->{$ext};
- }
- if (! $handler) {
- $handler = $EXT_WRITERS{$ext} || die "Unknown file extension: $ext";
- }
-
- return eval { scalar &$handler($file, $conf, $args) } || do {
- debug "Couldn't write $file: $@" if $DEBUG_ON_FAIL;
- dex_warn "Couldn't write $file: $@" if ! $self->{no_warn_on_fail};
- return 0;
- };
-
- return 1;
-}
-
###----------------------------------------------------------------###
sub write_handler_ini {
my $file = shift;
my $ref = shift;
require Config::IniHash;
- return &Config::IniHash::WriteINI($file, $ref);
+ return Config::IniHash::WriteINI($file, $ref);
}
sub write_handler_pl {
die "Ref to be written contained circular references - can't write";
}
+ local *OUT;
+ open (OUT, ">$file") || die $!;
+ print OUT $str;
+ close OUT;
+}
+
+sub write_handler_json {
+ my $file = shift;
+ my $ref = shift;
+ require JSON;
+ my $str = JSON::objToJson($ref, {pretty => 1, indent => 2});
local *OUT;
open (OUT, ">$file") || die $!;
print OUT $str;
my $file = shift;
my $ref = shift;
require Storable;
- return &Storable::store($ref, $file);
+ return Storable::store($ref, $file);
}
sub write_handler_yaml {
my $file = shift;
my $ref = shift;
require YAML;
- &YAML::DumpFile($file, $ref);
+ return YAML::DumpFile($file, $ref);
}
sub write_handler_xml {
}
}
return if ! keys %EXT;
-
+
### look in the paths for the files
foreach my $path (ref($paths) ? @$paths : $paths) {
$path =~ s|//+|/|g;
$CACHE{$path} = $self->read($path);
} elsif (-d _) {
$CACHE{$path} = 1;
- &File::Find::find(sub {
+ File::Find::find(sub {
return if exists $CACHE{$File::Find::name};
return if $File::Find::name =~ m|/CVS/|;
return if ! -f;
__END__
-=head1 NAME
-
-CGI::Ex::Conf - CGI Extended Conf Reader
-
=head1 SYNOPSIS
my $cob = CGI::Ex::Conf->new;
package CGI::Ex::Die;
+=head1 NAME
+
+CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
+
+=cut
+
+###----------------------------------------------------------------###
+# Copyright 2006 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
use strict;
use vars qw($no_recurse
$EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL
__END__
-=head1 NAME
-
-CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
-
=head1 SYNOPSIS
use CGI::Ex::Die;
package CGI::Ex::Dump;
-### CGI Extended Data::Dumper Extension
+=head1 NAME
+
+CGI::Ex::Dump - A debug utility
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
-use vars qw(@ISA @EXPORT @EXPORT_OK $ON $SUB $QR1 $QR2 $full_filename);
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
+ $CALL_LEVEL
+ $ON $SUB $QR1 $QR2 $full_filename);
use strict;
use Exporter;
+$VERSION = '2.00';
@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 what_is_this);
+@EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug);
### is on or off
sub on { $ON = 1 };
### same as dumper but with more descriptive output and auto-formatting
### for cgi output
-sub what_is_this {
+sub _what_is_this {
return if ! $ON;
### figure out which sub we called
- my ($pkg, $file, $line_n, $called) = caller(0);
- ($pkg, $file, $line_n, $called) = caller(1) if $pkg eq __PACKAGE__;
+ my ($pkg, $file, $line_n, $called) = caller(1 + ($CALL_LEVEL || 0));
substr($called, 0, length(__PACKAGE__) + 2, '');
### get the actual line
elsif ($called eq 'dex_warn') { warn $txt }
else { print $txt }
} else {
- my $html = "<pre><b>$called: $file line $line_n</b>\n";
+ my $html = "<pre class=debug><span class=debughead><b>$called: $file line $line_n</b></span>\n";
for (0 .. $#dump) {
$dump[$_] =~ s/\\n/\n/g;
$dump[$_] = _html_quote($dump[$_]);
- $dump[$_] =~ s|\$VAR1|<b>$var[$_]</b>|g;
+ $dump[$_] =~ s|\$VAR1|<span class=debugvar><b>$var[$_]</b></span>|g;
$html .= $dump[$_];
}
$html .= "</pre>\n";
return $html if $called eq 'dex_html';
require CGI::Ex;
- &CGI::Ex::print_content_type();
+ CGI::Ex::print_content_type();
print $html;
}
}
### some aliases
-sub debug { &what_is_this }
-sub dex { &what_is_this }
-sub dex_warn { &what_is_this }
-sub dex_text { &what_is_this }
-sub dex_html { &what_is_this }
+sub debug { &_what_is_this }
+sub dex { &_what_is_this }
+sub dex_warn { &_what_is_this }
+sub dex_text { &_what_is_this }
+sub dex_html { &_what_is_this }
sub _html_quote {
my $value = shift;
my $max1 = 0;
my $max2 = 0;
my $max3 = 0;
- while (my %i = &Carp::caller_info(++$i)) {
+ while (my %i = Carp::caller_info(++$i)) {
$i{sub_name} =~ s/\((.*)\)$//;
$i{args} = $i{has_args} ? $1 : "";
$i{sub_name} =~ s/^.*?([^:]+)$/$1/;
}
sub dex_trace {
- &what_is_this(ctrace(1));
+ _what_is_this(ctrace(1));
}
###----------------------------------------------------------------###
__END__
-=head1 NAME
-
-CGI::Ex::Dump - A debug utility
-
=head1 SYNOPSIS
use CGI::Ex::Dump; # auto imports dex, dex_warn, dex_text and others
package CGI::Ex::Fill;
-### CGI Extended Form Filler
+=head1 NAME
+
+CGI::Ex::Fill - Fast but compliant regex based form filler
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2003 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
use strict;
use vars qw($VERSION
- @ISA @EXPORT @EXPORT_OK
+ @EXPORT @EXPORT_OK
$REMOVE_SCRIPT
$REMOVE_COMMENT
$MARKER_SCRIPT
$MARKER_COMMENT
$OBJECT_METHOD
- $TEMP_TARGET
+ $_TEMP_TARGET
);
-use Exporter;
+use base qw(Exporter);
-$VERSION = '1.3';
-@ISA = qw(Exporter);
-@EXPORT = qw(form_fill);
-@EXPORT_OK = qw(form_fill html_escape get_tagval_by_key swap_tagval_by_key);
+BEGIN {
+ $VERSION = '2.00';
+ @EXPORT = qw(form_fill);
+ @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
+};
### These directives are used to determine whether or not to
### remove html comments and script sections while filling in
### a form. Default is on. This may give some trouble if you
### have a javascript section with form elements that you would
### like filled in.
-$REMOVE_SCRIPT = 1;
-$REMOVE_COMMENT = 1;
-$MARKER_SCRIPT = "\0SCRIPT\0";
-$MARKER_COMMENT = "\0COMMENT\0";
-$OBJECT_METHOD = "param";
+BEGIN {
+ $REMOVE_SCRIPT = 1;
+ $REMOVE_COMMENT = 1;
+ $MARKER_SCRIPT = "\0SCRIPT\0";
+ $MARKER_COMMENT = "\0COMMENT\0";
+ $OBJECT_METHOD = "param";
+};
###----------------------------------------------------------------###
### pos4 - boolean fill in password fields - default is true
### pos5 - hashref or arrayref of fields to ignore
sub form_fill {
- my $text = shift;
- my $ref = ref($text) ? $text : \$text;
- my $form = shift;
- my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
- my $target = shift;
- my $fill_password = shift;
- my $ignore = shift || {};
- $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
- $fill_password = 1 if ! defined $fill_password;
-
-
- ### allow for optionally removing comments and script
- my @comment;
- my @script;
- if ($REMOVE_SCRIPT) {
- $$ref =~ s|(<script\b.+?</script>)|push(@script, $1);$MARKER_SCRIPT|egi;
- }
- if ($REMOVE_COMMENT) {
- $$ref =~ s|(<!--.*?-->)|push(@comment, $1);$MARKER_COMMENT|eg;
- }
-
- ### if there is a target - focus in on it
- ### possible bug here - name won't be found if
- ### there is nested html inside the form tag that comes before
- ### the name field - if no close form tag - don't swap in anything
- if ($target) {
- local $TEMP_TARGET = $target;
- $$ref =~ s{(<form # open form
- [^>]+ # some space
- \bname=([\"\']?) # the name tag
- $target # with the correct name (allows for regex)
- \2 # closing quote
- .+? # as much as there is
- (?=</form>)) # then end
- }{
- local $REMOVE_SCRIPT = undef;
- local $REMOVE_COMMENT = undef;
- &form_fill($1, $form, undef, $fill_password, $ignore);
- }sigex;
+ my $text = shift;
+ my $ref = ref($text) ? $text : \$text;
+ my $form = shift;
+ my $target = shift;
+ my $fill_password = shift;
+ my $ignore = shift || {};
+
+ fill({
+ text => $ref,
+ form => $form,
+ target => $target,
+ fill_password => $fill_password,
+ ignore_fields => $ignore,
+ });
- ### put scripts and comments back and return
- $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
- $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
return ref($text) ? 1 : $$ref;
- }
+}
- ### build a sub to get a value
- my %indexes = (); # store indexes for multivalued elements
- my $get_form_value = sub {
- my $key = shift;
- my $all = $_[0] && $_[0] eq 'all';
- if (! defined $key || ! length $key) {
- return $all ? [] : undef;
- }
+sub fill {
+ my $args = shift;
+ my $ref = $args->{'text'};
+ my $form = $args->{'form'};
+ my $target = $args->{'target'};
+ my $ignore = $args->{'ignore_fields'};
+ my $fill_password = $args->{'fill_password'};
+
+ my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
+ $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
+ $fill_password = 1 if ! defined $fill_password;
- my $val;
- my $meth;
- foreach my $form (@$forms) {
- next if ! ref $form;
- if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
- $val = $form->{$key};
- last;
- } elsif ($meth = UNIVERSAL::can($form, $OBJECT_METHOD)) {
- $val = $form->$meth($key);
- last if defined $val;
- } elsif (UNIVERSAL::isa($form, 'CODE')) {
- $val = &{ $form }($key, $TEMP_TARGET);
- last if defined $val;
- }
- }
- if (! defined $val) {
- return $all ? [] : undef;
- }
- ### fix up the value some
- if (UNIVERSAL::isa($val, 'CODE')) {
- $val = &{ $val }($key, $TEMP_TARGET);
+ ### allow for optionally removing comments and script
+ my @comment;
+ my @script;
+ if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) {
+ $$ref =~ s|(<script\b.+?</script>)|push(@script, $1);$MARKER_SCRIPT|egi;
}
- if (UNIVERSAL::isa($val, 'ARRAY')) {
- $val = [@$val]; # copy the values
- } elsif (ref $val) {
- # die "Value for $key is not an array or a scalar";
- $val = "$val"; # stringify anything else
+ if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) {
+ $$ref =~ s|(<!--.*?-->)|push(@comment, $1);$MARKER_COMMENT|eg;
}
- ### html escape them all
- &html_escape(\$_) foreach (ref($val) ? @$val : $val);
-
- ### allow for returning all elements
- ### or one at a time
- if ($all) {
- return ref($val) ? $val : [$val];
- } elsif (ref($val)) {
- $indexes{$key} ||= 0;
- my $ret = $val->[$indexes{$key}] || '';
- $indexes{$key} ++; # don't wrap - if we run out of values - we're done
- return $ret;
- } else {
- return $val;
+ ### if there is a target - focus in on it
+ ### possible bug here - name won't be found if
+ ### there is nested html inside the form tag that comes before
+ ### the name field - if no close form tag - don't swap in anything
+ if ($target) {
+ local $_TEMP_TARGET = $target;
+ $$ref =~ s{(<form # open form
+ [^>]+ # some space
+ \bname=([\"\']?) # the name tag
+ $target # with the correct name (allows for regex)
+ \2 # closing quote
+ .+? # as much as there is
+ (?=</form>)) # then end
+ }{
+ my $str = $1;
+ local $args->{'text'} = \$str;
+ local $args->{'remove_script'} = 0;
+ local $args->{'remove_comment'} = 0;
+ local $args->{'target'} = undef;
+ fill($args);
+ $str; # return of the s///;
+ }sigex;
+
+ ### put scripts and comments back and return
+ $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
+ $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
+ return 1;
}
- };
-
-
- ###--------------------------------------------------------------###
-
- ### First pass
- ### swap <input > form elements if they have a name
- $$ref =~ s{
- (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )* >) # nested html ok
- }{
- ### get the type and name - intentionally exlude names with nested "'
- my $tag = $1;
- my $type = uc(&get_tagval_by_key(\$tag, 'type') || '');
- my $name = &get_tagval_by_key(\$tag, 'name');
-
- if ($name && ! $ignore->{$name}) {
- if (! $type
- || $type eq 'HIDDEN'
- || $type eq 'TEXT'
- || $type eq 'FILE'
- || ($type eq 'PASSWORD' && $fill_password)) {
-
- my $value = &$get_form_value($name, 'next');
- if (defined $value) {
- &swap_tagval_by_key(\$tag, 'value', $value);
- } elsif (! defined &get_tagval_by_key(\$tag, 'value')) {
- &swap_tagval_by_key(\$tag, 'value', '');
- }
-
- } elsif ($type eq 'CHECKBOX'
- || $type eq 'RADIO') {
- my $values = &$get_form_value($name, 'all');
- if (@$values) {
- $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
-
- if ($type eq 'CHECKBOX' && @$values == 1 && $values->[0] eq 'on') {
- $tag =~ s|(/?>\s*)$| checked="checked"$1|;
- } else {
- my $fvalue = &get_tagval_by_key(\$tag, 'value');
- if (defined $fvalue) {
- foreach (@$values) {
- next if $_ ne $fvalue;
- $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
- last;
- }
- }
+
+ ### build a sub to get a value from the passed forms on a request basis
+ my %indexes = (); # store indexes for multivalued elements
+ my $get_form_value = sub {
+ my $key = shift;
+ my $all = $_[0] && $_[0] eq 'all';
+ if (! defined $key || ! length $key) {
+ return $all ? [] : undef;
+ }
+
+ my $val;
+ my $meth;
+ foreach my $form (@$forms) {
+ next if ! ref $form;
+ if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
+ $val = $form->{$key};
+ last;
+ } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) {
+ $val = $form->$meth($key);
+ last if defined $val;
+ } elsif (UNIVERSAL::isa($form, 'CODE')) {
+ $val = $form->($key, $_TEMP_TARGET);
+ last if defined $val;
}
- }
}
- }
- $tag; # return of swap
- }sigex;
-
-
- ### Second pass
- ### swap select boxes (must be done in such a way as to allow no closing tag)
- my @start = ();
- my @close = ();
- push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
- push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*select\b)|ig;
- for (my $i = 0; $i <= $#start; $i ++) {
- while (defined($close[$i]) && $close[$i] < $start[$i]) {
- splice (@close,$i,1,());
- }
- if ($i == $#start) {
- $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
- } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
- $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
- }
- }
- for (my $i = $#start; $i >= 0; $i --) {
- my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
- $opts =~ s{
- (<select \s # opening
- (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
- >) # end of tag
- }{}sxi || next;
- next if ! $opts;
- my $tag = $1;
- my $name = &get_tagval_by_key(\$tag, 'name');
- my $values = $ignore->{$name} ? [] : &$get_form_value($name, 'all');
- if ($#$values != -1) {
- my $n = $opts =~ s{
- (<option[^>]*>) # opening tag - no embedded > allowed
- (.*?) # the text value
- (?=<option|$|</option>) # the next tag
+ if (! defined $val) {
+ return $all ? [] : undef;
+ }
+
+ ### fix up the value some
+ if (UNIVERSAL::isa($val, 'CODE')) {
+ $val = $val->($key, $_TEMP_TARGET);
+ }
+ if (UNIVERSAL::isa($val, 'ARRAY')) {
+ $val = [@$val]; # copy the values
+ } elsif (ref $val) {
+ # die "Value for $key is not an array or a scalar";
+ $val = "$val"; # stringify anything else
+ }
+
+ ### html escape them all
+ html_escape(\$_) foreach (ref($val) ? @$val : $val);
+
+ ### allow for returning all elements
+ ### or one at a time
+ if ($all) {
+ return ref($val) ? $val : [$val];
+ } elsif (ref($val)) {
+ $indexes{$key} ||= 0;
+ my $ret = $val->[$indexes{$key}];
+ $ret = '' if ! defined $ret;
+ $indexes{$key} ++; # don't wrap - if we run out of values - we're done
+ return $ret;
+ } else {
+ return $val;
+ }
+ };
+
+
+ ###--------------------------------------------------------------###
+
+ ### First pass
+ ### swap <input > form elements if they have a name
+ $$ref =~ s{
+ (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )* >) # nested html ok
}{
- my ($tag2, $opt) = ($1, $2);
- $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
-
- my $fvalues = &get_tagval_by_key(\$tag2, 'value', 'all');
- my $fvalue = @$fvalues ? $fvalues->[0]
- : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
- foreach (@$values) {
- next if $_ ne $fvalue;
- $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
- last;
- }
- "$tag2$opt"; # return of the swap
+ ### get the type and name - intentionally exlude names with nested "'
+ my $tag = $1;
+ my $type = uc(get_tagval_by_key(\$tag, 'type') || '');
+ my $name = get_tagval_by_key(\$tag, 'name');
+
+ if ($name && ! $ignore->{$name}) {
+ if (! $type
+ || $type eq 'HIDDEN'
+ || $type eq 'TEXT'
+ || $type eq 'FILE'
+ || ($type eq 'PASSWORD' && $fill_password)) {
+
+ my $value = $get_form_value->($name, 'next');
+ if (defined $value) {
+ swap_tagval_by_key(\$tag, 'value', $value);
+ } elsif (! defined get_tagval_by_key(\$tag, 'value')) {
+ swap_tagval_by_key(\$tag, 'value', '');
+ }
+
+ } elsif ($type eq 'CHECKBOX'
+ || $type eq 'RADIO') {
+ my $values = $get_form_value->($name, 'all');
+ if (@$values) {
+ $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
+
+ my $fvalue = get_tagval_by_key(\$tag, 'value');
+ $fvalue = 'on' if ! defined $fvalue;
+ if (defined $fvalue) {
+ foreach (@$values) {
+ next if $_ ne $fvalue;
+ $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
+ last;
+ }
+ }
+ }
+ }
+
+ }
+ $tag; # return of swap
}sigex;
- if ($n) {
- substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
- }
+
+
+ ### Second pass
+ ### swap select boxes (must be done in such a way as to allow no closing tag)
+ my @start = ();
+ my @close = ();
+ push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
+ push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*select\b)|ig;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ while (defined($close[$i]) && $close[$i] < $start[$i]) {
+ splice (@close,$i,1,());
+ }
+ if ($i == $#start) {
+ $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
+ } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
+ $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
+ }
}
- }
-
-
- ### Third pass
- ### swap textareas (must be done in such a way as to allow no closing tag)
- @start = ();
- @close = ();
- push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
- push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
- for (my $i = 0; $i <= $#start; $i ++) {
- while (defined($close[$i]) && $close[$i] < $start[$i]) {
- splice (@close,$i,1,());
+ for (my $i = $#start; $i >= 0; $i --) {
+ my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
+ $opts =~ s{
+ (<select \s # opening
+ (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
+ >) # end of tag
+ }{}sxi || next;
+ next if ! $opts;
+ my $tag = $1;
+ my $name = get_tagval_by_key(\$tag, 'name');
+ my $values = $ignore->{$name} ? [] : $get_form_value->($name, 'all');
+ if ($#$values != -1) {
+ my $n = $opts =~ s{
+ (<option[^>]*>) # opening tag - no embedded > allowed
+ (.*?) # the text value
+ (?=<option|$|</option>) # the next tag
+ }{
+ my ($tag2, $opt) = ($1, $2);
+ $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
+
+ my $fvalues = get_tagval_by_key(\$tag2, 'value', 'all');
+ my $fvalue = @$fvalues ? $fvalues->[0]
+ : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
+ foreach (@$values) {
+ next if $_ ne $fvalue;
+ $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
+ last;
+ }
+ "$tag2$opt"; # return of the swap
+ }sigex;
+ if ($n) {
+ substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
+ }
+ }
}
- if ($i == $#start) {
- $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
- } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
- $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
+
+
+ ### Third pass
+ ### swap textareas (must be done in such a way as to allow no closing tag)
+ @start = ();
+ @close = ();
+ push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
+ push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ while (defined($close[$i]) && $close[$i] < $start[$i]) {
+ splice (@close,$i,1,()); # get rid of extra closes
+ }
+ if ($i == $#start) {
+ $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
+ } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
+ splice(@close, $i, 0, $start[$i + 1]); # set to start of next select if no closing or > next select
+ }
+ }
+ my $offset = 0;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ my $oldval = substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i]);
+ $oldval =~ s{
+ (<textarea \s # opening
+ (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
+ >) # end of tag
+ }{}sxi || next;
+ my $tag = $1;
+ my $name = get_tagval_by_key(\$tag, 'name');
+ if ($name && ! $ignore->{$name}) {
+ my $value = $get_form_value->($name, 'next');
+ next if ! defined $value;
+ substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i], "$tag$value");
+ $offset += length($value) - length($oldval);
+ }
}
- }
- for (my $i = $#start; $i >= 0; $i --) {
- my $oldval = substr($$ref, $start[$i], $close[$i] - $start[$i]);
- $oldval =~ s{
- (<textarea \s # opening
- (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
- >) # end of tag
- }{}sxi || next;
- my $tag = $1;
- my $name = &get_tagval_by_key(\$tag, 'name');
- my $value = $ignore->{$name} ? [] : &$get_form_value($name, 'next');
- next if ! defined $value;
- substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$value");
- }
-
- ### put scripts and comments back and return
- $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
- $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
- return ref($text) ? 1 : $$ref;
+
+ ### put scripts and comments back and return
+ $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
+ $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
+ return 1;
}
### yet another html escaper
### allow pass by value or by reference (reference is modified inplace)
sub html_escape {
- my $str = shift;
- return $str if ! $str;
- my $ref = ref($str) ? $str : \$str;
+ my $str = shift;
+ return $str if ! $str;
+ my $ref = ref($str) ? $str : \$str;
- $$ref =~ s/&/&/g;
- $$ref =~ s/</</g;
- $$ref =~ s/>/>/g;
- $$ref =~ s/\"/"/g;
+ $$ref =~ s/&/&/g;
+ $$ref =~ s/</</g;
+ $$ref =~ s/>/>/g;
+ $$ref =~ s/\"/"/g;
- return ref($str) ? 1 : $$ref;
+ return ref($str) ? 1 : $$ref;
}
### get a named value for key="value" pairs
-### usage: my $val = &get_tagval_by_key(\$tag, $key);
-### usage: my $valsref = &get_tagval_by_key(\$tag, $key, 'all');
+### usage: my $val = get_tagval_by_key(\$tag, $key);
+### usage: my $valsref = get_tagval_by_key(\$tag, $key, 'all');
sub get_tagval_by_key {
- my $tag = shift;
- my $ref = ref($tag) ? $tag : \$tag;
- my $key = lc(shift);
- my $all = $_[0] && $_[0] eq 'all';
- my @all = ();
- pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
-
- ### loop looking for tag pairs
- while ($$ref =~ m{
- (?<![\w\.\-]) # 0 - not proceded by letter or .
- ([\w\.\-]+) # 1 - the key
- \s*= # equals
- (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
- | ([^\s/]*? (?=\s|>|/>)) # 4 - a non-quoted string
- )
- }sigx) {
- next if lc($1) ne $key;
- my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
- $val =~ s/\\$quot/$quot/ if $quot;
- return $val if ! $all;
- push @all, $val;
- }
- return undef if ! $all;
- return \@all;
+ my $tag = shift;
+ my $ref = ref($tag) ? $tag : \$tag;
+ my $key = lc(shift);
+ my $all = $_[0] && $_[0] eq 'all';
+ my @all = ();
+ pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
+
+ ### loop looking for tag pairs
+ while ($$ref =~ m{
+ (?<![\w\.\-]) # 0 - not proceded by letter or .
+ ([\w\.\-]+) # 1 - the key
+ \s*= # equals
+ (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
+ | ([^\s/]*? (?=\s|>|/>)) # 4 - a non-quoted string
+ )
+ }sigx) {
+ next if lc($1) ne $key;
+ my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
+ $val =~ s/\\$quot/$quot/ if $quot;
+ return $val if ! $all;
+ push @all, $val;
+ }
+ return undef if ! $all;
+ return \@all;
}
### swap out values for key="value" pairs
### usage: my $count = &swap_tagval_by_key(\$tag, $key, $val);
### usage: my $newtag = &swap_tagval_by_key($tag, $key, $val);
sub swap_tagval_by_key {
- my $tag = shift;
- my $ref = ref($tag) ? $tag : \$tag;
- my $key = lc(shift);
- my $val = shift;
- my $n = 0;
-
- ### swap a key/val pair at time
- $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+) # 1 - open tag or previous position
- ( ([\w\-\.]+) # 2 - group, 3 - the key
- (\s*=) # 4 - equals
- (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
- | [^\s/]*? (?=\s|>|/>) # a non-quoted string (may be zero length)
- )
- | ([^\s/]+?) (?=\s|>|/>) # 6 - a non keyvalue chunk (CHECKED)
- )
- }{
- if (defined($3) && lc($3) eq $key) { # has matching key value pair
- if (! $n ++) { # only put value back on first match
- "$1$3$4\"$val\""; # always double quote
- } else {
- $1; # second match
- }
- } elsif (defined($6) && lc($6) eq $key) { # has matching key
- if (! $n ++) { # only put value back on first match
- "$1$6=\"$val\"";
- } else {
- $1; # second match
- }
- } else {
- "$1$2"; # non-keyval
- }
- }sigex;
-
- ### append value on if none were swapped
- if (! $n) {
- $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
- $n = -1;
- }
-
- return ref($tag) ? $n : $$ref;
+ my $tag = shift;
+ my $ref = ref($tag) ? $tag : \$tag;
+ my $key = lc(shift);
+ my $val = shift;
+ my $n = 0;
+
+ ### swap a key/val pair at time
+ $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+) # 1 - open tag or previous position
+ ( ([\w\-\.]+) # 2 - group, 3 - the key
+ (\s*=) # 4 - equals
+ (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
+ | [^\s/]*? (?=\s|>|/>) # a non-quoted string (may be zero length)
+ )
+ | ([^\s/]+?) (?=\s|>|/>) # 6 - a non keyvalue chunk (CHECKED)
+ )
+ }{
+ if (defined($3) && lc($3) eq $key) { # has matching key value pair
+ if (! $n ++) { # only put value back on first match
+ "$1$3$4\"$val\""; # always double quote
+ } else {
+ $1; # second match
+ }
+ } elsif (defined($6) && lc($6) eq $key) { # has matching key
+ if (! $n ++) { # only put value back on first match
+ "$1$6=\"$val\"";
+ } else {
+ $1; # second match
+ }
+ } else {
+ "$1$2"; # non-keyval
+ }
+ }sigex;
+
+ ### append value on if none were swapped
+ if (! $n) {
+ $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
+ $n = -1;
+ }
+
+ return ref($tag) ? $n : $$ref;
}
1;
###----------------------------------------------------------------###
-=head1 NAME
+=head1 SYNOPSIS
-CGI::Ex::Fill - Yet another form filler
+ use CGI::Ex::Fill qw(form_fill fill);
-=head1 SYNOPSIS
+ my $text = my_own_template_from_somewhere();
- use CGI::Ex::Fill qw(form_fill);
+ my $form = CGI->new;
+ # OR
+ # my $form = {key => 'value'}
+ # OR
+ # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
- my $text = my_own_template_from_somewhere();
- my $form = CGI->new;
- # OR
- # my $form = {key => 'value'}
- # OR
- # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
+ form_fill(\$text, $form); # modifies $text
+ # OR
+ # my $copy = form_fill($text, $form); # copies $text
- form_fill(\$text, $form); # modifies $text
- # OR
- # my $copy = form_fill($text, $form); # copies $text
+ # OR
+ fill({
+ text => \$text,
+ form => $form,
+ });
- ALSO
+ # ALSO
- my $formname = 'formname'; # table to parse (undef = anytable)
- my $fp = 0; # fill_passwords ? default is true
- my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
+ my $formname = 'formname'; # form to parse (undef = anytable)
+ my $fp = 0; # fill_passwords ? default is true
+ my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
- form_fill(\$text, $form, $formname, $fp, $ignore);
+ form_fill(\$text, $form, $formname, $fp, $ignore);
- ALSO
+ # OR
+ fill({
+ text => \$text,
+ form => $form,
+ target => 'my_formname',
+ fill_password => $fp,
+ ignore_fields => $ignore,
+ });
- ### delay getting the value until we find an element that needs it
- my $form = {key => sub {my $key = shift; # get and return value}};
+ # ALSO
+
+ ### delay getting the value until we find an element that needs it
+ my $form = {key => sub {my $key = shift; # get and return value}};
=head1 DESCRIPTION
-form_fill is directly comparable to HTML::FillInForm. It will pass the
-same suite of tests (actually - it is a little bit kinder on the parse as
-it won't change case, reorder your attributes, or miscellaneous spaces).
-
-HTML::FillInForm both benefits and suffers from being based on
-HTML::Parser. It is good for standards and poor for performance. Testing
-the form_fill module against HTML::FillInForm gave some surprising
-results. On tiny forms (< 1 k) form_fill was ~ 17% faster than FillInForm.
-If the html document incorporated very many entities at all, the
-performace of FillInForm goes down (and down). However, if you are only
-filling in one form every so often, then it shouldn't matter - but form_fill
-will be nicer on the tags and won't balk at ugly html.
-See the benchmarks in the t/samples directory for more information (ALL
-BENCHMARKS SHOULD BE TAKEN WITH A GRAIN OF SALT).
+form_fill is directly comparable to HTML::FillInForm. It will pass
+the same suite of tests (actually - it is a little bit kinder on the
+parse as it won't change case, reorder your attributes, or alter
+miscellaneous spaces and it won't require the HTML to be well formed).
+
+HTML::FillInForm is based upon HTML::Parser while CGI::Ex::Fill is
+purely regex driven. The performance of CGI::Ex::Fill will be better
+on HTML with many markup tags because HTML::Parser will parse each tag
+while CGI::Ex::Fill will search only for those tags it knows how to
+handle. And CGI::Ex::Fill generally won't break on malformed html.
+
+On tiny forms (< 1 k) form_fill was ~ 13% slower than FillInForm. If
+the html document incorporated very many entities at all, the
+performance of FillInForm goes down (adding 360 <br> tags pushed
+form_fill to ~ 350% faster). However, if you are only filling in one
+form every so often, then it shouldn't matter which you use - but
+form_fill will be nicer on the tags and won't balk at ugly html and
+will decrease performance only at a slow rate as the size of the html
+increases. See the benchmarks in the t/samples/bench_cgix_hfif.pl
+file for more information (ALL BENCHMARKS SHOULD BE TAKEN WITH A GRAIN
+OF SALT).
+
+There are two functions, fill and form_fill. The function fill takes
+a hashref of named arguments. The function form_fill takes a list
+of positional parameters.
+
+=head1 ARGUMENTS TO form_fill
+
+The following are the arguments to the main function C<fill>.
+
+=over 4
+
+=item text
+
+A reference to an html string that includes one or more forms.
+
+=item form
+
+A form hash, CGI object, or an array of hashrefs and objects.
+
+=item target
+
+The name of the form to swap. Default is undef which means
+to swap all form entities in all forms.
+
+=item fill_password
+
+Default true. If set to false, fields of type password will
+not be refilled.
+
+=item ignore_fields
+
+Hashref of fields to be ignored from swapping.
+
+=item remove_script
+
+Defaults to the package global $REMOVE_SCRIPT which defaults to true.
+Removes anything in <script></script> tags which often cause problems for
+parsers.
+
+=item remove_comment
+
+Defaults to the package global $REMOVE_COMMENT which defaults to true.
+Removes anything in <!-- --> tags which can sometimes cause problems for
+parsers.
+
+=item object_method
+
+The method to call on objects passed to the form argument. Default value
+is the package global $OBJECT_METHOD which defaults to 'param'. If a
+CGI object is passed, it would call param on that object passing
+the desired keyname as an argument.
+
+=back
+
+=head1 ARGUMENTS TO form_fill
+
+The following are the arguments to the legacy function C<form_fill>.
+
+=over 4
+
+=item C<\$html>
+
+A reference to an html string that includes one or more forms or form
+entities.
+
+=item C<\%FORM>
+
+A form hash, or CGI query object, or an arrayref of multiple hash refs
+and/or CGI query objects that will supply values for the form.
+
+=item C<$form_name>
+
+The name of the form to fill in values for. The default is undef
+which indicates that all forms are to be filled in.
+
+=item C<$swap_pass>
+
+Default true. Indicates that C<<lt>input type="password"<gt>> fields
+are to be swapped as well. Set to false to disable this behavior.
+
+=item C<\%IGNORE_FIELDS> OR C<\@IGNORE_FIELDS>
+
+A hash ref of key names or an array ref of key names that will be
+ignored during the fill in of the form.
+
+=back
+
+=head1 BEHAVIOR
+
+fill and form_fill will attempt to DWYM when filling in values. The following behaviors
+are used on the following types of form elements.
+
+=over 4
+
+=item C<E<lt>input type="text"E<gt>>
+
+The following rules are used when matching this type:
+
+ 1) Get the value from the form that matches the input's "name".
+ 2) If the value is defined - it adds or replaces the existing value.
+ 3) If the value is not defined and the existing value is not defined,
+ a value of "" is added.
+
+For example:
+
+ my $form = {foo => "FOO", bar => "BAR", baz => "BAZ"};
+
+ my $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=bar value="">
+ <input type=text name=baz value="Something else">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=text name=foo value="FOO">
+ <input type=text name=foo value="FOO">
+ <input type=text name=bar value="BAR">
+ <input type=text name=baz value="BAZ">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw value="">
+ ';
+
+
+If the value returned from the form is an array ref, the values of the array ref
+will be sequentially used for each input found by that name until the values
+run out. If the value is not an array ref - it will be used to fill in any values
+by that name. For example:
+
+ $form = {foo => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=text name=foo value="aaaa">
+ <input type=text name=foo value="bbbb">
+ <input type=text name=foo value="cccc">
+ <input type=text name=foo value="">
+ <input type=text name=foo value="">
+ ';
+
+=item C<E<lt>input type="hidden"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>.
+
+=item C<E<lt>input type="password"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>.
+
+=item C<E<lt>input type="file"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>. (Note - this is subject
+to browser support for pre-population)
+
+=item C<E<lt>input type="checkbox"E<gt>>
+
+As each checkbox is found the following rules are applied:
+
+ 1) Get the values from the form (do nothing if no values found)
+ 2) Remove any existing "checked=checked" or "checked" markup from the tag.
+ 3) Compare the "value" field to the values and mark with checked="checked"
+ if there is a match.
+
+If no "value" field is found in the html, a default value of "on" will be used (which is
+what most browsers will send as the default value for checked boxes without
+"value" fields).
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc'], baz => 'on'};
+
+ $html = '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO">
+ <input type=checkbox name=bar value="aaaa">
+ <input type=checkbox name=bar value="cccc">
+ <input type=checkbox name=bar value="dddd" checked="checked">
+ <input type=checkbox name=baz>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO" checked="checked">
+ <input type=checkbox name=bar value="aaaa" checked="checked">
+ <input type=checkbox name=bar value="cccc" checked="checked">
+ <input type=checkbox name=bar value="dddd">
+ <input type=checkbox name=baz checked="checked">
+ ';
+
+
+=item C<E<lt>input type="radio"E<gt>>
+
+Same as C<E<lt>input type="checkbox"E<gt>>.
+
+=item C<E<lt>selectE<gt>>
+
+As each select box is found the following rules are applied (these rules are
+applied regardless of if the box is a select-one or a select-multi - if multiple
+values are selected on a select-one it is up to the browser to choose which one
+to highlight):
+
+ 1) Get the values from the form (do nothing if no values found)
+ 2) Remove any existing "selected=selected" or "selected" markup from the tag.
+ 3) Compare the "value" field to the values and mark with selected="selected"
+ if there is a match.
+ 4) If there is no "value" field - use the text in between the "option" tags.
+
+ (Note: There does not need to be a closing "select" tag or closing "option" tag)
+
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <select name=foo><option>FOO<option>123<br>
+
+ <select name=bar>
+ <option>aaaa</option>
+ <option value="cccc">cccc</option>
+ <option value="dddd" selected="selected">dddd</option>
+ </select>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <select name=foo><option selected="selected">FOO<option>123<br>
+
+ <select name=bar>
+ <option selected="selected">aaaa</option>
+ <option value="cccc" selected="selected">cccc</option>
+ <option value="dddd">dddd</option>
+ </select>
+ ', "Perldoc example 4 passed");
+
+
+=item C<E<lt>textareaE<gt>>
+
+The rules for swapping textarea are as follows:
+
+ 1) Get the value from the form that matches the textarea's "name".
+ 2) If the value is defined - it adds or replaces the existing value.
+ 3) If the value is not defined, the text area is left alone.
+
+ (Note - there does not need to be a closing textarea tag. In the case of
+ a missing close textarea tag, the contents of the text area will be
+ assumed to be the start of the next textarea of the end of the document -
+ which ever comes sooner)
+
+If the form returned an array ref of values, then these values will be
+used sequentially each time a textarea by that name is found. If a single value
+(not array ref) is found, that value will be used for each textarea by that name.
+
+For example.
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb']};
+
+ $html = '
+ <textarea name=foo></textarea>
+ <textarea name=foo></textarea>
+
+ <textarea name=bar>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>dddd</textarea><br>
+ <textarea name=bar><br><br>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <textarea name=foo>FOO</textarea>
+ <textarea name=foo>FOO</textarea>
+
+ <textarea name=bar>aaaa<textarea name=bar>bbbb</textarea><br>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>';
+
+=item C<E<lt>input type="submit"E<gt>>
+
+Does nothing. The value for submit should typically be set by the
+templating system or application system.
+
+=item C<E<lt>input type="button"E<gt>>
+
+Same as submit.
+
+=back
=head1 HTML COMMENT / JAVASCRIPT
comments and javascript, form_fill temporarily removes them during the
fill. You may disable this behavior by setting $REMOVE_COMMENT and
$REMOVE_SCRIPT to 0 before calling form_fill. The main reason for
-doing this would be if you wanted to have form elments inside the
+doing this would be if you wanted to have form elements inside the
javascript and comments get filled. Disabling the removal only
results in a speed increase of 5%. The function uses \0COMMENT\0 and
-\0SCRIPT\0 as placeholders so i'd avoid these in your text (Actually
-they may be reset to whatever you'd like via $MARKER_COMMENT and
-$MARKER_SCRIPT).
+\0SCRIPT\0 as placeholders so it would be good to avoid these in your
+text (Actually they may be reset to whatever you'd like via
+$MARKER_COMMENT and $MARKER_SCRIPT).
-=head1 AUTHOR
+=head1 UTILITY FUNCTIONS
-Paul Seamons
+=over 4
+
+=item C<html_escape>
+
+Very minimal entity escaper for filled in values.
+
+ my $escaped = html_escape($unescaped);
+
+ html_escape(\$text_to_escape);
+
+=item C<get_tagval_by_key>
+
+Get a named value for from an html tag (key="value" pairs).
+
+ my $val = get_tagval_by_key(\$tag, $key);
+ my $valsref = get_tagval_by_key(\$tag, $key, 'all'); # get all values
+
+=item C<swap_tagval_by_key>
+
+Swap out values in an html tag (key="value" pairs).
+
+ my $count = swap_tagval_by_key(\$tag, $key, $val); # modify ref
+ my $newtag = swap_tagval_by_key($tag, $key, $val); # copies tag
+
+=back
=head1 LICENSE
This module may distributed under the same terms as Perl itself.
+=head1 AUTHOR
+
+Paul Seamons
+
=cut
package CGI::Ex::Template;
+###----------------------------------------------------------------###
+# See the perldoc in CGI/Ex/Template.pod
+# Copyright 2006 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
use strict;
-use vars qw(@INCLUDE_PATH $CONTENT_SUBDIR);
-use base qw(Template);
+use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing
+use vars qw($VERSION
+ $TAGS
+ $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS
+ $DIRECTIVES $QR_DIRECTIVE
+
+ $OPERATORS
+ $OP_UNARY
+ $OP_BINARY
+ $OP_TRINARY
+ $OP_DISPATCH
+
+ $QR_OP
+ $QR_OP_UNARY
+ $QR_OP_PARENED
+
+ $QR_COMMENTS
+ $QR_FILENAME
+ $QR_AQ_NOTDOT
+ $QR_AQ_SPACE
+ $QR_PRIVATE
+
+ $PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
+ $WHILE_MAX
+ $EXTRA_COMPILE_EXT
+ $DEBUG
+ );
+
+BEGIN {
+ $VERSION = '2.00';
+
+ $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
+ $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
+ $PACKAGE_CONTEXT = 'CGI::Ex::Template::_Context';
+ $PACKAGE_STASH = 'CGI::Ex::Template::_Stash';
+ $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';
+
+ $TAGS ||= {
+ default => ['[%', '%]'], # default
+ template => ['[%', '%]'], # default
+ metatext => ['%%', '%%'], # Text::MetaText
+ star => ['[*', '*]'], # TT alternate
+ php => ['<?', '?>'], # PHP
+ asp => ['<%', '%>'], # ASP
+ mason => ['<%', '>' ], # HTML::Mason
+ html => ['<!--', '-->'], # HTML comments
+ };
+
+ $SCALAR_OPS ||= {
+ chunk => \&vmethod_chunk,
+ collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
+ defined => sub { 1 },
+ indent => \&vmethod_indent,
+ 'format' => \&vmethod_format,
+ hash => sub { {value => $_[0]} },
+ html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
+ lcfirst => sub { lcfirst $_[0] },
+ length => sub { defined($_[0]) ? length($_[0]) : 0 },
+ lower => sub { lc $_[0] },
+ match => \&vmethod_match,
+ null => sub { '' },
+ remove => sub { vmethod_replace(shift, shift, '', 1) },
+ repeat => \&vmethod_repeat,
+ replace => \&vmethod_replace,
+ search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return scalar $str =~ /$pat/ },
+ size => sub { 1 },
+ split => \&vmethod_split,
+ stderr => sub { print STDERR $_[0]; '' },
+ substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
+ trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
+ ucfirst => sub { ucfirst $_[0] },
+ upper => sub { uc $_[0] },
+ uri => \&vmethod_uri,
+ };
+
+ $FILTER_OPS ||= { # generally - non-dynamic filters belong in scalar ops
+ eval => [\&filter_eval, 1],
+ evaltt => [\&filter_eval, 1],
+ file => [\&filter_redirect, 1],
+ redirect => [\&filter_redirect, 1],
+ };
+
+ $LIST_OPS ||= {
+ first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
+ grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
+ hash => sub { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
+ join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
+ last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
+ list => sub { $_[0] },
+ max => sub { $#{ $_[0] } },
+ merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
+ nsort => \&vmethod_nsort,
+ pop => sub { pop @{ $_[0] } },
+ push => sub { my $ref = shift; push @$ref, @_; return '' },
+ reverse => sub { [ reverse @{ $_[0] } ] },
+ shift => sub { shift @{ $_[0] } },
+ size => sub { scalar @{ $_[0] } },
+ slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
+ sort => \&vmethod_sort,
+ splice => \&vmethod_splice,
+ unique => sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
+ unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
+ };
+
+ $HASH_OPS ||= {
+ defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
+ delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
+ each => sub { [%{ $_[0] }] },
+ exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
+ hash => sub { $_[0] },
+ import => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
+ keys => sub { [keys %{ $_[0] }] },
+ list => sub { [$_[0]] },
+ pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] },
+ nsort => sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] },
+ size => sub { scalar keys %{ $_[0] } },
+ sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
+ values => sub { [values %{ $_[0] }] },
+ };
+
+ $DIRECTIVES = {
+ #name #parse_sub #play_sub #block #postdir #continue #move_to_front
+ BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1, 0, 0, 1],
+ BREAK => [sub {}, \&play_control],
+ CALL => [\&parse_CALL, \&play_CALL],
+ CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}],
+ CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}],
+ CLEAR => [sub {}, \&play_CLEAR],
+ '#' => [sub {}, sub {}],
+ DEBUG => [\&parse_DEBUG, \&play_DEBUG],
+ DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT],
+ DUMP => [\&parse_DUMP, \&play_DUMP],
+ ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
+ ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
+ END => [undef, sub {}],
+ FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1],
+ '|' => [\&parse_FILTER, \&play_FILTER, 1, 1],
+ FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}],
+ FOR => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
+ FOREACH => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
+ GET => [\&parse_GET, \&play_GET],
+ IF => [\&parse_IF, \&play_IF, 1, 1],
+ INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
+ INSERT => [\&parse_INSERT, \&play_INSERT],
+ LAST => [sub {}, \&play_control],
+ MACRO => [\&parse_MACRO, \&play_MACRO],
+ META => [undef, sub {}],
+ METADEF => [undef, \&play_METADEF],
+ NEXT => [sub {}, \&play_control],
+ PERL => [\&parse_PERL, \&play_PERL, 1],
+ PROCESS => [\&parse_PROCESS, \&play_PROCESS],
+ RAWPERL => [\&parse_PERL, \&play_RAWPERL, 1],
+ RETURN => [sub {}, \&play_control],
+ SET => [\&parse_SET, \&play_SET],
+ STOP => [sub {}, \&play_control],
+ SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1],
+ TAGS => [undef, sub {}],
+ THROW => [\&parse_THROW, \&play_THROW],
+ TRY => [sub {}, \&play_TRY, 1],
+ UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1],
+ USE => [\&parse_USE, \&play_USE],
+ WHILE => [\&parse_IF, \&play_WHILE, 1, 1],
+ WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1],
+ #name #parse_sub #play_sub #block #postdir #continue #move_to_front
+ };
+ $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x;
+
+ ### setup the operator parsing
+ $OPERATORS ||= [
+ # name => # order, precedence, symbols, only_in_parens, sub to create
+ [2, 96, ['**', '^', 'pow'], 0, sub { $_[0] ** $_[1] } ],
+ [1, 93, ['!'], 0, sub { ! $_[0] } ],
+ [1, 93, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
+ [2, 90, ['*'], 0, sub { $_[0] * $_[1] } ],
+ [2, 90, ['/'], 0, sub { $_[0] / $_[1] } ],
+ [2, 90, ['div', 'DIV'], 0, sub { int($_[0] / $_[1]) } ],
+ [2, 90, ['%', 'mod', 'MOD'], 0, sub { $_[0] % $_[1] } ],
+ [2, 85, ['+'], 0, sub { $_[0] + $_[1] } ],
+ [2, 85, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
+ [2, 85, ['_', '~'], 0, sub { join "", @_ } ],
+ [2, 80, ['<'], 0, sub { $_[0] < $_[1] } ],
+ [2, 80, ['>'], 0, sub { $_[0] > $_[1] } ],
+ [2, 80, ['<='], 0, sub { $_[0] <= $_[1] } ],
+ [2, 80, ['>='], 0, sub { $_[0] >= $_[1] } ],
+ [2, 80, ['lt'], 0, sub { $_[0] lt $_[1] } ],
+ [2, 80, ['gt'], 0, sub { $_[0] gt $_[1] } ],
+ [2, 80, ['le'], 0, sub { $_[0] le $_[1] } ],
+ [2, 80, ['ge'], 0, sub { $_[0] ge $_[1] } ],
+ [2, 75, ['==', 'eq'], 0, sub { $_[0] eq $_[1] } ],
+ [2, 75, ['!=', 'ne'], 0, sub { $_[0] ne $_[1] } ],
+ [2, 70, ['&&'], 0, undef ],
+ [2, 65, ['||'], 0, undef ],
+ [2, 60, ['..'], 0, sub { $_[0] .. $_[1] } ],
+ [3, 55, ['?', ':'], 0, undef ],
+ [2, 52, ['='], 1, undef ],
+ [1, 50, ['not', 'NOT'], 0, sub { ! $_[0] } ],
+ [2, 45, ['and', 'AND'], 0, undef ],
+ [2, 40, ['or', 'OR'], 0, undef ],
+ [0, 0, ['hash'], 0, sub { return {@_}; } ],
+ [0, 0, ['array'], 0, sub { return [@_] } ],
+ ];
+ $OP_DISPATCH ||= {map {my $ref = $_; map {$_ => $ref->[4]} @{$ref->[2]}} @$OPERATORS};
+ $OP_UNARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS};
+ $OP_BINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS};
+ $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$OPERATORS};
+ sub _op_qr { # no mixed \w\W operators
+ my %used;
+ my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
+ my $chr = join '', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
+ my $word = join '|', grep {++$used{$_} < 2} grep {/^\w+$/} @_;
+ $chr = "[$chr]" if $chr;
+ $word = "\\b(?:$word)\\b" if $word;
+ return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
+ }
+ sub _build_op_qr { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops
+ sub _build_op_qr_unary { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] == 1 } @$OPERATORS) } # unary operators
+ sub _build_op_qr_paren { _op_qr(sort map {@{ $_->[2] }} grep { $_->[3]} @$OPERATORS) } # paren
+ $QR_OP ||= _build_op_qr();
+ $QR_OP_UNARY ||= _build_op_qr_unary();
+ $QR_OP_PARENED ||= _build_op_qr_paren();
-use CGI::Ex;
-use CGI::Ex::Fill;
-$CONTENT_SUBDIR ||= 'content';
+ $QR_COMMENTS = '(?-s: \# .* \s*)*';
+ $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\-\.]+ (?:/[\w\-\.]+)*';
+ $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
+ $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=[;+]) )'; # the + comes into play on filenames
+ $QR_PRIVATE ||= qr/^_/;
+
+ $WHILE_MAX ||= 1000;
+ $EXTRA_COMPILE_EXT = '.sto';
+};
###----------------------------------------------------------------###
sub new {
my $class = shift;
- my $args = ref($_[0]) ? shift : {@_};
+ my $args = ref($_[0]) ? { %{ shift() } } : {@_};
+ my $self = bless $args, $class;
- $args->{INCLUDE_PATH} ||= \@INCLUDE_PATH;
+ ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
+ if ($self->{'DEBUG'}) {
+ $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
+ $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
+ }
- return $class->SUPER::new($args);
+ return $self;
}
-sub process {
- my $self = ref($_[0]) ? shift : shift->new;
- my $in = shift;
+###----------------------------------------------------------------###
- ### force the content to have a .html prefix
- if (! ref $in) {
- $in .= '.html' if $in !~ /\.\w+$/;
- }
+sub _process {
+ my $self = shift;
+ my $file = shift;
+ local $self->{'_vars'} = shift || {};
+ my $out_ref = shift || $self->throw('undef', "Missing output ref");
+ local $self->{'_top_level'} = delete $self->{'_start_top_level'};
+ my $i = length $$out_ref;
- ### prepend "content" dir as needed
- if (! ref($in) # not a scalar ref or a file glob
- && $in =~ m|^\w+(\.\w+)?(/\w+(\.\w+)?)*$| # not an absolute filename
- && index($in, $CONTENT_SUBDIR) == -1) {
- $in = $CONTENT_SUBDIR .'/'. $in;
- }
+ ### parse and execute
+ my $doc;
+ eval {
+ ### load the document
+ $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");;
+
+ ### prevent recursion
+ $self->throw('file', "recursion into '$doc->{name}'")
+ if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text';
+ local $self->{'_in'}->{$doc->{'name'}} = 1;
+
+ ### execute the document
+ if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content
+ $$out_ref = ${ $doc->{'_content'} };
+ } else {
+ local $self->{'_vars'}->{'component'} = $doc;
+ $self->{'_vars'}->{'template'} = $doc if $self->{'_top_level'};
+ $self->execute_tree($doc->{'_tree'}, $out_ref);
+ delete $self->{'_vars'}->{'template'} if $self->{'_top_level'};
+ }
+ };
+
+ ### trim whitespace from the beginning and the end of a block or template
+ if ($self->{'TRIM'}) {
+ substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first
+ substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x;
+ }
+
+ ### handle exceptions
+ if (my $err = $@) {
+ $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
+ $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
+ die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/;
+ }
+
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+sub load_parsed_tree {
+ my $self = shift;
+ my $file = shift;
+ return if ! defined $file;
+
+ my $doc = {name => $file};
+
+ ### looks like a string reference
+ if (ref $file) {
+ $doc->{'_content'} = $file;
+ $doc->{'name'} = 'input text';
+ $doc->{'is_str_ref'} = 1;
+
+ ### looks like a previously cached-in-memory document
+ } elsif ($self->{'_documents'}->{$file}
+ && ( ($self->{'_documents'}->{$file}->{'_cache_time'} == time) # don't stat more than once a second
+ || ($self->{'_documents'}->{$file}->{'modtime'}
+ == (stat $self->{'_documents'}->{$file}->{'_filename'})[9]))) {
+ $doc = $self->{'_documents'}->{$file};
+ $doc->{'_cache_time'} = time;
+ return $doc;
+
+ ### looks like a block name of some sort
+ } elsif ($self->{'BLOCKS'}->{$file}) {
+ my $block = $self->{'BLOCKS'}->{$file};
+
+ ### allow for predefined blocks that are a code or a string
+ if (UNIVERSAL::isa($block, 'CODE')) {
+ $block = $block->();
+ }
+ if (! UNIVERSAL::isa($block, 'HASH')) {
+ $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block;
+ my $copy = $block;
+ $block = eval { $self->load_parsed_tree(\$copy) }
+ || $self->throw('block', 'Parse error on predefined block');
+ }
+ $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)");
+ return $doc;
+
+
+ ### go and look on the file system
+ } else {
+ $doc->{'_filename'} = eval { $self->include_filename($file) };
+ if (my $err = $@) {
+ ### allow for blocks in other files
+ if ($self->{'EXPOSE_BLOCKS'}
+ && ! $self->{'_looking_in_block_file'}) {
+ local $self->{'_looking_in_block_file'} = 1;
+ my $block_name = '';
+ while ($file =~ s|/([^/.]+)$||) {
+ $block_name = length($block_name) ? "$1/$block_name" : $1;
+ my $ref = eval { $self->load_parsed_tree($file) } || next;
+ my $_tree = $ref->{'_tree'};
+ foreach my $node (@$_tree) {
+ next if ! ref $node;
+ next if $node->[0] eq 'METADEF';
+ last if $node->[0] ne 'BLOCK';
+ next if $block_name ne $node->[3];
+ $doc->{'_content'} = $ref->{'_content'};
+ $doc->{'_tree'} = $node->[4];
+ $doc->{'modtime'} = $ref->{'modtime'};
+ $file = $ref->{'name'};
+ last;
+ }
+ }
+ die $err if ! $doc->{'_tree'};
+ } elsif ($self->{'DEFAULT'}) {
+ $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err;
+ } else {
+ die $err;
+ }
+ }
+
+ ### no tree yet - look for a file cache
+ if (! $doc->{'_tree'}) {
+ $doc->{'modtime'} = (stat $doc->{'_filename'})[9];
+ if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) {
+ if ($self->{'COMPILE_DIR'}) {
+ $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file;
+ } else {
+ $doc->{'_compile_filename'} = $doc->{'_filename'};
+ }
+ $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'});
+ $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT;
+
+ if (-e $doc->{'_compile_filename'} && (stat _)[9] == $doc->{'modtime'}) {
+ require Storable;
+ $doc->{'_tree'} = Storable::retrieve($doc->{'_compile_filename'});
+ $doc->{'compile_was_used'} = 1;
+ } else {
+ my $str = $self->slurp($doc->{'_filename'});
+ $doc->{'_content'} = \$str;
+ }
+ } else {
+ my $str = $self->slurp($doc->{'_filename'});
+ $doc->{'_content'} = \$str;
+ }
+ }
+
+ }
+
+ ### haven't found a parsed tree yet - parse the content into a tree
+ if (! $doc->{'_tree'}) {
+ if ($self->{'CONSTANTS'}) {
+ my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants';
+ $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'};
+ }
+
+ local $self->{'_vars'}->{'component'} = $doc;
+ $doc->{'_tree'} = $self->parse_tree($doc->{'_content'}); # errors die
+ }
+
+ ### cache parsed_tree in memory unless asked not to do so
+ if (! $doc->{'is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) {
+ $self->{'_documents'}->{$file} ||= $doc;
+ $doc->{'_cache_time'} = time;
+
+ ### allow for config option to keep the cache size down
+ if ($self->{'CACHE_SIZE'}) {
+ my $all = $self->{'_documents'};
+ if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) {
+ my $n = 0;
+ foreach my $file (sort {$all->{$b}->{'_cache_time'} <=> $all->{$a}->{'_cache_time'}} keys %$all) {
+ delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'};
+ }
+ }
+ }
+ }
+
+ ### save a cache on the fileside as asked
+ if ($doc->{'_compile_filename'} && ! $doc->{'compile_was_used'}) {
+ my $dir = $doc->{'_compile_filename'};
+ $dir =~ s|/[^/]+$||;
+ if (! -d $dir) {
+ require File::Path;
+ File::Path::mkpath($dir);
+ }
+ require Storable;
+ Storable::store($doc->{'_tree'}, $doc->{'_compile_filename'});
+ utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'};
+ }
+
+ return $doc;
+}
+
+sub parse_tree {
+ my $self = shift;
+ my $str_ref = shift;
+ if (! $str_ref || ! defined $$str_ref) {
+ $self->throw('parse.no_string', "No string or undefined during parse");
+ }
+
+ my $STYLE = $self->{'TAG_STYLE'} || 'default';
+ my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0];
+ my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1];
+ my $len_s = length $START;
+ my $len_e = length $END;
+
+ my @tree; # the parsed tree
+ my $pointer = \@tree; # pointer to current tree to handle nested blocks
+ my @state; # maintain block levels
+ local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
+ local $self->{'_in_perl'}; # no interpolation in perl
+ my @move_to_front; # items that need to be declared first (usually BLOCKS)
+ my @meta; # place to store any found meta information (to go into METADEF)
+ my $i = 0; # start index
+ my $j = 0; # end index
+ my $last = 0; # previous end index
+ my $post_chomp = 0; # previous post_chomp setting
+ my $continue; # multiple directives in the same tag
+ my $post_op; # found a post-operative DIRECTIVE
+ my $capture; # flag to start capture
+ my $func;
+ my $node;
+ my $tag;
+ while (1) {
+ ### continue looking for information in a semi-colon delimited tag
+ if ($continue) {
+ $i = $continue;
+ $node = [undef, $i, $j];
+
+ ### look through the string using index
+ } else {
+ $i = index($$str_ref, $START, $last);
+ last if $i == -1; # no start tag found - we are done
+ if ($last != $i) { # found a text portion - chomp it, interpolate it and store it
+ my $text = substr($$str_ref, $last, $i - $last);
+ my $_last = $last;
+ if ($post_chomp) {
+ if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
+ elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
+ elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
+ }
+ if (length $text) {
+ push @$pointer, $text;
+ $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
+ }
+ }
+ $j = index($$str_ref, $END, $i + $len_s);
+ $last = $j + $len_e;
+ if ($j == -1) { # missing closing tag
+ $last = length($$str_ref);
+ last;
+ }
+ $tag = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
+ $node = [undef, $i + $len_s, $j];
+
+ ### take care of whitespace and comments flags
+ my $pre_chomp = $tag =~ s{ ^ ([+=~-]) }{}x ? $1 : $self->{'PRE_CHOMP'};
+ $post_chomp = $tag =~ s{ ([+=~-]) $ }{}x ? $1 : $self->{'POST_CHOMP'};
+ $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
+ $post_chomp =~ y/-=~+/1230/ if $post_chomp;
+ if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
+ if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
+ elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
+ elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
+ splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
+ }
+ if ($tag =~ /^\#/) { # leading # means to comment the entire section
+ $node->[0] = '#';
+ push @$pointer, $node;
+ next;
+ }
+ $tag =~ s{ ^ \s+ $QR_COMMENTS }{}ox;
+ }
+
+ if (! length $tag) {
+ undef $continue;
+ undef $post_op;
+ next;
+ }
+
+ ### look for DIRECTIVES
+ if ($tag =~ $QR_DIRECTIVE # find a word
+ && $DIRECTIVES->{$1} ) { # is it a directive
+ $node->[0] = $func = $1;
+ $tag =~ s{ ^ (\w+ | \|) \s* $QR_COMMENTS }{}ox;
+
+ ### store out this current node level
+ if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
+ my @post_op = @$post_op;
+ @$post_op = @$node;
+ $node = $post_op;
+ $node->[4] = [\@post_op];
+ } elsif ($capture) {
+ # do nothing - it will be handled further down
+ } else{
+ push @$pointer, $node;
+ }
+
+ ### anything that behaves as a block ending
+ if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
+ if (! @state) {
+ $self->throw('parse', "Found an $func tag while not in a block", $node);
+ }
+ my $parent_node = pop @state;
+
+ if ($func ne 'END') {
+ pop @$pointer; # we will store the node in the parent instead
+ $parent_node->[5] = $node;
+ my $parent_type = $parent_node->[0];
+ if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) {
+ $self->throw('parse', "Found unmatched nested block", $node, 0);
+ }
+ }
+
+ ### restore the pointer up one level (because we hit the end of a block)
+ $pointer = (! @state) ? \@tree : $state[-1]->[4];
+
+ ### normal end block
+ if ($func eq 'END') {
+ if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front
+ push @move_to_front, $parent_node;
+ if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
+ splice(@$pointer, -1, 1, ());
+ }
+ } elsif ($parent_node->[0] =~ /PERL$/) {
+ delete $self->{'_in_perl'};
+ }
+
+ ### continuation block - such as an elsif
+ } else {
+ $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
+ if (my $err = $@) {
+ $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
+ die $err;
+ }
+ push @state, $node;
+ $pointer = $node->[4] ||= [];
+ }
+
+ } elsif ($func eq 'TAGS') {
+ if ($tag =~ / ^ (\w+) /x && $TAGS->{$1}) {
+ $tag =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox;
+ ($START, $END) = @{ $TAGS->{$1} };
+ } elsif ($tag =~ s{ ^ (\S+) \s+ (\S+) \s* $QR_COMMENTS }{}ox) {
+ ($START, $END) = ($1, $2);
+ }
+ $len_s = length $START;
+ $len_e = length $END;
+
+ } elsif ($func eq 'META') {
+ my $args = $self->parse_args(\$tag);
+ my $hash;
+ if (($hash = $self->vivify_args($args)->[-1])
+ && UNIVERSAL::isa($hash, 'HASH')) {
+ unshift @meta, %$hash; # first defined win
+ }
+
+ ### all other "normal" tags
+ } else {
+ $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
+ if (my $err = $@) {
+ $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
+ die $err;
+ }
+ if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive
+ push @state, $node;
+ $pointer = $node->[4] ||= [];
+ }
+ }
- return $self->SUPER::process($in, @_);
+ ### allow for bare variable getting and setting
+ } elsif (defined(my $var = $self->parse_variable(\$tag))) {
+ push @$pointer, $node;
+ if ($tag =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
+ $node->[0] = 'SET';
+ $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $var) };
+ if (my $err = $@) {
+ $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
+ die $err;
+ }
+ } else {
+ $node->[0] = 'GET';
+ $node->[3] = $var;
+ }
+
+ } else { # error
+ my $all = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
+ $all =~ s/^\s+//;
+ $all =~ s/\s+$//;
+ $self->throw('parse', "Not sure how to handle tag \"$all\"", $node);
+ }
+
+ ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it
+ if ($capture) {
+ my $parent_node = $capture;
+ push @{ $parent_node->[4] }, $node;
+ undef $capture;
+ }
+
+ ### we are flagged to start capturing the output of the next directive - set it up
+ if ($node->[6]) {
+ $continue = $j - length $tag;
+ $node->[2] = $continue;
+ $post_op = undef;
+ $capture = $node;
+
+ ### semi-colon = end of statement - we will need to continue parsing this tag
+ } elsif ($tag =~ s{ ^ ; \s* $QR_COMMENTS }{}ox) {
+ $continue = $j - length $tag;
+ $node->[2] = $continue;
+ $post_op = undef;
+
+ ### looking at a post operator ([% u FOREACH u IN [1..3] %])
+ } elsif ($tag =~ $QR_DIRECTIVE # find a word
+ && $DIRECTIVES->{$1} # is it a directive
+ && $DIRECTIVES->{$1}->[3]) { # it is a post operative directive
+ $continue = $j - length $tag;
+ $node->[2] = $continue;
+ $post_op = $node;
+
+ } else { # error
+ $self->throw('parse', "Found trailing info \"$tag\"", $node) if length $tag;
+ $continue = undef;
+ $post_op = undef;
+ }
+ }
+
+ if (@move_to_front) {
+ unshift @tree, @move_to_front;
+ }
+ if (@meta) {
+ unshift @tree, ['METADEF', 0, 0, {@meta}];
+ }
+
+ if ($#state > -1) {
+ $self->throw('parse.missing.end', "Missing END", $state[-1], 0);
+ }
+
+ ### pull off the last text portion - if any
+ if ($last != length($$str_ref)) {
+ my $text = substr($$str_ref, $last, length($$str_ref) - $last);
+ my $_last = $last;
+ if ($post_chomp) {
+ if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
+ elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
+ elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
+ }
+ if (length $text) {
+ push @$pointer, $text;
+ $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
+ }
+ }
+
+ return \@tree;
+}
+
+sub execute_tree {
+ my ($self, $tree, $out_ref) = @_;
+
+ # node contains (0: DIRECTIVE,
+ # 1: start_index,
+ # 2: end_index,
+ # 3: parsed tag details,
+ # 4: sub tree for block types
+ # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
+ # 6: flag to capture next directive
+ for my $node (@$tree) {
+ ### text nodes are just the bare text
+ if (! ref $node) {
+ warn "NODE: TEXT\n" if trace;
+ $$out_ref .= $node if defined $node;
+ next;
+ }
+
+ warn "NODE: $node->[0] (char $node->[1])\n" if trace;
+ $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
+
+ my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
+ $$out_ref .= $val if defined $val;
+ }
}
###----------------------------------------------------------------###
-sub out {
- my $self = ref($_[0]) ? shift : shift->new;
-# dex $self;
- my $in = shift;
- my $form = shift;
- my $fill = shift;
- my $out = '';
+sub parse_variable {
+ my $self = shift;
+ my $str_ref = shift;
+ my $ARGS = shift || {};
+
+ ### allow for custom auto_quoting (such as hash constructors)
+ if ($ARGS->{'auto_quote'}) {
+ if ($$str_ref =~ $ARGS->{'auto_quote'}) {
+ my $str = $1;
+ substr($$str_ref, 0, length($str), '');
+ $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
+ return $str;
+ ### allow for auto-quoted $foo or ${foo.bar} type constructs
+ } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
+ || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ return $self->parse_variable(\$name);
+ }
+ }
+
+ my $copy = $$str_ref; # copy while parsing to allow for errors
+
+ ### test for leading unary operators
+ my $has_unary;
+ if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) {
+ return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+ $has_unary = $1;
+ }
+
+ my @var;
+ my $is_literal;
+ my $is_namespace;
+
+ ### allow for numbers
+ if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) {
+ my $number = $1;
+ push @var, \ $number;
+ $is_literal = 1;
+
+ ### looks like a normal variable start
+ } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
+ push @var, $1;
+ $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
+
+ ### allow for literal strings
+ } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
+ if ($1 eq "'") { # no interpolation on single quoted strings
+ my $str = $2;
+ $str =~ s{ \\\' }{\'}xg;
+ push @var, \ $str;
+ $is_literal = 1;
+ } else {
+ my $str = $2;
+ $str =~ s/\\n/\n/g;
+ $str =~ s/\\t/\t/g;
+ $str =~ s/\\r/\r/g;
+ $str =~ s/\\([\"\$])/$1/g;
+ my @pieces = $ARGS->{'auto_quote'}
+ ? split(m{ (\$\w+ | \$\{ [^\}]+ \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
+ : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
+ my $n = 0;
+ foreach my $piece (@pieces) {
+ next if ! ($n++ % 2);
+ next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
+ && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
+ my $name = $1;
+ $piece = $self->parse_variable(\$name);
+ }
+ @pieces = grep {defined && length} @pieces;
+ if (@pieces == 1 && ! ref $pieces[0]) {
+ push @var, \ $pieces[0];
+ $is_literal = 1;
+ } elsif (! @pieces) {
+ push @var, \ '';
+ $is_literal = 1;
+ } else {
+ push @var, \ ['~', @pieces];
+ }
+ }
+ if ($ARGS->{'auto_quote'}){
+ $$str_ref = $copy;
+ return ${ $var[0] } if $is_literal;
+ push @var, 0;
+ return \@var;
+ }
+
+ ### allow for leading $foo or ${foo.bar} type constructs
+ } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
+ || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ push @var, $self->parse_variable(\$name);
+
+ ### looks like an array constructor
+ } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
+ local $self->{'_operator_precedence'} = 0; # reset presedence
+ my $arrayref = ['array'];
+ while (defined(my $var = $self->parse_variable(\$copy))) {
+ push @$arrayref, $var;
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ }
+ $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
+ || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, length($$str_ref) - length($copy));
+ push @var, \ $arrayref;
+
+ ### looks like a hash constructor
+ } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
+ local $self->{'_operator_precedence'} = 0; # reset precedence
+ my $hashref = ['hash'];
+ while (defined(my $key = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
+ $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
+ my $val = $self->parse_variable(\$copy);
+ push @$hashref, $key, $val;
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ }
+ $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
+ || $self->throw('parse.missing.curly_bracket', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
+ push @var, \ $hashref;
+
+ ### looks like a paren grouper
+ } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $self->{'_operator_precedence'} = 0; # reset precedence
+ my $var = $self->parse_variable(\$copy, {allow_parened_ops => 1});
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ @var = @$var;
+ pop(@var); # pull off the trailing args of the paren group
+
+ ### nothing to find - return failure
+ } else {
+ return;
+ }
+
+ return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+
+ ### looks for args for the initial
+ if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $self->{'_operator_precedence'} = 0; # reset precedence
+ my $args = $self->parse_args(\$copy);
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ push @var, $args;
+ } else {
+ push @var, 0;
+ }
+
+ ### allow for nested items
+ while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
+ push(@var, $1) if ! $ARGS->{'no_dots'};
+
+ ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
+ if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
+ || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ my $var = $self->parse_variable(\$name);
+ push @var, $var;
+ } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
+ push @var, $1;
+ } else {
+ $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
+ }
+
+ ### looks for args for the nested item
+ if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $self->{'_operator_precedence'} = 0; # reset precedence
+ my $args = $self->parse_args(\$copy);
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ push @var, $args;
+ } else {
+ push @var, 0;
+ }
- ### run the template
- my $status = $self->process($in, $form, \$out) || die $Template::ERROR;
+ }
- ### fill in any forms
- &CGI::Ex::Fill::form_fill(\$out, $fill) if $fill && ! $self->{no_fill};
+ ### flatten literals and constants as much as possible
+ my $var = ($is_literal && $#var == 1) ? ${ $var[0] }
+ : $is_namespace ? $self->get_variable(\@var, {is_namespace_during_compile => 1})
+ : \@var;
- return $out;
+ ### allow for all "operators"
+ if (! $self->{'_operator_precedence'}) {
+ my $tree;
+ my $found;
+ while ($copy =~ s{ ^ ($QR_OP) \s* $QR_COMMENTS }{}ox ## look for operators - then move along
+ || ($ARGS->{'allow_parened_ops'}
+ && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) {
+ local $self->{'_operator_precedence'} = 1;
+ my $op = $1;
+ my $var2 = $self->parse_variable(\$copy);
+
+ ### allow for unary operator precedence
+ if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) {
+ if ($tree) {
+ if ($#$tree == 1) { # only one operator - keep simple things fast
+ $var = [\ [$tree->[0], $var, $tree->[1]], 0];
+ } else {
+ unshift @$tree, $var;
+ $var = $self->apply_precedence($tree, $found);
+ }
+ undef $tree;
+ undef $found;
+ }
+ $var = [ \ [ $has_unary, $var ], 0 ];
+ undef $has_unary;
+ }
+
+ ### add the operator to the tree
+ push (@{ $tree ||= [] }, $op, $var2);
+ my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op};
+ $found->{$op} = $ref->[1];
+ }
+
+ ### if we found operators - tree the nodes by operator precedence
+ if ($tree) {
+ if (@$tree == 2) { # only one operator - keep simple things fast
+ $var = [\ [$tree->[0], $var, $tree->[1]], 0];
+ } else {
+ unshift @$tree, $var;
+ $var = $self->apply_precedence($tree, $found);
+ }
+ }
+ }
+
+ ### allow for unary on non-chained variables
+ if ($has_unary) {
+ $var = [ \ [ $has_unary, $var ], 0 ];
+ }
+
+ $$str_ref = $copy; # commit the changes
+ return $var;
+}
+
+### this is used to put the parsed variables into the correct operations tree
+sub apply_precedence {
+ my ($self, $tree, $found) = @_;
+
+ my @var;
+ my $trees;
+ ### look at the operators we found in the order we found them
+ for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) {
+ local $found->{$op};
+ delete $found->{$op};
+ my @trees;
+ my @trinary;
+
+ ### split the array on the current operator
+ for (my $i = 0; $i <= $#$tree; $i ++) {
+ my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] };
+ next if $tree->[$i] ne $op && ! $is_trinary;
+ push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
+ push @trinary, $tree->[0] if $is_trinary;
+ shift @$tree; # pull off the operator
+ $i = -1;
+ }
+ next if ! @trees; # this iteration didn't have the current operator
+ push @trees, $tree if scalar @$tree; # elements after last operator
+
+ ### now - for this level split on remaining operators, or add the variable to the tree
+ for my $node (@trees) {
+ if (@$node == 1) {
+ $node = $node->[0]; # single item - its not a tree
+ } elsif (@$node == 3) {
+ $node = [ \ [ $node->[1], $node->[0], $node->[2] ], 0 ]; # single operator - put it straight on
+ } else {
+ $node = $self->apply_precedence($node, $found); # more complicated - recurse
+ }
+ }
+
+ ### return binary
+ if ($OP_BINARY->{$op}) {
+ my $val = $trees[-1];
+ $val = [ \ [ $op, $trees[$_], $val ], 0 ] for reverse (0 .. $#trees - 1); # reverse order - helps out ||
+ return $val;
+ }
+
+ ### return simple trinary
+ if (@trinary == 2) {
+ return [ \ [ $op, @trees ], 0 ];
+ }
+
+ ### reorder complex trinary - rare case
+ while ($#trinary >= 1) {
+ ### if we look starting from the back - the first lead trinary op will always be next to its matching op
+ for (my $i = $#trinary; $i >= 0; $i --) {
+ next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i];
+ my ($op, $op2) = splice @trinary, $i, 2, (); # remove the pair of operators
+ my $node = [ \ [$op, @trees[$i .. $i + 2] ], 0 ];
+ splice @trees, $i, 3, $node;
+ }
+ }
+ return $trees[0]; # at this point the trinary has been reduced to a single operator
+
+ }
+
+ $self->throw('parse', "Couldn't apply precedence");
+}
+
+### look for arguments - both positional and named
+sub parse_args {
+ my $self = shift;
+ my $str_ref = shift;
+ my $ARGS = shift || {};
+ my $copy = $$str_ref;
+
+ my @args;
+ my @named;
+ while (length $$str_ref) {
+ my $copy = $$str_ref;
+ if (defined(my $name = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
+ && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
+ $self->throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
+ my $val = $self->parse_variable(\$copy);
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ push @named, $name, $val;
+ $$str_ref = $copy;
+ } elsif (defined(my $arg = $self->parse_variable($str_ref))) {
+ push @args, $arg;
+ $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ } else {
+ last;
+ }
+ }
+
+ ### allow for named arguments to be added also
+ push @args, [\ ['hash', @named], 0] if scalar @named;
+
+ return \@args;
}
-sub print {
- my $self = ref($_[0]) ? shift : shift->new;
- my $in = shift;
- my $form = shift;
- my $fill = shift || $form;
+### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree.
+sub interpolate_node {
+ my ($self, $tree, $offset) = @_;
+ return if $self->{'_in_perl'};
- &CGI::Ex::content_type();
- print $self->out($in, $form, $fill);
+ ### split on variables while keeping the variables
+ my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $tree->[-1];
+ if ($#pieces <= 0) {
+ $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg;
+ return;
+ }
+
+ my @sub_tree;
+ my $n = 0;
+ foreach my $piece (@pieces) {
+ $offset += length $piece; # we track the offset to make sure DEBUG has the right location
+ if (! ($n++ % 2)) { # odds will always be text chunks
+ next if ! length $piece;
+ $piece =~ s{ \\ ([\"\$]) }{$1}xg;
+ push @sub_tree, $piece;
+ } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
+ || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x) {
+ my $name = $1;
+ push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_variable(\$name)];
+ } else {
+ $self->throw('parse', "Parse error during interpolate node");
+ }
+ }
+
+ ### replace the tree
+ splice @$tree, -1, 1, @sub_tree;
}
###----------------------------------------------------------------###
-1;
+sub get_variable {
+ ### allow for the parse tree to store literals
+ return $_[1] if ! ref $_[1];
+
+ my $self = shift;
+ my $var = shift;
+ my $ARGS = shift || {};
+ my $i = 0;
+
+ ### determine the top level of this particular variable access
+ my $ref = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: begin \"$ref\"\n" if trace;
+ if (ref $ref) {
+ if (ref($ref) eq 'SCALAR') { # a scalar literal
+ $ref = $$ref;
+ } elsif (ref($ref) eq 'REF') { # operator
+ return $self->play_operator($$ref) if ${ $ref }->[0] eq '..';
+ $ref = $self->play_operator($$ref);
+ } else { # a named variable access (ie via $name.foo)
+ $ref = $self->get_variable($ref);
+ if (defined $ref) {
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+ } elsif (defined $ref) {
+ if ($ARGS->{'is_namespace_during_compile'}) {
+ $ref = $self->{'NAMESPACE'}->{$ref};
+ } else {
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the rurned thing was a code
+ if (UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? @{ $self->vivify_args($args) } : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### descend one chained level
+ last if $i >= $#$var;
+ my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
+ my $name = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: nested \"$name\"\n" if trace;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ if (ref($name) eq 'ARRAY') {
+ $name = $self->get_variable($name);
+ if (! defined($name) || $name =~ $QR_PRIVATE || $name =~ /^\./) {
+ $ref = undef;
+ last;
+ }
+ } else {
+ die "Shouldn't get a ". ref($name) ." during a vivify on chain";
+ }
+ }
+ if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ());
-__END__
+ } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || $self->list_filters->{$name}) { # filter defined in Template::Filters
-=head1 NAME
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
-CGI::Ex::Template - Beginning interface to Templating systems - for they are many
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ());
+ if (! $sub && $err) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$var->[$i - 5] || ''}) {
+ $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
-=head1 SYNOPSIS
+ } else {
- None yet.
+ ### method calls on objects
+ if ($was_dot_call && UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ my $class = ref $ref;
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
-=head1 DESCRIPTION
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ } elsif ($ARGS->{'is_namespace_during_compile'}) {
+ return $var; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
-=head1 AUTHORS
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ }
+ }
+ }
-Paul Seamons <perlspam at seamons dot com>
+ } # end of while
-=cut
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($self->{'_debug_undef'}) {
+ my $chunk = $var->[$i - 2];
+ $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY';
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($var);
+ }
+ }
+
+ return $ref;
+}
+
+sub set_variable {
+ my ($self, $var, $val, $ARGS) = @_;
+ $ARGS ||= {};
+ my $i = 0;
+
+ ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
+ $var = [$var, 0] if ! ref $var;
+
+ ### determine the top level of this particular variable access
+ my $ref = $var->[$i++];
+ my $args = $var->[$i++];
+ if (ref $ref) {
+ if (ref($ref) eq 'ARRAY') { # named access (ie via $name.foo)
+ $ref = $self->get_variable($ref);
+ if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
+ if ($#$var <= $i) {
+ $self->{'_vars'}->{$ref} = $val;
+ return;
+ } else {
+ $ref = $self->{'_vars'}->{$ref} ||= {};
+ }
+ } else {
+ return;
+ }
+ } else { # all other types can't be set
+ return;
+ }
+ } elsif (defined $ref) {
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ if ($#$var <= $i) {
+ $self->{'_vars'}->{$ref} = $val;
+ return;
+ } else {
+ $ref = $self->{'_vars'}->{$ref} ||= {};
+ }
+ }
+
+ ### let the top level thing be a code block
+ if (UNIVERSAL::isa($ref, 'CODE')) {
+ return;
+ }
+
+ ### vivify the chained levels
+ while (defined $ref && $#$var > $i) {
+ my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
+ my $name = $var->[$i++];
+ my $args = $var->[$i++];
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ if (ref($name) eq 'ARRAY') {
+ $name = $self->get_variable($name);
+ if (! defined($name) || $name =~ /^[_.]/) {
+ $ref = undef;
+ next;
+ }
+ } else {
+ die "Shouldn't get a ".ref($name)." during a vivify on chain";
+ }
+ }
+ if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ return;
+ }
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my $lvalueish;
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ if ($i >= $#$var) {
+ $lvalueish = 1;
+ push @args, $val;
+ }
+ my @results = eval { $ref->$name(@args) };
+ if (! $@) {
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ }
+ return if $lvalueish;
+ next;
+ }
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ # fall on down to "normal" accessors
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($#$var <= $i) {
+ $ref->{$name} = $val;
+ return;
+ } else {
+ $ref = $ref->{$name} ||= {};
+ next;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ if ($#$var <= $i) {
+ $ref->[$name] = $val;
+ return;
+ } else {
+ $ref = $ref->[$name] ||= {};
+ next;
+ }
+ } else {
+ return;
+ }
+
+ ### scalar access
+ } elsif (! ref($ref) && defined($ref)) {
+ return;
+ }
+
+ ### check at each point if the returned thing was a code
+ if (defined($ref) && UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? @{ $self->vivify_args($args) } : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ return;
+ }
+ }
+
+ }
+
+ return $ref;
+}
+
+sub vivify_args {
+ my $self = shift;
+ my $vars = shift;
+ return [map {$self->get_variable($_)} @$vars];
+}
+
+###----------------------------------------------------------------###
+
+sub play_operator {
+ my $self = shift;
+ my $tree = shift;
+
+ if ($OP_DISPATCH->{$tree->[0]}) {
+ my @args = map { $self->get_variable($tree->[$_]) } 1 .. $#$tree;
+ local $^W;
+ return $OP_DISPATCH->{$tree->[0]}->(@args);
+ }
+
+ my $op = $tree->[0];
+
+ ### do custom and short-circuitable operators
+ if ($op eq '=') {
+ my $val = $self->get_variable($tree->[2]);
+ $self->set_variable($tree->[1], $val);
+ return $val;
+
+ } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
+ return $self->get_variable($tree->[1]) || $self->get_variable($tree->[2]) || '';
+
+ } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
+ my $var = $self->get_variable($tree->[1]) && $self->get_variable($tree->[2]);
+ return $var ? $var : 0;
+
+ } elsif ($op eq '?') {
+ local $^W;
+ return $self->get_variable($tree->[1]) ? $self->get_variable($tree->[2]) : $self->get_variable($tree->[3]);
+ }
+
+ $self->throw('operator', "Un-implemented operation $op");
+}
+
+###----------------------------------------------------------------###
+
+sub parse_BLOCK {
+ my ($self, $tag_ref, $node) = @_;
+
+ my $block_name = '';
+ if ($$tag_ref =~ s{ ^ (\w+ (?: :\w+)*) \s* (?! [\.\|]) }{}x
+ || $$tag_ref =~ s{ ^ '(|.*?[^\\])' \s* (?! [\.\|]) }{}x
+ || $$tag_ref =~ s{ ^ "(|.*?[^\\])" \s* (?! [\.\|]) }{}x
+ ) {
+ $block_name = $1;
+ ### allow for nested blocks to have nested names
+ my @names = map {$_->[3]} grep {$_->[0] eq 'BLOCK'} @{ $self->{'_state'} };
+ $block_name = join("/", @names, $block_name) if scalar @names;
+ }
+
+ return $block_name;
+}
+
+sub play_BLOCK {
+ my ($self, $block_name, $node, $out_ref) = @_;
+
+ ### store a named reference - but do nothing until something processes it
+ $self->{'BLOCKS'}->{$block_name} = {
+ _tree => $node->[4],
+ name => $self->{'_vars'}->{'component'}->{'name'} .'/'. $block_name,
+ };
+
+ return;
+}
+
+sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }
+
+sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }
+
+sub parse_CASE {
+ my ($self, $tag_ref) = @_;
+ return if $$tag_ref =~ s{ ^ DEFAULT \s* }{}x;
+ return $self->parse_variable($tag_ref);
+}
+
+sub parse_CATCH {
+ my ($self, $tag_ref) = @_;
+ return $self->parse_variable($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
+}
+
+sub play_control {
+ my ($self, $undef, $node) = @_;
+ $self->throw(lc($node->[0]), 'Control exception', $node);
+}
+
+sub play_CLEAR {
+ my ($self, $undef, $node, $out_ref) = @_;
+ $$out_ref = '';
+}
+
+sub parse_DEBUG {
+ my ($self, $tag_ref) = @_;
+ $$tag_ref =~ s{ ^ (on | off | format) \s* }{}xi || $self->throw('parse', "Unknown DEBUG option");
+ my $ret = [lc($1)];
+ if ($ret->[0] eq 'format') {
+ $$tag_ref =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* }{}xs || $self->throw('parse', "Missing format string");
+ $ret->[1] = $2;
+ }
+ return $ret;
+}
+
+sub play_DEBUG {
+ my ($self, $ref) = @_;
+ if ($ref->[0] eq 'on') {
+ delete $self->{'_debug_off'};
+ } elsif ($ref->[0] eq 'off') {
+ $self->{'_debug_off'} = 1;
+ } elsif ($ref->[0] eq 'format') {
+ $self->{'_debug_format'} = $ref->[1];
+ }
+}
+
+sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) }
+
+sub play_DEFAULT {
+ my ($self, $set) = @_;
+ foreach (@$set) {
+ my ($set, $default) = @$_;
+ next if ! defined $set;
+ my $val = $self->get_variable($set);
+ if (! $val) {
+ $default = defined($default) ? $self->get_variable($default) : '';
+ $self->set_variable($set, $default);
+ }
+ }
+ return;
+}
+
+sub parse_DUMP {
+ my ($self, $tag_ref) = @_;
+ my $ref = $self->parse_variable($tag_ref);
+ return $ref;
+}
+
+sub play_DUMP {
+ my ($self, $ident, $node) = @_;
+ require Data::Dumper;
+ my $info = $self->node_info($node);
+ my $out;
+ my $var;
+ if ($ident) {
+ $out = Data::Dumper::Dumper($self->get_variable($ident));
+ $var = $info->{'text'};
+ $var =~ s/^[+\-~=]?\s*DUMP\s+//;
+ $var =~ s/\s*[+\-~=]?$//;
+ } else {
+ my @were_never_here = (qw(template component), grep {$_ =~ $QR_PRIVATE} keys %{ $self->{'_vars'} });
+ local @{ $self->{'_vars'} }{ @were_never_here };
+ delete @{ $self->{'_vars'} }{ @were_never_here };
+ $out = Data::Dumper::Dumper($self->{'_vars'});
+ $var = 'EntireStash';
+ }
+ if ($ENV{'REQUEST_METHOD'}) {
+ $out =~ s/</</g;
+ $out = "<pre>$out</pre>";
+ $out =~ s/\$VAR1/$var/;
+ $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out";
+ } else {
+ $out =~ s/\$VAR1/$var/;
+ }
+
+ return $out;
+}
+
+sub parse_FILTER {
+ my ($self, $tag_ref) = @_;
+ my $name = '';
+ if ($$tag_ref =~ s{ ^ ([^\W\d]\w*) \s* = \s* }{}x) {
+ $name = $1;
+ }
+
+ my $filter = $self->parse_variable($tag_ref);
+ $filter = '' if ! defined $filter;
+
+ return [$name, $filter];
+}
+
+sub play_FILTER {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $filter) = @$ref;
+
+ return '' if ! @$filter;
+
+ $self->{'FILTERS'}->{$name} = $filter if length $name;
+
+ my $sub_tree = $node->[4];
+
+ ### play the block
+ my $out = '';
+ eval { $self->execute_tree($sub_tree, \$out) };
+ die $@ if $@ && ref($@) !~ /Template::Exception$/;
+
+ my $var = [\$out, 0, '|', @$filter]; # make a temporary var out of it
+
+
+ return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
+}
+
+sub parse_FOREACH {
+ my ($self, $tag_ref) = @_;
+ my $items = $self->parse_variable($tag_ref);
+ my $var;
+ if ($$tag_ref =~ s{ ^ (= | [Ii][Nn]\b) \s* }{}x) {
+ $var = [@$items];
+ $items = $self->parse_variable($tag_ref);
+ }
+ return [$var, $items];
+}
+
+sub play_FOREACH {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ ### get the items - make sure it is an arrayref
+ my ($var, $items) = @$ref;
+
+ $items = $self->get_variable($items);
+ return '' if ! defined $items;
+
+ if (ref($items) !~ /Iterator$/) {
+ $items = $PACKAGE_ITERATOR->new($items);
+ }
+
+ my $sub_tree = $node->[4];
+
+ local $self->{'_vars'}->{'loop'} = $items;
+
+ ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
+ if (defined $var) {
+ my ($item, $error) = $items->get_first;
+ while (! $error) {
+
+ $self->set_variable($var, $item);
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
+ if ($err->type eq 'next') {
+ ($item, $error) = $items->get_next;
+ next;
+ }
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+
+ ($item, $error) = $items->get_next;
+ }
+ die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
+ ### if the FOREACH tag doesn't set a var - then everything gets localized
+ } else {
+
+ ### localize variable access for the foreach
+ my $swap = $self->{'_vars'};
+ local $self->{'_vars'} = my $copy = {%$swap};
+
+ ### iterate use the iterator object
+ #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
+ my ($item, $error) = $items->get_first;
+ while (! $error) {
+
+ if (ref($item) eq 'HASH') {
+ @$copy{keys %$item} = values %$item;
+ }
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
+ if ($err->type eq 'next') {
+ ($item, $error) = $items->get_next;
+ next;
+ }
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+
+ ($item, $error) = $items->get_next;
+ }
+ die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
+ }
+
+ return undef;
+}
+
+sub parse_GET {
+ my ($self, $tag_ref) = @_;
+ my $ref = $self->parse_variable($tag_ref);
+ $self->throw('parse', "Missing variable name") if ! defined $ref;
+ return $ref;
+}
+
+sub play_GET {
+ my ($self, $ident, $node) = @_;
+ my $var = $self->get_variable($ident);
+ return (! defined $var) ? $self->undefined_get($ident, $node) : $var;
+}
+
+sub parse_IF {
+ my ($self, $tag_ref) = @_;
+ return $self->parse_variable($tag_ref);
+}
+
+sub play_IF {
+ my ($self, $var, $node, $out_ref) = @_;
+
+ my $val = $self->get_variable($var);
+ if ($val) {
+ my $body_ref = $node->[4] ||= [];
+ $self->execute_tree($body_ref, $out_ref);
+ return;
+ }
+
+ while ($node = $node->[5]) { # ELSE, ELSIF's
+ if ($node->[0] eq 'ELSE') {
+ my $body_ref = $node->[4] ||= [];
+ $self->execute_tree($body_ref, $out_ref);
+ return;
+ }
+ my $var = $node->[3];
+ my $val = $self->get_variable($var);
+ if ($val) {
+ my $body_ref = $node->[4] ||= [];
+ $self->execute_tree($body_ref, $out_ref);
+ return;
+ }
+ }
+ return;
+}
+
+sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
+
+sub play_INCLUDE {
+ my ($self, $tag_ref, $node, $out_ref) = @_;
+
+ ### localize the swap
+ my $swap = $self->{'_vars'};
+ local $self->{'_vars'} = {%$swap};
+
+ ### localize the blocks
+ my $blocks = $self->{'BLOCKS'};
+ local $self->{'BLOCKS'} = {%$blocks};
+
+ my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $tag_ref, $node, $out_ref);
+
+ return $str;
+}
+
+sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
+
+sub play_INSERT {
+ my ($self, $var, $node, $out_ref) = @_;
+ my ($names, $args) = @$var;
+
+ foreach my $name (@$names) {
+ my $filename = $self->get_variable($name);
+ $$out_ref .= $self->_insert($filename);
+ }
+
+ return;
+}
+
+sub parse_MACRO {
+ my ($self, $tag_ref, $node) = @_;
+ my $copy = $$tag_ref;
+
+ my $name = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo});
+ $self->throw('parse', "Missing macro name") if ! defined $name;
+ if (! ref $name) {
+ $name = [ $name, 0 ];
+ }
+
+ my $args;
+ if ($copy =~ s{ ^ \( \s* }{}x) {
+ $args = $self->parse_args(\$copy, {positional_only => 1});
+ $copy =~ s { ^ \) \s* }{}x || $self->throw('parse.missing', "Missing close ')'");
+ }
+
+ $node->[6] = 1; # set a flag to keep parsing
+ $$tag_ref = $copy;
+ return [$name, $args];
+}
+
+sub play_MACRO {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $args) = @$ref;
+
+ ### get the sub tree
+ my $sub_tree = $node->[4];
+ if (! $sub_tree || ! $sub_tree->[0]) {
+ $self->set_variable($name, undef);
+ return;
+ } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
+ $sub_tree = $sub_tree->[0]->[4];
+ }
+
+ my $self_copy = $self->weak_copy;
+
+ ### install a closure in the stash that will handle the macro
+ $self->set_variable($name, sub {
+ ### macros localize
+ my $copy = $self_copy->{'_vars'};
+ local $self_copy->{'_vars'}= {%$copy};
+
+ ### set arguments
+ my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
+ my @positional = @_;
+ foreach my $var (@$args) {
+ $self_copy->set_variable($var, shift(@positional));
+ }
+ foreach my $name (sort keys %$named) {
+ $self_copy->set_variable([$name, 0], $named->{$name});
+ }
+
+ ### finally - run the sub tree
+ my $out = '';
+ $self_copy->execute_tree($sub_tree, \$out);
+ return $out;
+ });
+
+ return;
+}
+
+sub play_METADEF {
+ my ($self, $hash) = @_;
+ my $ref;
+ if ($self->{'_top_level'}) {
+ $ref = $self->{'_vars'}->{'template'} ||= {};
+ } else {
+ $ref = $self->{'_vars'}->{'component'} ||= {};
+ }
+ foreach my $key (keys %$hash) {
+ next if $key eq 'name' || $key eq 'modtime';
+ $ref->{$key} = $hash->{$key};
+ }
+ return;
+}
+
+sub parse_PERL { shift->{'_in_perl'} = 1; return }
+
+sub play_PERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $perl = $node->[4] || return;
+ my $out = '';
+ $self->execute_tree($perl, \$out);
+ $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ ### setup a fake handle
+ local *PERLOUT;
+ tie *PERLOUT, $CGI::Ex::Template::PACKAGE_PERL_HANDLE, $out_ref;
+ my $old_fh = select PERLOUT;
+
+ eval $out;
+ $err = $@;
+
+ ### put the handle back
+ select $old_fh;
+
+ };
+ $err ||= $@;
+
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub parse_PROCESS {
+ my ($self, $tag_ref) = @_;
+ my $info = [[], []];
+ while (defined(my $filename = $self->parse_variable($tag_ref, {
+ auto_quote => qr{ ^ ($QR_FILENAME | \w+ (?: :\w+)* ) $QR_AQ_SPACE }xo,
+ }))) {
+ push @{$info->[0]}, $filename;
+ last if $$tag_ref !~ s{ ^ \+ \s* }{}x;
+ }
+
+ ### allow for post process variables
+ while (length $$tag_ref) {
+ last if $$tag_ref =~ / ^ (\w+) (?: ;|$|\s)/x && $DIRECTIVES->{$1}; ### looks like a directive - we are done
+
+ my $var = $self->parse_variable($tag_ref);
+ last if ! defined $var;
+ if ($$tag_ref !~ s{ ^ = >? \s* }{}x) {
+ $self->throw('parse.missing.equals', 'Missing equals while parsing args');
+ }
+
+ my $val = $self->parse_variable($tag_ref);
+ push @{$info->[1]}, [$var, $val];
+ $$tag_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox if $val;
+ }
+
+ return $info;
+}
+
+sub play_PROCESS {
+ my ($self, $info, $node, $out_ref) = @_;
+
+ my ($files, $args) = @$info;
+
+ ### set passed args
+ foreach (@$args) {
+ my ($key, $val) = @$_;
+ $val = $self->get_variable($val);
+ if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
+ foreach my $key (keys %$val) {
+ $self->set_variable([$key,0], $val->{$key});
+ }
+ next;
+ }
+ $self->set_variable($key, $val);
+ }
+
+ ### iterate on any passed block or filename
+ foreach my $ref (@$files) {
+ next if ! defined $ref;
+ my $filename = $self->get_variable($ref);
+ my $out = ''; # have temp item to allow clear to correctly clear
+
+ ### normal blocks or filenames
+ if (! ref $filename) {
+ eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash
+
+ ### allow for $template which is used in some odd instances
+ } else {
+ $self->throw('process', "Unable to process document $filename") if $ref->[0] ne 'template';
+ $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
+ local $self->{'_process_dollar_template'} = 1;
+ local $self->{'_vars'}->{'component'} = my $doc = $filename;
+ return if ! $doc->{'_tree'};
+
+ ### execute and trim
+ eval { $self->execute_tree($doc->{'_tree'}, \$out) };
+ if ($self->{'TRIM'}) {
+ $out =~ s{ \s+ $ }{}x;
+ $out =~ s{ ^ \s+ }{}x;
+ }
+
+ ### handle exceptions
+ if (my $err = $@) {
+ $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
+ $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
+ }
+
+ }
+
+ ### append any output
+ $$out_ref .= $out;
+ if (my $err = $@) {
+ die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
+ }
+ }
+
+ return;
+}
+
+sub play_RAWPERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $tree = $node->[4] || return;
+ my $perl = '';
+ $self->execute_tree($tree, \$perl);
+ $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ my $output = '';
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ eval $perl;
+ $err = $@;
+ };
+ $err ||= $@;
+
+ $$out_ref .= $output;
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub parse_SET {
+ my ($self, $tag_ref, $node, $initial_var) = @_;
+ my @SET;
+ my $copy = $$tag_ref;
+ my $func;
+ while (length $$tag_ref) {
+ my $set;
+ my $get_val;
+ my $val;
+ if ($initial_var) {
+ $set = $initial_var;
+ undef $initial_var;
+ $get_val = 1;
+ } else {
+ $set = $self->parse_variable($tag_ref);
+ last if ! defined $set;
+ $get_val = $$tag_ref =~ s{ ^ = >? \s* }{}x;
+ }
+ if (! $get_val) { # no next val
+ $val = undef;
+ } elsif ($$tag_ref =~ $QR_DIRECTIVE # find a word
+ && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing
+ $node->[6] = 1; # set a flag to keep parsing
+ $val = $node->[4] ||= []; # setup storage
+ push @SET, [$set, $val];
+ last;
+ } else { # get a normal variable
+ $val = $self->parse_variable($tag_ref);
+ }
+ push @SET, [$set, $val];
+ }
+ return \@SET;
+}
+
+sub play_SET {
+ my ($self, $set, $node) = @_;
+ foreach (@$set) {
+ my ($set, $val) = @$_;
+ if (! defined $val) { # not defined
+ $val = '';
+ } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
+ my $sub_tree = $node->[4];
+ $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
+ $val = '';
+ $self->execute_tree($sub_tree, \$val);
+ } else { # normal var
+ $val = $self->get_variable($val);
+ }
+
+ $self->set_variable($set, $val);
+ }
+ return;
+}
+
+sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) }
+
+sub play_SWITCH {
+ my ($self, $var, $node, $out_ref) = @_;
+
+ my $val = $self->get_variable($var);
+ $val = '' if ! defined $val;
+ ### $node->[4] is thrown away
+
+ my $default;
+ while ($node = $node->[5]) { # CASES
+ my $var = $node->[3];
+ if (! defined $var) {
+ $default = $node->[4];
+ next;
+ }
+
+ my $val2 = $self->get_variable($var);
+ $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY');
+ for my $test (@$val2) { # find matching values
+ next if ! defined $val && defined $test;
+ next if defined $val && ! defined $test;
+ if ($val ne $test) { # check string-wise first - then numerical
+ next if $val !~ /^ -? (?: \d*\.\d+ | \d+) $/x;
+ next if $test !~ /^ -? (?: \d*\.\d+ | \d+) $/x;
+ next if $val != $test;
+ }
+
+ my $body_ref = $node->[4] ||= [];
+ $self->execute_tree($body_ref, $out_ref);
+ return;
+ }
+ }
+
+ if ($default) {
+ $self->execute_tree($default, $out_ref);
+ }
+
+ return;
+}
+
+sub parse_THROW {
+ my ($self, $tag_ref, $node) = @_;
+ my $name = $self->parse_variable($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
+ $self->throw('parse.missing', "Missing name in THROW", $node) if ! $name;
+ my $args = $self->parse_args($tag_ref);
+ return [$name, $args];
+}
+
+sub play_THROW {
+ my ($self, $ref, $node) = @_;
+ my ($name, $args) = @$ref;
+ $name = $self->get_variable($name);
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ $self->throw($name, \@args, $node);
+}
+
+sub play_TRY {
+ my ($self, $foo, $node, $out_ref) = @_;
+ my $out = '';
+
+ my $body_ref = $node->[4];
+ eval { $self->execute_tree($body_ref, \$out) };
+ my $err = $@;
+
+ if (! $node->[5]) { # no catch or final
+ if (! $err) { # no final block and no error
+ $$out_ref .= $out;
+ return;
+ }
+ $self->throw('parse.missing', "Missing CATCH block", $node);
+ }
+ if ($err) {
+ $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
+ if ($err->type =~ /stop|return/) {
+ $$out_ref .= $out;
+ die $err;
+ }
+ }
+
+ ### loop through the nested catch and final blocks
+ my $catch_body_ref;
+ my $last_found;
+ my $type = $err ? $err->type : '';
+ my $final;
+ while ($node = $node->[5]) { # CATCH
+ if ($node->[0] eq 'FINAL') {
+ $final = $node->[4];
+ next;
+ }
+ next if ! $err;
+ my $name = $self->get_variable($node->[3]);
+ $name = '' if ! defined $name || lc($name) eq 'default';
+ if ($type =~ / ^ \Q$name\E \b /x
+ && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
+ $catch_body_ref = $node->[4] || [];
+ $last_found = $name;
+ }
+ }
+
+ ### play the best catch block
+ if ($err) {
+ if (! $catch_body_ref) {
+ $$out_ref .= $out;
+ die $err;
+ }
+ local $self->{'_vars'}->{'error'} = $err;
+ local $self->{'_vars'}->{'e'} = $err;
+ eval { $self->execute_tree($catch_body_ref, \$out) };
+ if (my $err = $@) {
+ $$out_ref .= $out;
+ die $err;
+ }
+ }
+
+ ### the final block
+ $self->execute_tree($final, \$out) if $final;
+
+ $$out_ref .= $out;
+
+ return;
+}
+
+sub parse_UNLESS {
+ my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
+ return [ \ [ '!', $ref ], 0 ];
+}
+
+sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) }
+
+sub parse_USE {
+ my ($self, $tag_ref) = @_;
+
+ my $var;
+ my $copy = $$tag_ref;
+ if (defined(my $_var = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
+ && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
+ $var = $_var;
+ $$tag_ref = $copy;
+ }
+
+ $copy = $$tag_ref;
+ my $module = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo});
+ $self->throw('parse', "Missing plugin name while parsing $$tag_ref") if ! defined $module;
+ $module =~ s/\./::/g;
+
+ my $args;
+ my $open = $copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox;
+ $args = $self->parse_args(\$copy);
+
+ if ($open) {
+ $copy =~ s { ^ \) \s* $QR_COMMENTS }{}ox || $self->throw('parse.missing', "Missing close ')'");
+ }
+
+ $$tag_ref = $copy;
+ return [$var, $module, $args];
+}
+
+sub play_USE {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($var, $module, $args) = @$ref;
+
+ ### get the stash storage location - default to the module
+ $var = $module if ! defined $var;
+ my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
+ pop @var; # remove the trailing '.'
+
+ ### look for a plugin_base
+ my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
+ my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+ : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+ : "${base}::${module}";
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+
+ ### try and load the module - fall back to bare module if allowed
+ my $obj;
+ if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
+ my $shape = $package->load;
+ my $context = $self->context;
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ $obj = $shape->new($context, @args);
+ } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+ $obj = $PACKAGE_ITERATOR->new($args ? $self->get_variable($args->[0]) : []);
+ } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+ foreach my $package (@packages) {
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+ eval {require $require} || next;
+ my $shape = $package->load;
+ my $context = $self->context;
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ $obj = $shape->new($context, @args);
+ }
+ } elsif ($self->{'LOAD_PERL'}) {
+ my $require = "$module.pm";
+ $require =~ s|::|/|g;
+ if (eval {require $require}) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ $obj = $module->new(@args);
+ }
+ }
+ if (! defined $obj) {
+ my $err = "$module: plugin not found";
+ $self->throw('plugin', $err);
+ }
+
+ ### all good
+ $self->set_variable(\@var, $obj);
+
+ return;
+}
+
+sub play_WHILE {
+ my ($self, $var, $node, $out_ref) = @_;
+ return '' if ! defined $var;
+
+ my $sub_tree = $node->[4];
+
+ ### iterate use the iterator object
+ my $count = $WHILE_MAX;
+ while (--$count > 0) {
+
+ $self->get_variable($var) || last;
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
+ next if $err->type =~ /next/;
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+ }
+ die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count;
+
+ return undef;
+}
+
+sub parse_WRAPPER { $DIRECTIVES->{'INCLUDE'}->[0]->(@_) }
+
+sub play_WRAPPER {
+ my ($self, $var, $node, $out_ref) = @_;
+ my $sub_tree = $node->[4] || return;
+
+ my ($names, $args) = @$var;
+
+ my $out = '';
+ $self->execute_tree($sub_tree, \$out);
+
+ foreach my $name (reverse @$names) {
+ local $self->{'_vars'}->{'content'} = $out;
+ $out = '';
+ $DIRECTIVES->{'INCLUDE'}->[1]->($self, [[$name], $args], $node, \$out);
+ }
+
+ $$out_ref .= $out;
+ return;
+}
+
+###----------------------------------------------------------------###
+
+sub _vars {
+ my $self = shift;
+ $self->{'_vars'} = shift if $#_ == 0;
+ return $self->{'_vars'} ||= {};
+}
+
+sub include_filename {
+ my ($self, $file) = @_;
+ if ($file =~ m|^/|) {
+ $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'};
+ return $file if -e $file;
+ } elsif ($file =~ m{(^|/)\.\./}) {
+ $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'};
+ return $file if -e $file;
+ }
+
+ my $paths = $self->{'INCLUDE_PATHS'} ||= do {
+ # TT does this everytime a file is looked up - we are going to do it just in time - the first time
+ my $paths = $self->{'INCLUDE_PATH'} || $self->throw('file', "INCLUDE_PATH not set");
+ $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE');
+ $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY');
+ $paths; # return of the do
+ };
+ foreach my $path (@$paths) {
+ return "$path/$file" if -e "$path/$file";
+ }
+
+ $self->throw('file', "$file: not found");
+}
+
+sub split_paths {
+ my ($self, $path) = @_;
+ return $path if ref $path;
+ my $delim = $self->{'DELIMITER'} || ':';
+ $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|;
+ return [split $delim, $path];
+}
+
+sub _insert {
+ my ($self, $file) = @_;
+ return $self->slurp($self->include_filename($file));
+}
+
+sub slurp {
+ my ($self, $file) = @_;
+ local *FH;
+ open(FH, "<$file") || $self->throw('file', "$file couldn't be opened: $!");
+ read FH, my $txt, -s $file;
+ close FH;
+ return $txt;
+}
+
+sub process_simple {
+ my $self = shift;
+ my $in = shift || die "Missing input";
+ my $swap = shift || die "Missing variable hash";
+ my $out = shift || die "Missing output string ref";
+
+ eval {
+ delete $self->{'_debug_off'};
+ delete $self->{'_debug_format'};
+ local $self->{'_start_top_level'} = 1;
+ $self->_process($in, $swap, $out);
+ };
+ if (my $err = $@) {
+ if ($err->type !~ /stop|return|next|last|break/) {
+ $self->{'error'} = $err;
+ return;
+ }
+ }
+ return 1;
+}
+
+sub process {
+ my ($self, $in, $swap, $out, @ARGS) = @_;
+ delete $self->{'error'};
+
+ my $args;
+ $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
+ $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests
+
+ ### get the content
+ my $content;
+ if (ref $in) {
+ if (UNIVERSAL::isa($in, 'SCALAR')) { # reference to a string
+ $content = $in;
+ } elsif (UNIVERSAL::isa($in, 'CODE')) {
+ $content = $in->();
+ $content = \$content;
+ } else { # should be a file handle
+ local $/ = undef;
+ $content = <$in>;
+ $content = \$content;
+ }
+ } else {
+ ### should be a filename
+ $content = $in;
+ }
+
+
+ ### prepare block localization
+ my $blocks = $self->{'BLOCKS'} ||= {};
+
+
+ ### do the swap
+ my $output = '';
+ eval {
+
+ ### localize the stash
+ $swap ||= {};
+ my $var1 = $self->{'_vars'} ||= {};
+ my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
+ $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
+ my $copy = {%$var2, %$var1, %$swap};
+ local $copy->{'template'};
+
+ local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore
+
+ delete $self->{'_debug_off'};
+ delete $self->{'_debug_format'};
+
+ ### handle pre process items that go before every document
+ if ($self->{'PRE_PROCESS'}) {
+ foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
+ my $out = '';
+ $self->_process($name, $copy, \$out);
+ $output = $out . $output;
+ }
+ }
+
+ ### handle the process config - which loads a template in place of the real one
+ if (exists $self->{'PROCESS'}) {
+ ### load the meta data for the top document
+ my $doc = $self->load_parsed_tree($content) || {};
+ my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'METADEF')
+ ? $doc->{'_tree'}->[0]->[3] : {};
+
+ $copy->{'template'} = $doc;
+ @{ $doc }{keys %$meta} = values %$meta;
+
+ ### process any other templates
+ foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
+ next if ! length $name;
+ $self->_process($name, $copy, \$output);
+ }
+
+ ### handle "normal" content
+ } else {
+ local $self->{'_start_top_level'} = 1;
+ $self->_process($content, $copy, \$output);
+ }
+
+
+ ### handle post process items that go after every document
+ if ($self->{'POST_PROCESS'}) {
+ foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
+ $self->_process($name, $copy, \$output);
+ }
+ }
+
+ };
+ if (my $err = $@) {
+ $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
+ if ($err->type !~ /stop|return|next|last|break/) {
+ $self->{'error'} = $err;
+ return;
+ }
+ }
+
+
+
+ ### clear blocks as asked (AUTO_RESET) defaults to on
+ $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};
+
+ ### send the content back out
+ $out ||= $self->{'OUTPUT'};
+ if (ref $out) {
+ if (UNIVERSAL::isa($out, 'CODE')) {
+ $out->($output);
+ } elsif (UNIVERSAL::can($out, 'print')) {
+ $out->print($output);
+ } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string
+ $$out = $output;
+ } elsif (UNIVERSAL::isa($out, 'ARRAY')) {
+ push @$out, $output;
+ } else { # should be a file handle
+ print $out $output;
+ }
+ } elsif ($out) { # should be a filename
+ my $file;
+ if ($out =~ m|^/|) {
+ if (! $self->{'ABSOLUTE'}) {
+ $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled");
+ } else {
+ $file = $out;
+ }
+ } elsif ($out =~ m|^\.\.?/|) {
+ if (! $self->{'RELATIVE'}) {
+ $self->{'error'} = $self->throw('file', "RELATIVE paths disabled");
+ } else {
+ $file = $out;
+ }
+ } else {
+ if (! $self->{'OUTPUT_PATH'}) {
+ $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set");
+ } else {
+ $file = $self->{'OUTPUT_PATH'} . '/' . $out;
+ }
+ }
+ if ($file) {
+ local *FH;
+ if (open FH, ">$file") {
+ if (my $bm = $args->{'binmode'}) {
+ if (+$bm == 1) { binmode FH }
+ else { binmode FH, $bm }
+ }
+ print FH $output;
+ close FH;
+ } else {
+ $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
+ }
+ }
+ } else {
+ print $output;
+ }
+
+ return if $self->{'error'};
+ return 1;
+}
+
+sub error { shift->{'error'} }
+
+sub DEBUG {
+ my $self = shift;
+ print STDERR "DEBUG: ", @_;
+}
+
+###----------------------------------------------------------------###
+
+sub exception {
+ my ($self, $type, $info, $node) = @_;
+ return $type if ref($type) =~ /Template::Exception$/;
+ if (ref($info) eq 'ARRAY') {
+ my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {};
+ if (@$info >= 2 || scalar keys %$hash) {
+ my $i = 0;
+ $hash->{$_} = $info->[$_] for 0 .. $#$info;
+ $hash->{'args'} = $info;
+ $info = $hash;
+ } elsif (@$info == 1) {
+ $info = $info->[0];
+ } else {
+ $info = $type;
+ $type = 'undef';
+ }
+ }
+ return $PACKAGE_EXCEPTION->new($type, $info, $node);
+}
+
+sub throw { die shift->exception(@_) }
+
+sub context {
+ my $self = shift;
+ return bless {_template => $self}, $PACKAGE_CONTEXT; # a fake context
+}
+
+sub undefined_get {
+ my ($self, $ident, $node) = @_;
+ return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'};
+ return '';
+}
+
+sub undefined_any {
+ my ($self, $ident) = @_;
+ return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'};
+ return;
+}
+
+sub list_filters {
+ my $self = shift;
+ return $self->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
+}
+
+sub list_plugins {
+ my $self = shift;
+ my $args = shift || {};
+ my $base = $args->{'base'} || '';
+
+ return $self->{'_plugins'}->{$base} ||= do {
+ my @plugins;
+
+ $base =~ s|::|/|g;
+ my @dirs = grep {-d $_} map {"$_/$base"} @INC;
+
+ foreach my $dir (@dirs) {
+ require File::Find;
+ File::Find::find(sub {
+ my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
+ $mod =~ s|/|::|g;
+ push @plugins, $mod;
+ }, $dir);
+ }
+
+ \@plugins; # return of the do
+ };
+}
+
+### get a copy of self without circular refs for use in closures
+sub weak_copy {
+ my $self = shift;
+ my $self_copy;
+ if (eval { require Scalar::Util }
+ && defined &Scalar::Util::weaken) {
+ $self_copy = $self;
+ Scalar::Util::weaken($self_copy);
+ } else {
+ $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8)
+ }
+ return $self_copy;
+}
+
+sub debug_node {
+ my ($self, $node) = @_;
+ my $info = $self->node_info($node);
+ my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n";
+ $format =~ s{\$(file|line|text)}{$info->{$1}}g;
+ return $format;
+}
+
+sub node_info {
+ my ($self, $node) = @_;
+ my $doc = $self->{'_vars'}->{'component'};
+ my $i = $node->[1];
+ my $j = $node->[2] || return ''; # METADEF can be 0
+ $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
+ my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
+ $s =~ s/^\s+//;
+ $s =~ s/\s+$//;
+ return {
+ file => $doc->{'name'},
+ line => $self->get_line_number_by_index($doc, $i),
+ text => $s,
+ };
+}
+
+sub get_line_number_by_index {
+ my ($self, $doc, $index) = @_;
+ ### get the line offsets for the doc
+ my $lines = $doc->{'line_offsets'} ||= do {
+ $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
+ my $i = 0;
+ my @lines = (0);
+ while (1) {
+ $i = index(${ $doc->{'_content'} }, "\n", $i) + 1;
+ last if $i == 0;
+ push @lines, $i;
+ }
+ \@lines;
+ };
+ ### binary search them (this is fast even on big docs)
+ return $#$lines + 1 if $index > $lines->[-1];
+ my ($i, $j) = (0, $#$lines);
+ while (1) {
+ return $i + 1 if abs($i - $j) <= 1;
+ my $k = int(($i + $j) / 2);
+ $j = $k if $lines->[$k] >= $index;
+ $i = $k if $lines->[$k] <= $index;
+ }
+}
+
+###----------------------------------------------------------------###
+### long virtual methods or filters
+### many of these vmethods have used code from Template/Stash.pm to
+### assure conformance with the TT spec.
+
+sub define_vmethod {
+ my ($self, $type, $name, $sub) = @_;
+ if ( $type =~ /scalar|item/i) { $SCALAR_OPS->{$name} = $sub }
+ elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub }
+ elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub }
+ elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub }
+ else {
+ die "Invalid type vmethod type $type";
+ }
+ return 1;
+}
+
+sub vmethod_chunk {
+ my $str = shift;
+ my $size = shift || 1;
+ my @list;
+ if ($size < 0) { # chunk from the opposite end
+ $str = reverse $str;
+ $size = -$size;
+ unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
+ } else {
+ push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
+ }
+ return \@list;
+}
+
+sub vmethod_indent {
+ my $str = shift; $str = '' if ! defined $str;
+ my $pre = shift; $pre = 4 if ! defined $pre;
+ $pre = ' ' x $pre if $pre =~ /^\d+$/;
+ $str =~ s/^/$pre/mg;
+ return $str;
+}
+
+sub vmethod_format {
+ my $str = shift; $str = '' if ! defined $str;
+ my $pat = shift; $pat = '%s' if ! defined $pat;
+ return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+}
+
+sub vmethod_match {
+ my ($str, $pat, $global) = @_;
+ return [] if ! defined $str || ! defined $pat;
+ my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
+ return (@res >= 2) ? \@res : (@res == 1) ? $res[0] : '';
+}
+
+sub vmethod_nsort {
+ my ($list, $field) = @_;
+ return defined($field)
+ ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
+ : UNIVERSAL::can($_, $field) ? $_->$field()
+ : $_)]} @$list ]
+ : [sort {$a <=> $b} @$list];
+}
+
+sub vmethod_repeat {
+ my ($str, $n, $join) = @_;
+ return if ! length $str;
+ $n = 1 if ! defined($n) || ! length $n;
+ $join = '' if ! defined $join;
+ return join $join, ($str) x $n;
+}
+
+### This method is a combination of my submissions along
+### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
+sub vmethod_replace {
+ my ($text, $pattern, $replace, $global) = @_;
+ $text = '' unless defined $text;
+ $pattern = '' unless defined $pattern;
+ $replace = '' unless defined $replace;
+ $global = 1 unless defined $global;
+ my $expand = sub {
+ my ($chunk, $start, $end) = @_;
+ $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
+ $1 ? $1
+ : ($2 > $#$start || $2 == 0) ? ''
+ : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
+ }exg;
+ $chunk;
+ };
+ if ($global) {
+ $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
+ } else {
+ $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
+ }
+ return $text;
+}
+
+sub vmethod_sort {
+ my ($list, $field) = @_;
+ return defined($field)
+ ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
+ : UNIVERSAL::can($_, $field) ? $_->$field()
+ : $_)]} @$list ]
+ : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
+}
+
+sub vmethod_splice {
+ my ($ref, $i, $len, @replace) = @_;
+ @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
+ if (defined $len) {
+ return [splice @$ref, $i || 0, $len, @replace];
+ } else {
+ return [splice @$ref, $i || 0];
+ }
+}
+
+sub vmethod_split {
+ my ($str, $pat, @args) = @_;
+ $str = '' if ! defined $str;
+ return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
+}
+
+sub vmethod_uri {
+ my $str = shift;
+ utf8::encode($str) if defined &utf8::encode;
+ $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
+ return $str;
+}
+
+sub filter_eval {
+ my $context = shift;
+ return sub {
+ my $text = shift;
+ return $context->process(\$text);
+ };
+}
+
+sub filter_redirect {
+ my ($context, $file, $options) = @_;
+ my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
+ $context->throw('redirect', 'Invalid filename - cannot include "/../"')
+ if $file =~ m{(^|/)\.\./};
+
+ return sub {
+ my $text = shift;
+ if (! -d $path) {
+ require File::Path;
+ File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
+ }
+ local *FH;
+ open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
+ if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
+ if (+$bm == 1) { binmode FH }
+ else { binmode FH, $bm}
+ }
+ print FH $text;
+ close FH;
+ return '';
+ };
+}
+
+###----------------------------------------------------------------###
+
+sub dump_parse {
+ my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
+ my $str = shift;
+ require Data::Dumper;
+ return Data::Dumper::Dumper($obj->parse_variable(\$str));
+}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::Exception;
+
+use overload
+ '""' => \&as_string,
+ bool => sub { defined shift },
+ fallback => 1;
+
+sub new {
+ my ($class, $type, $info, $node, $pos, $str_ref) = @_;
+ return bless [$type, $info, $node, $pos, $str_ref], $class;
+}
+
+sub type { shift->[0] }
+
+sub info { shift->[1] }
+
+sub node {
+ my $self = shift;
+ $self->[2] = shift if $#_ == 0;
+ $self->[2];
+}
+
+sub offset { shift->[3] || 0 }
+
+sub doc {
+ my $self = shift;
+ $self->[4] = shift if $#_ == 0;
+ $self->[4];
+}
+
+sub as_string {
+ my $self = shift;
+ my $msg = $self->type .' error - '. $self->info;
+ if (my $node = $self->node) {
+# $msg .= " (In tag $node->[0] starting at char ".($node->[1] + $self->offset).")";
+ }
+ return $msg;
+}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::Iterator;
+
+sub new {
+ my ($class, $items) = @_;
+ $items = [] if ! defined $items;
+ if (UNIVERSAL::isa($items, 'HASH')) {
+ $items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ];
+ } elsif (UNIVERSAL::can($items, 'as_list')) {
+ $items = $items->as_list;
+ } elsif (! UNIVERSAL::isa($items, 'ARRAY')) {
+ $items = [$items];
+ }
+ return bless [$items, 0], $class;
+}
+
+sub get_first {
+ my $self = shift;
+ return (undef, 3) if ! @{ $self->[0] };
+ return ($self->[0]->[$self->[1] = 0], undef);
+}
+
+sub get_next {
+ my $self = shift;
+ return (undef, 3) if ++ $self->[1] > $#{ $self->[0] };
+ return ($self->items->[$self->[1]], undef);
+}
+
+sub items { shift->[0] }
+
+sub index { shift->[1] }
+
+sub max { $#{ shift->[0] } }
+
+sub size { shift->max + 1 }
+
+sub count { shift->index + 1 }
+
+sub number { shift->index + 1 }
+
+sub first { (shift->index == 0) || 0 }
+
+sub last { my $self = shift; return ($self->index == $self->max) || 0 }
+
+sub prev {
+ my $self = shift;
+ return undef if $self->index <= 0;
+ return $self->items->[$self->index - 1];
+}
+
+sub next {
+ my $self = shift;
+ return undef if $self->index >= $self->max;
+ return $self->items->[$self->index + 1];
+}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::_Context;
+
+use vars qw($AUTOLOAD);
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub config { shift->_template }
+
+sub stash {
+ my $self = shift;
+ return $self->{'stash'} ||= bless {_template => $self->_template}, $CGI::Ex::Template::PACKAGE_STASH;
+}
+
+sub insert { shift->_template->_insert(@_) }
+
+sub eval_perl { shift->_template->{'EVAL_PERL'} }
+
+sub process {
+ my $self = shift;
+ my $ref = shift;
+ my $vars = $self->_template->_vars;
+ my $out = '';
+ $self->_template->_process($ref, $vars, \$out);
+ return $out;
+}
+
+sub include {
+ my $self = shift;
+ my $file = shift;
+ my $args = shift || {};
+
+ $self->_template->set_variable($_, $args->{$_}) for keys %$args;
+
+ my $out = ''; # have temp item to allow clear to correctly clear
+ eval { $self->_template->_process($file, $self->{'_vars'}, \$out) };
+ if (my $err = $@) {
+ die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
+ }
+
+ return $out;
+}
+
+sub define_filter {
+ my ($self, $name, $filter, $is_dynamic) = @_;
+ $filter = [ $filter, 1 ] if $is_dynamic;
+ $self->define_vmethod('filter', $name, $filter);
+}
+
+sub filter {
+ my ($self, $name, $args, $alias) = @_;
+ my $t = $self->_template;
+
+ my $filter;
+ if (! ref $name) {
+ $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
+ $t->throw('filter', $name) if ! $filter;
+ } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
+ $filter = $name;
+ } elsif (UNIVERSAL::can($name, 'factory')) {
+ $filter = $name->factory || $t->throw($name->error);
+ } else {
+ $t->throw('undef', "$name: filter not found");
+ }
+
+ if (UNIVERSAL::isa($filter, 'ARRAY')) {
+ $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
+ } elsif ($args && @$args) {
+ my $sub = $filter;
+ $filter = sub { $sub->(shift, @$args) };
+ }
+
+ $t->{'FILTERS'}->{$alias} = $filter if $alias;
+
+ return $filter;
+}
+
+sub define_vmethod { shift->_template->define_vmethod(@_) }
+
+sub throw {
+ my ($self, $type, $info) = @_;
+
+ if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
+ die $type;
+ } elsif (defined $info) {
+ $self->_template->throw($type, $info);
+ } else {
+ $self->_template->throw('undef', $type);
+ }
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::_Stash;
+
+use vars qw($AUTOLOAD);
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub get {
+ my ($self, $var) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_variable(\$var, {no_dots => 1}) }
+ }
+ return $self->_template->get_variable($var, {no_dots => 1});
+}
+
+sub set {
+ my ($self, $var, $val) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_variable(\$var, {no_dots => 1}) }
+ }
+ $self->_template->set_variable($var, $val, {no_dots => 1});
+ return $val;
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::EvalPerlHandle;
+
+sub TIEHANDLE {
+ my ($class, $out_ref) = @_;
+ return bless [$out_ref], $class;
+}
+
+sub PRINT {
+ my $self = shift;
+ ${ $self->[0] } .= $_ for grep {defined && length} @_;
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+1;
+### See the perldoc in CGI/Ex/Template.pod
--- /dev/null
+=head1
+
+CGI::Ex::Template - Fast and lightweight TT2/3 template engine
+
+=head1 SYNOPSIS
+
+ my $t = CGI::Ex::Template->new(
+ INCLUDE_PATH => ['/path/to/templates'],
+ );
+
+ my $swap = {
+ key1 => 'val1',
+ key2 => 'val2',
+ code => sub { 42 },
+ hash => {a => 'b'},
+ };
+
+ $t->process('my/template.tt', $swap)
+ || die $t->error;
+
+ ### Anything in the Template::Toolkit SYNOPSIS would fit here also
+
+=head1 DESCRIPTION
+
+CGI::Ex::Template happened by accident (accidentally on purpose). The
+CGI::Ex::Template (CET hereafter) was originally a part of the CGI::Ex
+suite that performed simple variable interpolation. It used TT2 style
+variables in TT2 style tags "[% foo.bar %]". That was all the
+original CGI::Ex::Template did. This was fine and dandy for a couple
+of years. In winter of 2005-2006 CET was revamped to add a few
+features. One thing led to another and soon CET provided for most of
+the features of TT2 as well as some from TT3. CGI::Ex::Template is a
+full-featured implementation of the Template::Toolkit language.
+
+CGI::Ex::Template (CET hereafter) is smaller, faster, uses less memory
+and less CPU than TT2. However, it is most likely less portable, less
+extendable, and probably has many of the bugs that TT2 has already massaged
+out from years of bug reports and patches from a very active community
+and mailing list. CET does not have a vibrant community behind it. Fixes
+applied to TT2 will take longer to get into CET, should they get in at all.
+An attempt will be made to follow updates made to TT2 to keep the two
+in sync at a language level. There already has been, and it is expected that
+there will continue to be code sharing between the two projects. (Acutally
+I will try and keep applicable fixes in sync with TT).
+
+Most of the standard Template::Toolkit documentation covering directives,
+variables, configuration, plugins, filters, syntax, and vmethods should
+apply to CET just fine (This pod tries to explain everything - but there is
+too much). The section on differences between CET and TT will explain
+what too look out for.
+
+Note: A clarification on "faster". All templates are going to take
+different amounts of time to process. Different types of DIRECTIVES
+parse and play more quickly than others. The test script
+samples/benchmark/bench_template.pl was used to obtain sample numbers.
+In general the following statements are true:
+
+ If you load a new Template object each time and pass a filename, CET
+ is around 4 times faster.
+
+ If you load a new Template object and pass a string ref, CET
+ is around 3.5 times faster.
+
+ If you load a new Template object and use CACHE_EXT, CET
+ is around 1.5 times faster.
+
+ If you use a cached object with a cached in memory template,
+ then CET is 50% faster.
+
+ If you use Template::Stash::XS with a cached in memory template,
+ then CET is about as fast.
+
+ Using TT with a compiled-in-memory template is only 33
+ faster than CET with a new object compiling each time.
+
+It is pretty hard to beat the speed of XS stash with compiled in
+memory templates. Many systems don't have access to those so
+CET may make more sense. Hopefully as TT is revised, many of the CET
+speed advantages can be incorporated so that the core TT is just as
+fast or faster.
+
+So should you use CGI::Ex::Template ? Well, try it out. It may
+give you no visible improvement. Or it could.
+
+
+=head1 PUBLIC METHODS
+
+The following section lists most of the publicly available methods. Some less
+commonly used public methods are listed later in this document.
+
+=over 4
+
+=item C<new>
+
+ my $obj = CGI::Ex::Template->new({
+ INCLUDE_PATH => ['/my/path/to/content', '/my/path/to/content2'],
+ });
+
+ Arguments may be passed as a hash or as a hashref. Returns a CGI::Ex::Template object.
+
+ There are currently no errors during CGI::Ex::Template object creation.
+
+=item C<process>
+
+This is the main method call for staring processing. Any errors that results in the
+template being stopped processing will be stored and available via the ->error method.
+
+Process takes three arguments.
+
+ $t->process($in, $swap, $out)
+ || die $t->error;
+
+The $in argument can be any one of:
+
+ String containing the filename of the template to be processed. The filename should
+ be relative to INCLUDE_PATH. (See INCLUDE_PATH, ABSOLUTE, and RELATIVE configuration items).
+ In memory caching and file side caching are available for this type.
+
+ A reference to a scalar containing the contents of the template to be processed.
+
+ A coderef that will be called to return the contents of the template.
+
+ An open filehandle that will return the contents of the template when read.
+
+The $swap argument should be hashref containing key value pairs that will be
+available to variables swapped into the template. Values can be hashrefs, hashrefs
+of hashrefs and so on, arrayrefs, arrayrefs of arrayrefs and so on, coderefs, objects,
+and simple scalar values such as numbers and strings. See the section on variables.
+
+The $out argument can be any one of:
+
+ undef - meaning to print the completed template to STDOUT.
+
+ String containing a filename. The completed template will be placed in the file.
+
+ A reference to a string. The contents will be appended to the scalar reference.
+
+ A coderef. The coderef will be called with the contents as a single argument.
+
+ An object that can run the method "print". The contents will be passed as
+ a single argument to print.
+
+ An arrayref. The contents will be pushed onto the array.
+
+ An open filehandle. The contents will be printed to the open handle.
+
+Additionally - the $out argument can be configured using the OUTPUT configuration
+item.
+
+=item C<process_simple>
+
+Similar to the process method but with the following restrictions:
+
+The $in parameter is limited to a filename or a reference a string containing the contents.
+
+The $out parameter may only be a reference to a scalar string that output will be appended to.
+
+Additionally, the following configuration variables will be ignored: VARIABLES,
+PRE_DEFINE, BLOCKS, PRE_PROCESS, PROCESS, POST_PROCESS, AUTO_RESET, OUTPUT.
+
+=item C<error>
+
+Should something go wrong during a "process" command, the error that occurred can
+be retrieved via the error method.
+
+ $obj->process('somefile.html', {a => 'b'}, \$string_ref)
+ || die $obj->error;
+
+=item C<define_vmethod>
+
+This method is available for defining extra Virtual methods or filters. This method is similar
+to Template::Stash::define_vmethod.
+
+=back
+
+=head1 TODO
+
+ Add WRAPPER config item
+
+ Add ERROR config item
+
+=head1 HOW IS CGI::Ex::Template DIFFERENT
+
+CET uses the same template syntax and configuration items
+as TT2, but the internals of CET were written from scratch. In
+addition to this, the following is a list of some of the ways that
+configuration and syntax of CET different from that of TT.
+
+=over 4
+
+Numerical hash keys work [% a = {1 => 2} %]
+
+Quoted hash key interpolation is fine [% a = {"$foo" => 1} %]
+
+Multiple ranges in same constructor [% a = [1..10, 21..30] %]
+
+Constructor types can call virtual methods
+
+ [% a = [1..10].reverse %]
+
+ [% "$foo".length %]
+
+ [% 123.length %] # = 3
+
+ [% 123.4.length %] # = 5
+
+ [% -123.4.length %] # = -5 ("." binds more tightly than "-")
+
+ [% (a ~ b).length %]
+
+ [% "hi".repeat(3) %]
+
+ [% {a => b}.size %]
+
+Reserved names are less reserved
+
+ [% GET GET %] # gets the variable named "GET"
+
+ [% GET $GET %] # gets the variable who's name is stored in "GET"
+
+Filters and SCALAR_OPS are interchangeable.
+
+ [% a | length %]
+
+ [% b . lower %]
+
+Pipe "|" can be used anywhere dot "." can be and means to call
+the virtual method.
+
+ [% a = {size => "foo"} %][% a.size %] # = foo
+
+ [% a = {size => "foo"} %][% a|size %] # = 1 (size of hash)
+
+Pipe "|" and "." can be mixed.
+
+ [% "aa" | repeat(2) . length %] # = 4
+
+Whitespace is less meaningful.
+
+ [% 2-1 %] # = 1 (fails in TT)
+
+Added pow operator.
+
+ [% 2 ** 3 %] [% 2 pow 3 %] # = 8 8
+
+FOREACH variables can be nested
+
+ [% FOREACH f.b = [1..10] ; f.b ; END %]
+
+ Note that nested variables are subject to scoping issues.
+ f.b will not be reset to its value before the FOREACH.
+
+Post operative directives can be nested.
+
+ [% one IF two IF three %]
+
+ same as
+
+ [% IF three %][% IF two %][% one %][% END %][% END %]
+
+
+ [% a = [[1..3], [5..7]] %][% i FOREACH i = j FOREACH j = a %] # = 123567
+
+CATCH blocks can be empty.
+
+CET does not generate Perl code. It generates an "opcode" tree.
+
+CET uses storable for its compiled templates. If EVAL_PERL is off,
+CET will not eval_string on ANY piece of information.
+
+There is no context. CET provides a context object that mimics the
+Template::Context interface for use by some TT filters, eval perl
+blocks, and plugins.
+
+There is no stash. CET only supports the variables passed in
+VARIABLES, PRE_DEFINE, and those passed to the process method. CET
+provides a stash object that mimics the Template::Stash interface for
+use by some TT filters, eval perl blocks, and plugins.
+
+There is no provider. CET uses the load_parsed_tree method to get and
+cache templates.
+
+There is no grammar. CET has its own built in grammar system.
+
+There is no VIEW directive.
+
+There are no references. (There was in initial beta tests, but it was decided
+to remove the little used feature).
+
+The DEBUG directive only understands DEBUG_DIRS (8) and DEBUG_UNDEF (2).
+
+When debug dirs is on, directives on different lines separated by colons show the line they
+are on rather than a general line range.
+
+There is no ANYCASE configuration item. There was in initial beta tests, but it
+was dropped in favor of consistent parsing syntax.
+
+There is no V1DOLLAR configuration item. This is a TT version 1 compatibility item and
+is not available in CET.
+
+=back
+
+=head1 VARIABLES
+
+This section discusses how to use variables and expressions in the TT mini-language.
+
+A variable is the most simple construct to insert into the TT mini language. A variable
+name will look for the matching value inside CGI::Ex::Templates internal stash of variables
+which is essentially a hash reference. This stash is initially populated by either passing
+a hashref as the second argument to the process method, or by setting the "VARIABLES" or
+"PRE_DEFINE" configuration variables.
+
+ ### some sample variables
+ my %vars = (
+ one => '1.0',
+ foo => 'bar',
+ vname => 'one',
+ some_code => sub { "You passed me (".join(', ', @_).")" },
+ some_data => {
+ a => 'A',
+ bar => 3234,
+ c => [3, 1, 4, 1, 5, 9],
+ vname => 'one',
+ },
+ my_list => [20 .. 50],
+ cet => CGI::Ex::Template->new,
+ );
+
+ ### pass the variables into the CET process
+ $cet->process($template_name, \%vars)
+ || die $cet->error;
+
+ ### pass the variables during object creation (will be available to every process call)
+ my $cet = CGI::Ex::Template->new(VARIABLES => \%vars);
+
+=head1 GETTING VARIABLES
+
+Once you have variables defined, they can be used directly in the template by using their name
+in the stash. Or by using the GET directive.
+
+ [% foo %]
+ [% one %]
+ [% GET foo %]
+
+Would print when processed:
+
+ bar
+ 1.0
+ bar
+
+To access members of a hashref or an arrayref, you can chain together the names using a ".".
+
+ [% some_data.a %]
+ [% my_list.0] [% my_list.1 %]
+ [% some_data.c.2 %]
+
+Would print:
+
+ A
+ 20 21
+ 4
+
+If the value of a variable is a code reference, it will be called. You can add a set of parenthesis
+and arguments to pass arguments. Arguments are variables and can be as complex as necessary.
+
+ [% some_code %]
+ [% some_code() %]
+ [% some_code(foo) %]
+ [% some_code(one, 2, 3) %]
+
+Would print:
+
+ You passed me ().
+ You passed me ().
+ You passed me (bar).
+ You passed me (1, 2, 3).
+
+If the value of a variable is an object, methods can be called using the "." operator.
+
+ [% cet %]
+
+ [% cet.dump_parse('1 + 2').replace('\s+', ' ') %]
+
+Would print something like:
+
+ CGI::Ex::Template=HASH(0x814dc28)
+
+ $VAR1 = [ \[ '+', '1', '2' ], 0 ];
+
+Each type of data has virtual methods associated with them. Virtual methods
+allow for access to common functions. For the full list of built in virtual
+methods, please see the section titled VIRTUAL METHODS
+
+ [% foo.length %]
+ [% my_list.size %]
+ [% some_data.c.join(" | ") %]
+
+Would print:
+
+ 3
+ 31
+ 3 | 1 | 4 | 5 | 9
+
+It is also possible to "interpolate" variable names using a "$". This allows for storing
+the name of a variable inside another variable. If a variable name is a little
+more complex, it can be embedded inside of "${" and "}".
+
+ [% $vname %]
+ [% ${vname} %]
+ [% ${some_data.vname} %]
+ [% some_data.$foo %]
+ [% some_data.${foo} %]
+
+Would print:
+
+ 1.0
+ 1.0
+ 1.0
+ 3234
+ 3234
+
+=head2 SETTING VARIABLES.
+
+To define variables during processing, you can use the = operator. In most cases
+this is the same as using the SET directive.
+
+ [% a = 234 %][% a %]
+ [% SET b = "Hello" %][% b %]
+
+Would print:
+
+ 234
+ Hello
+
+It is also possible to create arrayrefs and hashrefs.
+
+ [% a = [1, 2, 3] %]
+ [% b = {key1 => 'val1', 'key2' => 'val2'} %]
+
+ [% a.1 %]
+ [% b.key1 %] [% b.key2 %]
+
+Would print:
+
+ 2
+ val1 val2
+
+It is possible to set multiple values at the same time.
+
+ [% SET a = 'A'
+ b = 'B'
+ c = 'C' %]
+ [% a %] [% b %] [% c %]
+
+Would print:
+
+ A B C
+
+It is also possible to unset variables, or to set members of
+nested data structures.
+
+ [% a = 1 %]
+ [% SET a %]
+
+ [% b.0.c = 37 %]
+
+ ([% a %])
+ [% b.0.c %]
+
+Would print
+
+ ()
+ 37
+
+=head1 LITERALS AND CONSTRUCTORS
+
+The following are the types of literals allowed in CET. They can be used as arguments
+to functions, in place of variables in directives, and in place of variables in expressions.
+
+In CET it is also possible to call virtual methods on literal values.
+
+=over 4
+
+=item Integers and Numbers.
+
+ [% 23423 %] Prints an integer.
+ [% 3.14159 %] Prints a number.
+ [% pi = 3.14159 %] Sets the value of the variable.
+ [% 3.13159.length %] Prints 7 (the string length of the number)
+
+
+=item Single quoted string.
+
+Returns the string. No variable interpolation happens.
+
+ [% 'foobar' %] Prints "foobar".
+ [% '$foo\n' %] Prints "$foo\\n". # the \\n is a literal "\" and a "\n"
+ [% 'That\'s nice' %] Prints "That's nice".
+ [% str = 'A string' %] Sets the value of str.
+ [% 'A string'.split %] Splits the string on ' ' and returns the list.
+
+Note: virtual methods can only be used on literal strings in CET, not in TT.
+
+=item Double quoted string.
+
+Returns the string. Variable interpolation happens.
+
+ [% "foobar" %] Prints "foobar".
+ [% "$foo" %] Prints "bar" (assuming the value of foo is bar).
+ [% "${foo} %] Prints "bar" (assuming the value of foo is bar).
+ [% "foobar\n" %] Prints "foobar\n". # the \n is a newline.
+ [% str = "Hello" %] Sets the value of str.
+ [% "foo".replace('foo','bar') %] Prints "bar".
+
+Note: virtual methods can only be used on literal strings in CET, not in TT.
+
+=item Array Constructor.
+
+ [% [1, 2, 3] %] Prints something like ARRAY(0x8309e90).
+ [% [4, 5, 6].size %] Prints 3.
+ [% [7, 8, 9].reverse.0 %] Prints 9.
+ [% array1 = [1 .. 3] %] Sets the value of array1.
+ [% array2 = [foo, 'a', []] %] Sets the value of array2.
+
+Note: virtual methods can only be used on array contructors in CET, not in TT.
+
+=item Hash Constructor.
+
+ [% {foo => 'bar'} %] Prints something like HASH(0x8305880)
+ [% {a => 'A', b => 'B'}.size %] Prints 2.
+ [% {'a' => 'A', 'b' => 'B'}.size %] Prints 2.
+ [% hash = {foo => 'bar', c => {}} %] Sets the value of hash.
+
+Note: virtual methods can only be used on hash contructors in CET, not in TT.
+
+=head1 EXPRESSIONS
+
+Expressions are one or more variables or literals joined together
+operators. An expression can be used anywhere a variable can be used
+with the exception of the variable name of SET, and the filename of
+PROCESS, INCLUDE, WRAPPER, and INSERT.
+
+The following section shows some samples of expressions. For a full list
+of available operators, please see the section titled OPERATORS.
+
+ [% 1 + 2 %] Prints 3
+ [% 1 + 2 * 3 %] Prints 7
+ [% (1 + 2) * 3 %] Prints 9
+
+ [% x = 2 %]
+ [% y = 3 %]
+ [% z = x * (y - 1) %] Prints 4
+
+=head1 VIRTUAL METHODS
+
+The following is the list of builtin virtual methods and filters that
+can be called on each type of data.
+
+In CGI::Ex::Template, the "|" operator can be used to call virtual
+methods just the same way that the "." operator can. The main
+difference between the two is that on access to hashrefs or objects,
+the "|" means to always call the virtual method or filter rather than
+looking in the hashref for a key by that name, or trying to call that
+method on the object. This is similar to how TT3 will function.
+
+=head2 SCALAR VIRTUAL METHODS AND FILTERS
+
+The following is the list of builtin virtual methods and filters
+that can be called on scalar data types. In CET and TT3, filters and
+virtual methods are more closely related. In general anywhere a
+virtual method can be used a filter can be used also - and vice versa
+- all scalar virtual methods can be used as filters.
+
+In addition to the filters listed below, CET will automatically load
+Template::Filters and use them if Template::Toolkit is installed.
+
+In addition to the scalar virtual methods, any scalar will be
+automatically converted to a single item list if a list virtual method
+is called on it.
+
+=over 4
+
+=item chunk
+
+ [% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide.
+
+=item collapse
+
+ [% item.collapse %] Strip leading and trailing whitespace and collapse all other space to one space.
+
+=item defined
+
+ [% item.defined %] Always true - because the undef sub translates all undefs to ''.
+
+=item indent
+
+ [% item.indent(3) %] Indent that number of spaces.
+
+ [% item.indent("Foo: ") %] Add the string "Foo: " to the beginning of every line.
+
+=item eval
+
+ [% item.eval %] Process the string as though it was a template. This will start the parsing
+ engine and will use the same configuration as the current process. CET is several times
+ faster at doing this than TT is and is considered acceptable.
+
+=item evaltt
+
+ Same as the eval filter.
+
+=item file
+
+ Same as the redirect filter.
+
+=item format
+
+ [% item.format('%d') %] Print the string out in the specified format. Each line is
+ processed separately.
+
+=item hash
+
+ [% item.hash %] Returns a one item hash with a key of "value" and a value of the item.
+
+=item html
+
+ [% item.html %] Performs a very basic html encoding (swaps out &, <, > and " for the html entities)
+
+=item lcfirst
+
+ [% item.lcfirst %] Capitalize the leading letter.
+
+=item length
+
+ [% item.length %] Return the length of the string.
+
+=item lower
+
+ [% item.lower %] Return a lower-casified string.
+
+=item match
+
+ [% item.match("(\w+) (\w+)") %] Return a list of items matching the pattern.
+
+ [% item.match("(\w+) (\w+)", 1) %] Same as before - but match globally.
+
+=item null
+
+ [% item.null %] Do nothing.
+
+=item remove
+
+ [% item.remove("\s+") %] Same as remove - but is global and replaces with nothing.
+
+=item redirect
+
+ [% item.redirect("output_file.html") %] - Writes the contents out to the specified file. The filename
+ must be relative to the OUTPUT_PATH configuration variable and the OUTPUT_PATH variable must be set.
+
+=item repeat
+
+ [% item.repeat(3) %] Repeat the item 3 times
+
+ [% item.repeat(3, ' | ') %] Repeat the item 3 times separated with ' | '
+
+=item replace
+
+ [% item.replace("\s+", " ") %] Globally replace all space with
+
+ [% item.replace("foo", "bar", 0) Replace the first instance of foo with bar.
+
+ [% item.replace("(\w+)", "($1)") %] Surround all words with parenthesis.
+
+=item search
+
+ [% item.search("(\w+)" %] Tests if the given pattern is in the string.
+
+=item size
+
+ [% item.size %] Always returns 1.
+
+=item split => \&vmethod_split,
+
+ [% item.split %] Returns an arrayref from the item split on " "
+
+ [% item.split("\s+") %] Returns an arrayref from the item split on /\s+/
+
+ [% item.split("\s+", 3) %] Returns an arrayref from the item split on /\s+/ splitting until 3 elements are found.
+
+=item stderr
+
+ [% item.stderr %] Print the item to the current STDERR handle.
+
+=item substr
+
+ [% item.substr(i) %] Returns a substring of item starting at i and going to the end of the string.
+
+ [% item.substr(i, n) %] Returns a substring of item starting at i and going n characters.
+
+=item trim
+
+ [% item.trim %] Strips leading and trailing whitespace.
+
+=item ucfirst
+
+ [% item.ucfirst %] Lower-case the leading letter.
+
+=item upper
+
+ [% item.upper %] Return a upper-casified string.
+
+=item uri
+
+ [% item.uri %] Perform a very basic URI encoding.
+
+=back
+
+=head2 LIST VIRTUAL METHODS
+
+=over 4
+
+The following methods can be called on an arrayref type data structures (scalar
+types will automatically promote to a single element list and call these methods
+if needed):
+
+=item first
+
+ [% mylist.first(3) %] Returns a list of the first 3 items in the list.
+
+=item grep
+
+ [% mylist.grep("^\w+\.\w+$") %] Returns a list of all items matching the pattern.
+
+=item hash
+
+ [% mylist.hash %] Returns a hashref with the array indexes as keys and the values as values.
+
+=item join
+
+ [% mylist.join %] Joins on space.
+ [% mylist.join(", ") Joins on the passed argument.
+
+=item last
+
+ [% mylist.last(3) %] Returns a list of the last 3 items in the list.
+
+=item list
+
+ [% mylist.list %] Returns a reference to the list.
+
+=item max
+
+ [% mylist.max %] Returns the last item in the array.
+
+=item merge
+
+ [% mylist.merge(list2) %] Returns a new list with all defined items from list2 added.
+
+=item nsort
+
+ [% mylist.nsort %] Returns the numerically sorted items of the list. If the items are
+ hashrefs, a key containing the field to sort on can be passed.
+
+=item pop
+
+ [% mylist.pop %] Removes and returns the last element from the arrayref (the stash is modified).
+
+=item push
+
+ [% mylist.push(23) %] Adds an element to the end of the arrayref (the stash is modified).
+
+=item reverse
+
+ [% mylist.reverse %] Returns the list in reverse order.
+
+=item shift
+
+ [% mylist.shift %] Removes and returns the first element of the arrayref (the stash is modified).
+
+=item size
+
+ [% mylist.size %] Returns the number of elements in the array.
+
+=item slice
+
+ [% mylist.slice(i, n) %] Returns a list from the arrayref beginning at index i and continuing for n items.
+
+=item sort
+
+ [% mylist.sort %] Returns the alphabetically sorted items of the list. If the items are
+ hashrefs, a key containing the field to sort on can be passed.
+
+=item splice
+
+ [% mylist.splice(i, n) %] Removes items from array beginning at i and continuing for n items.
+
+ [% mylist.splice(i, n, list2) %] Same as before, but replaces removed items with the items
+ from list2.
+
+=item unique
+
+ [% mylist.unique %] Return a list of the unique items in the array.
+
+=item unshift
+
+ [% mylist.unshift(23) %] Adds an item to the beginning of the arrayref.
+
+=back 4
+
+=head2 HASH VIRTUAL METHODS
+
+The following methods can be called on hash type data structures:
+
+=over 4
+
+=item defined
+
+ [% myhash.defined('a') %] Checks if a is defined in the hash.
+
+=item delete
+
+ [% myhash.delete('a') %] Deletes the item from the hash.
+
+=item each
+
+ [% myhash.each.join(", ") %] Turns the contents of the hash into a list - subject
+ to change as TT is changing the operations of each and list.
+
+=item exists
+
+ [% myhash.exists('a') %] Checks if a is in the hash.
+
+=item hash
+
+ [% myhash.hash %] Returns a reference to the hash.
+
+=item import
+
+ [% myhash.import(hash2) %] Overlays the keys of hash2 over the keys of myhash.
+
+=item keys
+
+ [% myhash.keys.join(', ') %] Returns an arrayref of the keys of the hash.
+
+=item list
+
+ [% myhash.list %] Returns an arrayref with the hash as a single value (subject to change).
+
+=item pairs
+
+ [% myhash.pairs %] Returns an arrayref of hashrefs where each hash contains {key => $key, value => $value}
+ for each value of the hash.
+
+=item nsort
+
+ [% myhash.nsort.join(", ") %] Returns a numerically sorted list of the keys.
+
+=item size
+
+ [% myhash.size %] Returns the number of key/value pairs in the hash.
+
+=item sort
+
+ [% myhash.sort.join(", ") Returns an alphabetically sorted list.
+
+=item values
+
+ [% myhash.values.join(', ') %] Returns an arrayref of the values of the hash.
+
+=back
+
+=head1 DIRECTIVES
+
+This section contains the alphabetical list of DIRECTIVES available
+in the TT language. DIRECTIVES are the "functions" and control
+structures that implement the Template Toolkit mini-language. For
+further discussion and examples, please refer to the TT directives
+documentation.
+
+
+=over 4
+
+=item C<BLOCK>
+
+Saves a block of text under a name for later use in PROCESS, INCLUDE,
+and WRAPPER directives. Blocks may be placed anywhere within the
+template being processed including after where they are used.
+
+ [% BLOCK foo %]Some text[% END %]
+ [% PROCESS foo %]
+
+ Would print
+
+ Some text
+
+ [% INCLUDE foo %]
+ [% BLOCK foo %]Some text[% END %]
+
+ Would print
+
+ Some text
+
+Anonymous BLOCKS can be used for capturing.
+
+ [% a = BLOCK %]Some text[% END %][% a %]
+
+ Would print
+
+ Some text
+
+Anonymous BLOCKS can be used with macros.
+
+
+=item C<BREAK>
+
+Alias for LAST. Used for exiting FOREACH and WHILE loops.
+
+=item C<CALL>
+
+Calls the variable (and any underlying coderefs) as in the GET method, but
+always returns an empty string.
+
+=item C<CASE>
+
+Used with the SWITCH directive. See the L</"SWITCH"> directive.
+
+=item C<CATCH>
+
+Used with the TRY directive. See the L</"TRY"> directive.
+
+=item C<CLEAR>
+
+Clears any of the content currently generated in the innermost block
+or template. This can be useful when used in conjunction with the TRY
+statement to clear generated content if an error occurs later.
+
+=item C<DEBUG>
+
+Used to reset the DEBUG_FORMAT configuration variable, or to turn
+DEBUG statements on or off. This only has effect if the DEBUG_DIRS or
+DEBUG_ALL flags were passed to the DEBUG configuration variable.
+
+ [% DEBUG format '($file) (line $line) ($text)' %]
+ [% DEBUG on %]
+ [% DEBUG off %]
+
+=item C<DEFAULT>
+
+Similar to SET, but only sets the value if a previous value was not
+defined or was zero length.
+
+ [% DEFAULT foo = 'bar' %][% foo %] => 'bar'
+
+ [% foo = 'baz' %][% DEFAULT foo = 'bar' %][% foo %] => 'baz'
+
+=item C<DUMP>
+
+This is not provided in TT. DUMP inserts a Data::Dumper printout
+of the variable or expression. If no argument is passed it will
+dump the entire contents of the current variable stash (with
+private keys removed.
+
+If the template is being processed in a web request, DUMP will html
+encode the DUMP automatically.
+
+ [% DUMP %] # dumps everything
+
+ [% DUMP 1 + 2 %]
+
+=item C<ELSE>
+
+Used with the IF directive. See the L</"IF"> directive.
+
+=item C<ELSIF>
+
+Used with the IF directive. See the L</"IF"> directive.
+
+=item C<END>
+
+Used to end a block directive.
+
+=item C<FILTER>
+
+Used to apply different treatments to blocks of text. It may operate as a BLOCK
+directive or as a post operative directive. CET supports all of the filters in
+Template::Filters. The lines between scalar virtual methods and filters is blurred (or
+non-existent) in CET. Anything that is a scalar virtual method may be used as a FILTER.
+
+TODO - enumerate the at least 7 ways to pass and use filters.
+
+=item C<'|'>
+
+Alias for the FILTER directive. Note that | is similar to the
+'.' in CGI::Ex::Template. Therefore a pipe cannot be used directly after a
+variable name in some situations (the pipe will act only on that variable).
+This is the behavior employed by TT3.
+
+=item C<FINAL>
+
+Used with the TRY directive. See the L</"TRY"> directive.
+
+=item C<FOR>
+
+Alias for FOREACH
+
+=item C<FOREACH>
+
+Allows for iterating over the contents of any arrayref. If the variable is not an
+arrayref, it is automatically promoted to one.
+
+ [% FOREACH i IN [1 .. 3] %]
+ The variable i = [% i %]
+ [%~ END %]
+
+ [% a = [1 .. 3] %]
+ [% FOREACH j IN a %]
+ The variable j = [% j %]
+ [%~ END %]
+
+Would print:
+
+ The variable i = 1
+ The variable i = 2
+ The variable i = 3
+
+ The variable j = 1
+ The variable j = 2
+ The variable j = 3
+
+You can also use the "=" instead of "IN" or "in".
+
+ [% FOREACH i = [1 .. 3] %]
+ The variable i = [% i %]
+ [%~ END %]
+
+ Same as before.
+
+Setting into a variable is optional.
+
+ [% a = [1 .. 3] %]
+ [% FOREACH a %] Hi [% END %]
+
+Would print:
+
+ hi hi hi
+
+If the item being iterated is a hashref and the FOREACH does not
+set into a variable, then values of the hashref are copied into
+the variable stash.
+
+ [% FOREACH [{a => 1}, {a => 2}] %]
+ Key a = [% a %]
+ [%~ END %]
+
+Would print:
+
+ Key a = 1
+ Key a = 2
+
+The FOREACH process uses the CGI::Ex::Template::Iterator class to handle
+iterations (It is compatible with Template::Iterator). During the FOREACH
+loop an object blessed into the iterator class is stored in the variable "loop".
+
+The loop variable provides the following information during a FOREACH:
+
+ index - the current index
+ max - the max index of the list
+ size - the number of items in the list
+ count - index + 1
+ number - index + 1
+ first - true if on the first item
+ last - true if on the last item
+ next - return the next item in the list
+ prev - return the previous item in the list
+
+The following:
+
+ [% FOREACH [1 .. 3] %] [% loop.count %]/[% loop.size %] [% END %]
+
+Would print:
+
+ 1/3 2/3 3/3
+
+The iterator is also available using a plugin. This allows for access
+to multiple "loop" variables in a nested FOREACH directive.
+
+ [%~ USE outer_loop = Iterator(["a", "b"]) %]
+ [%~ FOREACH i = outer_loop %]
+ [%~ FOREACH j = ["X", "Y"] %]
+ [% outer_loop.count %]-[% loop.count %] = ([% i %] and [% j %])
+ [%~ END %]
+ [%~ END %]
+
+Would print:
+
+ 1-1 = (a and X)
+ 1-2 = (a and Y)
+ 2-1 = (b and X)
+ 2-2 = (b and Y)
+
+FOREACH may also be used as a post operative directive.
+
+ [% "$i" FOREACH i = [1 .. 5] %] => 12345
+
+=item C<GET>
+
+Return the value of a variable or expression.
+
+ [% GET a %]
+
+The GET keyword may be omitted.
+
+ [% a %]
+
+ [% 7 + 2 - 3 %] => 6
+
+See the section on VARIABLES.
+
+=item C<IF (IF / ELSIF / ELSE)>
+
+Allows for conditional testing. Expects an expression as its only
+argument. If the expression is true, the contents of its block are
+processed. If false, the processor looks for an ELSIF block. If an
+ELSIF's expression is true then it is processed. Finally it looks for
+an ELSE block which is processed if none of the IF or ELSIF's
+expressions were true.
+
+ [% IF a == b %]A equaled B[% END %]
+
+ [% IF a == b -%]
+ A equaled B
+ [%- ELSIF a == c -%]
+ A equaled C
+ [%- ELSE -%]
+ Couldn't determine that A equaled anything.
+ [%- END %]
+
+IF may also be used as a post operative directive.
+
+ [% 'A equaled B' IF a == b %]
+
+=item C<INCLUDE>
+
+Parse the contents of a file or block and insert them. Variables defined
+or modifications made to existing variables are discarded after
+a template is included.
+
+ [% INCLUDE path/to/template.html %]
+
+ [% INCLUDE "path/to/template.html" %]
+
+ [% file = "path/to/template.html" %]
+ [% INCLUDE $file %]
+
+ [% BLOCK foo %]This is foo[% END %]
+ [% INCLUDE foo %]
+
+Arguments may also be passed to the template:
+
+ [% INCLUDE "path/to/template.html" a = "An arg" b = "Another arg" %]
+
+Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE
+or RELATIVE configuration items are set.
+
+=item C<INSERT>
+
+Insert the contents of a file without template parsing.
+
+Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE
+or RELATIVE configuration items are set.
+
+=item C<LAST>
+
+Used to exit out of a WHILE or FOREACH loop.
+
+=item C<MACRO>
+
+Takes a directive and turns it into a variable that can take arguments.
+
+ [% MACRO foo(i, j) BLOCK %]You passed me [% i %] and [% j %].[% END %]
+
+ [%~ foo("a", "b") %]
+ [% foo(1, 2) %]
+
+Would print:
+
+ You passed me a and b.
+ You passed me 1 and 2.
+
+Another example:
+
+ [% MACRO bar(max) FOREACH i = [1 .. max] %]([% i %])[% END %]
+
+ [%~ bar(4) %]
+
+Would print:
+
+ (1)(2)(3)(4)
+
+=item C<META>
+
+Used to define variables that will be available via either the
+template or component namespace.
+
+Once defined, they cannot be overwritten.
+
+ [% template.foobar %]
+ [%~ META foobar = 'baz' %]
+ [%~ META foobar = 'bing' %]
+
+Would print:
+
+ baz
+
+=item C<NEXT>
+
+Used to go to the next iteration of a WHILE or FOREACH loop.
+
+=item C<PERL>
+
+Only available if the EVAL_PERL configuration item is true (default is false).
+
+Allow eval'ing the block of text as perl. The block will be parsed and then eval'ed.
+
+ [% a = "BimBam" %]
+ [%~ PERL %]
+ my $a = "[% a %]";
+ print "The variable \$a was \"$a\"";
+ $stash->set('b', "FooBar");
+ [% END %]
+ [% b %]
+
+Would print:
+
+ The variable $a was "BimBam"
+ FooBar
+
+During execution, anything printed to STDOUT will be inserted into the template. Also,
+the $stash and $context variables are set and are references to objects that mimic the
+interface provided by Template::Context and Template::Stash. These are provided for
+compatibility only. $self contains the current CGI::Ex::Template object.
+
+=item C<PROCESS>
+
+Parse the contents of a file or block and insert them. Unlike INCLUDE,
+no variable localization happens so variables defined or modifications made
+to existing variables remain after the template is processed.
+
+ [% PROCESS path/to/template.html %]
+
+ [% PROCESS "path/to/template.html" %]
+
+ [% file = "path/to/template.html" %]
+ [% PROCESS $file %]
+
+ [% BLOCK foo %]This is foo[% END %]
+ [% PROCESS foo %]
+
+Arguments may also be passed to the template:
+
+ [% PROCESS "path/to/template.html" a = "An arg" b = "Another arg" %]
+
+Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE
+or RELATIVE configuration items are set.
+
+=item C<RAWPERL>
+
+Only available if the EVAL_PERL configuration item is true (default is false).
+Similar to the PERL directive, but you will need to append
+to the $output variable rather than just calling PRINT.
+
+=item C<RETURN>
+
+Used to exit the innermost block or template and continue processing
+in the surrounding block or template.
+
+=item C<SET>
+
+Used to set variables.
+
+ [% SET a = 1 %][% a %] => "1"
+ [% a = 1 %][% a %] => "1"
+ [% b = 1 %][% SET a = b %][% a %] => "1"
+ [% a = 1 %][% SET a %][% a %] => ""
+ [% SET a = [1, 2, 3] %][% a.1 %] => "2"
+ [% SET a = {b => 'c'} %][% a.b %] => "c"
+
+=item C<STOP>
+
+Used to exit the entire process method (out of all blocks and templates).
+No content will be processed beyond this point.
+
+=item C<SWITCH>
+
+Allow for SWITCH and CASE functionality.
+
+ [% a = "hi" %]
+ [% b = "bar" %]
+ [% SWITCH a %]
+ [% CASE "foo" %]a was foo
+ [% CASE b %]a was bar
+ [% CASE ["hi", "hello"] %]You said hi or hello
+ [% CASE DEFAULT %]I don't know what you said
+ [% END %]
+
+Would print:
+
+ You said hi or hello
+
+=item C<TAGS>
+
+Change the type of enclosing braces used to delineate template tags. This
+remains in effect until the end of the enclosing block or template or until
+the next TAGS directive. Either a named set of tags must be supplied, or
+two tags themselves must be supplied.
+
+ [% TAGS html %]
+
+ [% TAGS <!-- --> %]
+
+The named tags are (duplicated from TT):
+
+ template => ['[%', '%]'], # default
+ metatext => ['%%', '%%'], # Text::MetaText
+ star => ['[*', '*]'], # TT alternate
+ php => ['<?', '?>'], # PHP
+ asp => ['<%', '%>'], # ASP
+ mason => ['<%', '>' ], # HTML::Mason
+ html => ['<!--', '-->'], # HTML comments
+
+=item C<THROW>
+
+Allows for throwing an exception. If the exception is not caught
+via the TRY DIRECTIVE, the template will abort processing of the directive.
+
+ [% THROW mytypes.sometime 'Something happened' arg1 => val1 %]
+
+See the TRY directive for examples of usage.
+
+=item C<TRY>
+
+The TRY block directive will catch exceptions that are thrown
+while processing its block (It cannot catch parse errors unless
+they are in included files or evaltt'ed strings. The TRY block
+will then look for a CATCH block that will be processed. While
+it is being processed, the "error" variable will be set with the thrown
+exception as the value. After the TRY block - the FINAL
+block will be ran whether or not an error was thrown (unless a CATCH
+block throws an error).
+
+Note: Parse errors cannot be caught unless they are in an eval FILTER, or are
+in a separate template being INCLUDEd or PROCESSed.
+
+ [% TRY %]
+ Nothing bad happened.
+ [% CATCH %]
+ Caught the error.
+ [% FINAL %]
+ This section runs no matter what happens.
+ [% END %]
+
+Would print:
+
+ Nothing bad happened.
+ This section runs no matter what happens.
+
+Another example:
+
+ [% TRY %]
+ [% THROW "Something happened" %]
+ [% CATCH %]
+ Error: [% error %]
+ Error.type: [% error.type %]
+ Error.info: [% error.info %]
+ [% FINAL %]
+ This section runs no matter what happens.
+ [% END %]
+
+Would print:
+
+ Error: undef error - Something happened
+ Error.type: undef
+ Error.info: Something happened
+ This section runs no matter what happens.
+
+You can give the error a type and more information including named arguments.
+This information replaces the "info" property of the exception.
+
+ [% TRY %]
+ [% THROW foo.bar "Something happened" "grrrr" foo => 'bar' %]
+ [% CATCH %]
+ Error: [% error %]
+ Error.type: [% error.type %]
+ Error.info: [% error.info %]
+ Error.info.0: [% error.info.0 %]
+ Error.info.1: [% error.info.1 %]
+ Error.info.args.0: [% error.info.args.0 %]
+ Error.info.foo: [% error.info.foo %]
+ [% END %]
+
+Would print something like:
+
+ Error: foo.bar error - HASH(0x82a395c)
+ Error.type: foo.bar
+ Error.info: HASH(0x82a395c)
+ Error.info.0: Something happened
+ Error.info.1: grrrr
+ Error.info.args.0: Something happened
+ Error.info.foo: bar
+
+You can also give the CATCH block a type to catch. And you
+can nest TRY blocks. If types are specified, CET will try and
+find the closest matching type. Also, an error object can
+be re-thrown using $error as the argument to THROW.
+
+ [% TRY %]
+ [% TRY %]
+ [% THROW foo.bar "Something happened" %]
+ [% CATCH bar %]
+ Caught bar.
+ [% CATCH DEFAULT %]
+ Caught default - but rethrew.
+ [% THROW $error %]
+ [% END %]
+ [% CATCH foo %]
+ Caught foo.
+ [% CATCH foo.bar %]
+ Caught foo.bar.
+ [% CATCH %]
+ Caught anything else.
+ [% END %]
+
+Would print:
+
+ Caught default - but rethrew.
+
+ Caught foo.bar.
+
+=item C<UNLESS>
+
+Same as IF but condition is negated.
+
+ [% UNLESS 0 %]hi[% END %] => hi
+
+Can also be a post operative directive.
+
+=item C<USE>
+
+Allows for loading a Template::Toolkit style plugin.
+
+ [% USE iter = Iterator(['foo', 'bar']) %]
+ [%~ iter.get_first %]
+ [% iter.size %]
+
+Would print:
+
+ foo
+ 2
+
+Note that it is possible to send arguments to the new object
+constructor. It is also possible to omit the variable name being
+assigned. In that case the name of the plugin becomes the variable.
+
+ [% USE Iterator(['foo', 'bar', 'baz']) %]
+ [%~ Iterator.get_first %]
+ [% Iterator.size %]
+
+Would print:
+
+ foo
+ 3
+
+Plugins that are loaded are looked up for in the namespace listed in
+the PLUGIN_BASE directive which defaults to Template::Plugin. So in
+the previous example, if Template::Toolkit was installed, the iter
+object would loaded by the class Template::Plugin::Iterator. In CET,
+an effective way to disable plugins is to set the PLUGIN_BASE to a
+non-existent base such as "_" (In TT it will still fall back to look
+in Template::Plugin).
+
+Note: The iterator plugin will fall back and use
+CGI::Ex::Template::Iterator if Template::Toolkit is not installed. No
+other plugins come installed with CGI::Ex::Template.
+
+The names of the Plugin being loaded from PLUGIN_BASE are case
+insensitive. However, using case insensitive names is bad as it
+requires scanning the @INC directories for any module matching the
+PLUGIN_BASE and caching the result (OK - not that bad).
+
+If the plugin is not found and the LOAD_PERL directive is set, then
+CET will try and load a module by that name (note: this type of lookup
+is case sensitive and will not scan the @INC dirs for a matching
+file).
+
+ # The LOAD_PERL directive should be set to 1
+ [% USE cet = CGI::Ex::Template %]
+ [%~ cet.dump_parse('2 * 3').replace('\s+', ' ') %]
+
+Would print:
+
+ $VAR1 = [ \[ '*', '2', '3' ], 0 ];
+
+See the PLUGIN_BASE, and PLUGINS configuration items.
+
+See the documentation for Template::Manual::Plugins.
+
+=item C<WHILE>
+
+Will process a block of code while a condition is true.
+
+ [% WHILE i < 3 %]
+ [%~ i = i + 1 %]
+ i = [% i %]
+ [%~ END %]
+
+Would print:
+
+ i = 1
+ i = 2
+ i = 3
+
+You could also do:
+
+ [% i = 4 %]
+ [% WHILE (i = i - 1) %]
+ i = [% i %]
+ [%~ END %]
+
+Would print:
+
+ i = 3
+ i = 2
+ i = 1
+
+Note that (f = f - 1) is a valid expression that returns the value
+of the assignment. The parenthesis are not optional.
+
+WHILE has a built in limit of 1000 iterations. This is controlled by the
+global variable $WHILE_MAX in CGI::Ex::Template.
+
+WHILE may also be used as a post operative directive.
+
+ [% "$i" WHILE (i = i + 1) < 7 %] => 123456
+
+=item C<WRAPPER>
+
+Block directive. Processes contents of its block and then passes them
+in the [% content %] variable to the block or filename listed in the
+WRAPPER tag.
+
+ [% WRAPPER foo %]
+ My content to be processed.[% a = 2 %]
+ [% END %]
+
+ [% BLOCK foo %]
+ A header ([% a %]).
+ [% content %]
+ A footer ([% a %]).
+ [% END %]
+
+This would print.
+
+ A header (2).
+ My content to be processed.
+ A footer (2).
+
+The WRAPPER directive may also be used as a post directive.
+
+ [% BLOCK baz %]([% content %])[% END -%]
+ [% "foobar" WRAPPER baz %]
+
+Would print
+
+ (foobar)');
+
+=back
+
+
+
+=head1 OPERATORS
+
+The following operators are available in CGI::Ex::Template. Except
+where noted these are the same operators available in TT. They are
+listed in the order of their precedence (the higher the precedence the
+tighter it binds).
+
+=over 4
+
+=item C<.>
+
+Binary. The dot operator. Allows for accessing sub-members, methods, or
+virtual methods of nested data structures.
+
+ my $obj->process(\$content, {a => {b => [0, {c => [34, 57]}]}}, \$output);
+
+ [% a.b.1.c.0 %] => 34
+
+Note: on access to hashrefs, any hash keys that match the sub key name
+will be used before a virtual method of the same name. For example if
+a passed hash contained pair with a keyname "defined" and a value of
+"2", then any calls to hash.defined(another_keyname) would always
+return 2 rather than using the vmethod named "defined." To get around
+this limitation use the "|" operator (listed next). Also - on objects
+the "." will always try and call the method by that name. To always
+call the vmethod - use "|".
+
+=item C<|>
+
+Binary. The pipe operator. Similar to the dot operator. Allows for
+explicit calling of virtual methods and filters (filters are "merged"
+with virtual methods in CGI::Ex::Template and TT3) when accessing
+hashrefs and objects. See the note for the "." operator.
+
+The pipe character is similar to TT2 in that it can be used in place
+of a directive as an alias for FILTER. It similar to TT3 in that it
+can be used for virtual method access. This duality is one source of
+difference between CGI::Ex::Template and TT2 compatibility. Templates
+that have directives that end with a variable name that then use the
+"|" directive to apply a filter will be broken as the "|" will be
+applied to the variable name.
+
+The following two cases will do the same thing.
+
+ [% foo | html %]
+
+ [% foo FILTER html %]
+
+Though they do the same thing, internally, foo|html is stored as a
+single variable while "foo FILTER html" is stored as the variable foo
+which is then passed to the FILTER html.
+
+A TT2 sample that would break in CGI::Ex::Template or TT3 is:
+
+ [% PROCESS foo a = b | html %]
+
+Under TT2 the content returned by "PROCESS foo a = b" would all be
+passed to the html filter. Under CGI::Ex::Template and TT3, b would
+be passed to the html filter before assigning it to the variable "a"
+before the template foo was processed.
+
+A simple fix is to do any of the following:
+
+ [% PROCESS foo a = b FILTER html %]
+
+ [% | html %][% PROCESS foo a = b %][% END %]
+
+ [% FILTER html %][% PROCESS foo a = b %][% END %]
+
+This shouldn't be too much hardship and offers the great return of disambiguating
+virtual method access.
+
+=item C<** ^ pow>
+
+Binary. X raised to the Y power. This isn't available in TT 2.15.
+
+ [% 2 ** 3 %] => 8
+
+=item C<!>
+
+Unary not. Negation of the value.
+
+=item C<- unary_minus>
+
+Unary minus. Returns the value multiplied by -1. The operator
+"unary_minus" is used internally by CGI::Ex::Template to provide for -
+to be listed in the precedence table twice.
+
+ [% a = 1 ; b = -a ; b %] => -1
+
+=item C<*>
+
+Binary. Multiplication.
+
+=item C</ div DIV>
+
+Binary. Division. Note that / is floating point division, but div and
+DIV are integer division.
+
+ [% 10 / 4 %] => 2.5
+ [% 10 div 4 %] => 2
+
+=item C<% mod MOD>
+
+Binary. Modulus.
+
+ [% 15 % 8 %] => 7
+
+=item C<+>
+
+Binary. Addition.
+
+=item C<->
+
+Binary. Minus.
+
+=item C<_ ~>
+
+Binary. String concatenation.
+
+ [% "a" ~ "b" %] => ab
+
+=item C<< < > <= >= >>
+
+Binary. Numerical comparators.
+
+=item C<lt gt le ge>
+
+Binary. String comparators.
+
+=item C<== eq>
+
+Binary. Equality test. TT chose to use Perl's eq for both operators.
+There is no test for numeric equality.
+
+=item C<!= ne>
+
+Binary. Non-equality test. TT chose to use Perl's ne for both
+operators. There is no test for numeric non-equality.
+
+=item C<&&>
+
+Multiple arity. And. All values must be true. If all values are true, the last
+value is returned as the truth value.
+
+ [% 2 && 3 && 4 %] => 4
+
+=item C<||>
+
+Multiple arity. Or. The first true value is returned.
+
+ [% 0 || '' || 7 %] => 7
+
+=item C<..>
+
+Binary. Range creator. Returns an arrayref containing the values
+between and including the first and last arguments.
+
+ [% t = [1 .. 5] %] => variable t contains an array with 1,2,3,4, and 5
+
+It is possible to place multiple ranges in the same [] constructor. This is not available in TT.
+
+ [% t = [1..3, 6..8] %] => variable t contains an array with 1,2,3,6,7,8
+
+The .. operator is the only operator that returns a list of items.
+
+=item C<? :>
+
+Trinary. Can be nested with other ?: pairs.
+
+ [% 1 ? 2 : 3 %] => 2
+ [% 0 ? 2 : 3 %] => 3
+
+=item C<=>
+
+Assignment. Sets the left-hand side to the value of the righthand side. In order
+to not conflict with SET, FOREACH and other operations, this operator is only
+available in parenthesis. Returns the value of the righthand side.
+
+ [% (a = 1) %] --- [% a %] => 1 --- 1
+
+=item C<not NOT>
+
+Lower precedence version of the '!' operator.
+
+=item C<and AND>
+
+Lower precedence version of the '&&' operator.
+
+=item C<or OR>
+
+Lower precedence version of the '||' operator.
+
+=item C<hash>
+
+Multiple arity. This operator is not used in TT. It is used internally
+by CGI::Ex::Template to delay the creation of a hash until the
+execution of the compiled template.
+
+=item C<array>
+
+Multiple arity. This operator is not used in TT. It is used internally
+by CGI::Ex::Template to delay the creation of an array until the
+execution of the compiled template.
+
+=back
+
+
+=head1 CHOMPING
+
+Chomping refers to the handling of whitespace immediately before and
+immediately after template tags. By default, nothing happens to this
+whitespace. Modifiers can be placed just inside the opening and just
+before the closing tags to control this behavior.
+
+Additionally, the PRE_CHOMP and POST_CHOMP configuration variables can
+be set and will globally control all chomping behavior for tags that
+do not have their own chomp modifier. PRE_CHOMP and POST_CHOMP can
+be set to any of the following values:
+
+ none: 0 + Template::Constants::CHOMP_NONE
+ one: 1 - Template::Constants::CHOMP_ONE
+ collapse: 2 = Template::Constants::CHOMP_COLLAPSE
+ greedy: 3 ~ Template::Constants::CHOMP_GREEDY
+
+=over 4
+
+=item CHOMP_NONE
+
+Don't do any chomping. The "+" sign is used to indicate CHOMP_NONE.
+
+ Hello.
+
+ [%+ "Hi." +%]
+
+ Howdy.
+
+Would print:
+
+ Hello.
+
+ Hi.
+
+ Howdy.
+
+=item CHOMP_ONE (formerly known as CHOMP_ALL)
+
+Delete any whitespace up to the adjacent newline. The "-" is used to indicate CHOMP_ONE.
+
+ Hello.
+
+ [%- "Hi." -%]
+
+ Howdy.
+
+Would print:
+
+ Hello.
+ Hi.
+ Howdy.
+
+=item CHOMP_COLLAPSE
+
+Collapse adjacent whitespace to a single space. The "=" is used to indicate CHOMP_COLLAPSE.
+
+ Hello.
+
+ [%- "Hi." -%]
+
+ Howdy.
+
+Would print:
+
+ Hello. Hi. Howdy.
+
+=item CHOMP_GREEDY
+
+Remove all adjacent whitespace. The "~" is used to indicate CHOMP_GREEDY.
+
+ Hello.
+
+ [%- "Hi." -%]
+
+ Howdy.
+
+Would print:
+
+ Hello.Hi.Howdy.
+
+=head1 CONFIGURATION
+
+The following TT2 configuration variables are supported (in
+alphabetical order). Note: for further discussion you can refer to
+the TT config documentation.
+
+These variables should be passed to the "new" constructor.
+
+ my $obj = CGI::Ex::Template->new(
+ VARIABLES => \%hash_of_variables,
+ AUTO_RESET => 0,
+ TRIM => 1,
+ POST_CHOMP => "=",
+ PRE_CHOMP => "-",
+ );
+
+
+=over 4
+
+=item ABSOLUTE
+
+Boolean. Default false. Are absolute paths allowed for included files.
+
+=item AUTO_RESET
+
+Boolean. Default 1. Clear blocks that were set during the process method.
+
+=item BLOCKS
+
+A hashref of blocks that can be used by the process method.
+
+ BLOCKS => {
+ block_1 => sub { ... }, # coderef that returns a block
+ block_2 => 'A String', # simple string
+ },
+
+Note that a Template::Document cannot be supplied as a value (TT
+supports this). However, it is possible to supply a value that is
+equal to the hashref returned by the load_parsed_tree method.
+
+=item CACHE_SIZE
+
+Number of compiled templates to keep in memory. Default undef.
+Undefined means to allow all templates to cache. A value of 0 will
+force no caching. The cache mechanism will clear templates that have
+not been used recently.
+
+=item COMPILE_DIR
+
+Base directory to store compiled templates. Default undef. Compiled
+templates will only be stored if one of COMPILE_DIR and COMPILE_EXT is
+set.
+
+=item COMPILE_EXT
+
+Extension to add to stored compiled template filenames. Default undef.
+
+=item CONSTANTS
+
+Hashref. Used to define variables that will be "folded" into the
+compiled template. Variables defined here cannot be overridden.
+
+ CONSTANTS => {my_constant => 42},
+
+ A template containing:
+
+ [% constants.my_constant %]
+
+ Will have the value 42 compiled in.
+
+Constants defined in this way can be chained as in [%
+constant.foo.bar.baz %] but may only interpolate values that are set
+before the compile process begins. This goes one step beyond TT in
+that any variable set in VARIABLES, or PRE_DEFINE, or passed to the
+process method are allowed - they are not in TT. Variables defined in
+the template are not available during the compile process.
+
+ GOOD:
+
+ CONSTANTS => {
+ foo => {
+ bar => {baz => 42},
+ bim => 57,
+ },
+ bing => 'baz',
+ bang => 'bim',
+ },
+ VARIABLES => {
+ bam => 'bar',
+ },
+
+ In the template
+
+ [% constants.foo.${constants.bang} %]
+
+ Will correctly print 57.
+
+ GOOD (non-tt behavior)
+
+ [% constants.foo.$bam.${constants.bing} %]
+
+ CGI::Ex::Template will print 42 because the value of bam is
+ known at compile time. TT would print '' because the value of $bam
+ is not yet defined in the TT engine.
+
+ BAD:
+
+ In the template:
+
+ [% bam = 'somethingelse' %]
+ [% constants.foo.$bam.${constants.bing} %]
+
+ Will still print 42 because the value of bam used comes from
+ variables defined before the template was compiled. TT will still print ''.
+
+=item CONSTANT_NAMESPACE
+
+Allow for setting the top level of values passed in CONSTANTS. Default
+value is 'constants'.
+
+=item DEBUG
+
+ Takes a list of constants |'ed together which enables different
+ debugging modes. Alternately the lowercase names may be used (multiple
+ values joined by a ",".
+
+ The only supported TT values are:
+ DEBUG_UNDEF (2) - debug when an undefined value is used.
+ DEBUG_DIRS (8) - debug when a directive is used.
+ DEBUG_ALL (2047) - turn on all debugging.
+
+ Either of the following would turn on undef and directive debugging:
+
+ DEBUG => 'undef, dirs', # preferred
+ DEBUG => 2 | 8,
+ DEBUG => DEBUG_UNDEF | DEBUG_DIRS, # constants from Template::Constants
+
+=item DEBUG_FORMAT
+
+Change the format of messages inserted when DEBUG has DEBUG_DIRS set on.
+This essentially the same thing as setting the format using the DEBUG
+directive.
+
+=item DEFAULT
+
+The name of a default template file to use if the passed on is not found.
+
+=item DELIMITER
+
+String to use to split INCLUDE_PATH with. Default is :. It is more
+straight forward to just send INCLUDE_PATH an arrayref of paths.
+
+=item END_TAG
+
+Set a string to use as the closing delimiter for TT. Default is "%]".
+
+=item EVAL_PERL
+
+Boolean. Default false. If set to a true value, PERL and RAWPERL blocks
+will be allowed to run. This is a potential security hole, as arbitrary
+perl can be included in the template. If Template::Toolkit is installed,
+a true EVAL_PERL value also allows the perl and evalperl filters to be used.
+
+=item FILTERS
+
+Allow for passing in TT style filters.
+
+ my $filters = {
+ filter1 => sub { my $str = shift; $s =~ s/./1/gs; $s },
+ filter2 => [sub { my $str = shift; $s =~ s/./2/gs; $s }, 0],
+ filter3 => [sub { my ($context, @args) = @_; return sub { my $s = shift; $s =~ s/./3/gs; $s } }, 1],
+ };
+
+ my $str = q{
+ [% a = "Hello" %]
+ 1([% a | filter1 %])
+ 2([% a | filter2 %])
+ 3([% a | filter3 %])
+ };
+
+ my $obj = CGI::Ex::Template->new(FILTERS => $filters);
+ $obj->process(\$str) || die $obj->error;
+
+Would print:
+
+ (11111)
+ (22222)
+ (33333)
+
+Filters passed in as an arrayref should contain a coderef and a value
+indicating if they are dynamic or static (true meaning dynamic). The
+dynamic filters are passed the pseudo context object and any arguments
+and should return a coderef that will be called as the filter. The filter
+coderef is then passed the string.
+
+=item INCLUDE_PATH
+
+A string or an arrayref or coderef that returns an arrayref that
+contains directories to look for files included by processed
+templates.
+
+=item INCLUDE_PATHS
+
+Non-TT item. Same as INCLUDE_PATH but only takes an arrayref. If not specified
+then INCLUDE_PATH is turned into an arrayref and stored in INCLUDE_PATHS.
+Overrides INCLUDE_PATH.
+
+=item INTERPOLATE
+
+Boolean. Specifies whether variables in text portions of the template will be
+interpolated. For example, the $variable and ${var.value} would be substituted
+with the appropriate values from the variable cache (if INTERPOLATE is on).
+
+ [% IF 1 %]The variable $variable had a value ${var.value}[% END %]
+
+
+=item LOAD_PERL
+
+Indicates if the USE directive can fall back and try and load a perl module
+if the indicated module was not found in the PLUGIN_BASE path. See the
+USE directive.
+
+=item NAMESPACE
+
+No Template::Namespace::Constants support. Hashref of hashrefs representing
+constants that will be folded into the template at compile time.
+
+ CGI::Ex::Template->new(NAMESPACE => {constants => {
+ foo => 'bar',
+ }});
+
+Is the same as
+
+ CGI::Ex::Template->new(CONSTANTS => {
+ foo => 'bar',
+ });
+
+Any number of hashes can be added to the NAMESPACE hash.
+
+=item OUTPUT
+
+Alternate way of passing in the output location for processed templates.
+If process is not passed an output argument, it will look for this value.
+
+See the process method for a listing of possible values.
+
+=item OUTPUT_PATH
+
+Base path for files written out via the process method or via the redirect
+and file filters. See the redirect virtual method and the process method
+for more information.
+
+=item PLUGINS
+
+A hashref of mappings of plugin modules.
+
+ PLUGINS => {
+ Iterator => 'Template::Plugin::Iterator',
+ DBI => 'MyDBI',
+ },
+
+See the USE directive for more information.
+
+=item PLUGIN_BASE
+
+Default value is Template::Plugin. The base module namespace
+that template plugins will be looked for. See the USE directive
+for more information.
+
+=item POST_CHOMP
+
+Set the type of chomping at the ending of a tag.
+See the section on chomping for more information.
+
+=item POST_PROCESS
+
+A list of templates to be processed and appended to the content
+after the main template. During this processing the "template"
+namespace will contain the name of the main file being processed.
+
+This is useful for adding a global footer to all templates.
+
+=item PRE_CHOMP
+
+Set the type of chomping at the beginning of a tag.
+See the section on chomping for more information.
+
+=item PRE_DEFINE
+
+Same as the VARIABLES configuration item.
+
+=item PRE_PROCESS
+
+A list of templates to be processed before and pre-pended to the content
+before the main template. During this processing the "template"
+namespace will contain the name of the main file being processed.
+
+This is useful for adding a global header to all templates.
+
+=item PROCESS
+
+Specify a file to use as the template rather than the one passed in
+to the ->process method.
+
+=item RECURSION
+
+Boolean. Default false. Indicates that INCLUDED or PROCESSED files
+can refer to each other in a circular manner. Be careful about recursion.
+
+=item RELATIVE
+
+Boolean. Default false. If true, allows filenames to be specified
+that are relative to the currently running process.
+
+=item START_TAG
+
+Set a string to use as the opening delimiter for TT. Default is "[%".
+
+=item TAG_STYLE
+
+Allow for setting the type of tag delimiters to use for parsing the TT.
+See the TAGS directive for a listing of the available types.
+
+=item TRIM
+
+Remove leading and trailing whitespace from blocks and templates.
+This operation is performed after all enclosed template tags have
+been executed.
+
+=item UNDEFINED_ANY
+
+This is not a TT configuration option. This option expects to be a code
+ref that will be called if a variable is undefined during a call to get_variable.
+It is passed the variable identity array as a single argument. This
+is most similar to the "undefined" method of Template::Stash. It allows
+for the "auto-defining" of a variable for use in the template. It is
+suggested that UNDEFINED_GET be used instead as UNDEFINED_ANY is a little
+to general in defining variables.
+
+You can also sub class the module and override the undefined_any method.
+
+=item UNDEFINED_GET
+
+This is not a TT configuration option. This option expects to be a code
+ref that will be called if a variable is undefined during a call to GET.
+It is passed the variable identity array as a single argument. This is more useful
+than UNDEFINED_ANY in that it is only called during a GET directive
+rather than in embedded expressions (such as [% a || b || c %]).
+
+You can also sub class the module and override the undefined_get method.
+
+=item VARIABLES
+
+A hashref of variables to initialize the template stash with. These
+variables are available for use in any of the executed templates.
+See the section on VARIABLES for the types of information that can be passed in.
+
+=back
+
+
+
+=head1 UNSUPPORTED TT CONFIGURATION
+
+=over 4
+
+=item ANYCASE
+
+This will not be supported. You will have to use the full case directive names.
+(It was in the beta code but was removed prior to release).
+
+=item WRAPPER
+
+This will be supported - just not done yet.
+
+=item ERROR
+
+This will be supported - just not done yet.
+
+=item V1DOLLAR
+
+This will not be supported.
+
+=item LOAD_TEMPLATES
+
+CGI::Ex::Template has its own mechanism for loading and storing
+compiled templates. TT would use a Template::Provider that would
+return a Template::Document. The closest thing in CGI::Ex::Template
+is the load_parsed_template method. There is no immediate plan to
+support the TT behavior.
+
+=item LOAD_PLUGINS
+
+CGI::Ex::Template uses its own mechanism for loading plugins. TT
+would use a Template::Plugins object to load plugins requested via the
+USE directive. The functionality for doing this in CGI::Ex::Template
+is contained in the list_plugins method and the play_USE method. There
+is no immediate plan to support the TT behavior.
+
+Full support is offered for the PLUGINS and LOAD_PERL configuration items.
+
+Also note that CGI::Ex::Template only natively supports the Iterator plugin.
+Any of the other plugins requested will need to provided by installing
+Template::Toolkit or the appropriate plugin module.
+
+=item LOAD_FILTERS
+
+CGI::Ex::Template uses its own mechanism for loading filters. TT
+would use the Template::Filters object to load filters requested via the
+FILTER directive. The functionality for doing this in CGI::Ex::Template
+is contained in the list_filters method and the get_variable method.
+
+Full support is offered for the FILTERS configuration item.
+
+=item TOLERANT
+
+This option is used by the LOAD_TEMPLATES and LOAD_PLUGINS options and
+is not applicable in CGI::Ex::Template.
+
+=item SERVICE
+
+CGI::Ex::Template has no concept of service (theoretically the CGI::Ex::Template
+is the "service").
+
+=item CONTEXT
+
+CGI::Ex::Template provides its own pseudo context object to plugins,
+filters, and perl blocks. The CGI::Ex::Template model doesn't really
+allow for a separate context. CGI::Ex::Template IS the context.
+
+=item STASH
+
+CGI::Ex::Template manages its own stash of variables. A pseudo stash
+object is available via the pseudo context object for use in plugins,
+filters, and perl blocks.
+
+=item PARSER
+
+CGI::Ex::Template has its own built in parser. The closest similarity is
+the parse_tree method. The output of parse_tree is an optree that is
+later run by execute_tree.
+
+=item GRAMMAR
+
+CGI::Ex::Template maintains its own grammar. The grammar is defined
+in the parse_tree method and the callbacks listed in the global
+$DIRECTIVES hashref.
+
+=back
+
+
+=head1 VARIABLE PARSE TREE
+
+CGI::Ex::Template parses templates into an tree of operations. Even
+variable access is parsed into a tree. This is done in a manner
+somewhat similar to the way that TT operates except that nested
+variables such as foo.bar|baz contain the '.' or '|' in between each
+name level. Operators are parsed and stored as part of the variable (it
+may be more appropriate to say we are parsing a term or an expression).
+
+The following table shows a variable or expression and the corresponding parsed tree
+(this is what the parse_variable method would return).
+
+ one [ 'one', 0 ]
+ one() [ 'one', [] ]
+ one.two [ 'one', 0, '.', 'two', 0 ]
+ one|two [ 'one', 0, '|', 'two', 0 ]
+ one.$two [ 'one', 0, '.', ['two', 0 ], 0 ]
+ one(two) [ 'one', [ ['two', 0] ] ]
+ one.${two().three} [ 'one', 0, '.', ['two', [], '.', 'three', 0], 0]
+ 2.34 2.34
+ "one" "one"
+ "one"|length [ \"one", 0, '|', 'length', 0 ]
+ "one $a two" [ \ [ '~', 'one ', ['a', 0], ' two' ], 0 ]
+ [0, 1, 2] [ \ [ 'array', 0, 1, 2 ], 0 ]
+ [0, 1, 2].size [ \ [ 'array', 0, 1, 2 ], 0, '.', 'size', 0 ]
+ ['a', a, $a ] [ \ [ 'array', 'a', ['a', 0], [['a', 0], 0] ], 0]
+ {a => 'b'} [ \ [ 'hash', 'a', 'b' ], 0 ]
+ {a => 'b'}.size [ \ [ 'hash', 'a', 'b' ], 0, '.', 'size', 0 ]
+ {$a => b} [ \ [ 'hash', ['a', 0], ['b', 0] ], 0 ]
+ 1 + 2 [ \ [ '+', 1, 2 ], 0]
+ a + b [ \ [ '+', ['a', 0], ['b', 0] ], 0 ]
+ a * (b + c) [ \ [ '*', ['a', 0], [ \ ['+', ['b', 0], ['c', 0]], 0 ]], 0 ]
+ (a + b) [ \ [ '+', ['a', 0], ['b', 0] ]], 0 ]
+ (a + b) * c [ \ [ '*', [ \ [ '+', ['a', 0], ['b', 0] ], 0 ], ['c', 0] ], 0 ]
+ a ? b : c [ \ [ '?', ['a', 0], ['b', 0], ['c', 0] ], 0 ]
+ a || b || c [ \ [ '||', ['a', 0], [ \ [ '||', ['b', 0], ['c', 0] ], 0 ] ], 0 ]
+ ! a [ \ [ '!', ['a', 0] ], 0 ]
+
+Some notes on the parsing.
+
+ Operators are parsed as part of the variable and become part of the variable tree.
+
+ Operators are stored in the variable tree using a reference to the arrayref - which
+ allows for quickly descending the parsed variable tree and determining that the next
+ node is an operator.
+
+ Parenthesis () can be used at any point in an expression to disambiguate precedence.
+
+ "Variables" that appear to be literal strings or literal numbers
+ are returned as the literal (no operator tree).
+
+The following perl can be typed at the command line to view the parsed variable tree:
+
+ perl -e 'use CGI::Ex::Template; print CGI::Ex::Template::dump_parse("foo.bar + 2")."\n"'
+
+Also the following can be included in a template to view the output in a template:
+
+ [% USE cet = CGI::Ex::Template %]
+ [%~ cet.dump_parse('foo.bar + 2').replace('\s+', ' ') %]
+
+
+=head1 SEMI PUBLIC METHODS
+
+The following list of methods are other interesting methods of CET that
+may be re-implemented by subclasses of CET.
+
+=over 4
+
+=item C<dump_parse>
+
+This method allows for returning a Data::Dumper dump of a parsed variable. It is mainly used for testing.
+
+=item C<exception>
+
+Creates an exception object blessed into the package listed in
+$CGI::Ex::Template::PACKAGE_EXCEPTION.
+
+=item C<execute_tree>
+
+Executes a parsed tree (returned from parse_tree)
+
+=item C<get_variable>
+
+Turns a variable identity array into the parsed variable. This
+method is also responsible for playing operators and running virtual methods
+and filters. The method could more accurately be called play_expression.
+
+=item C<include_filename>
+
+Takes a file path, and resolves it into the full filename using
+paths from INCLUDE_PATH or INCLUDE_PATHS.
+
+=item C<_insert>
+
+Resolves the file passed, and then returns its contents.
+
+=item C<list_filters>
+
+Dynamically loads the filters list from Template::Filters when a filter
+is used that is not natively implemented in CET.
+
+=item C<list_plugins>
+
+Returns an arrayref of modules that are under a base Namespace.
+
+ my @modules = @{ $self->list_plugins({base => 'Template::Plugins'}) }:
+
+=item C<load_parsed_tree>
+
+Given a filename or a string reference will return a parsed document
+hash that contains the parsed tree.
+
+ my $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");
+
+=item C<parse_args>
+
+Allow for the multitudinous ways that TT parses arguments. This allows
+for positional as well as named arguments. Named arguments can be separated with a "=" or "=>",
+and positional arguments should be separated by " " or ",". This only returns an array
+of parsed variables. Use vivify_args to translate to the actual values.
+
+=item C<parse_tree>
+
+Used by load_parsed_tree. This is the main grammar engine of the program. It
+uses method in the $DIRECTIVES hashref to parse different DIRECTIVE TYPES.
+
+=item C<parse_variable>
+
+Used to parse a variable, an expression, a literal string, or a number. It
+returns a parsed variable tree. Samples of parsed variables can be found in the VARIABLE PARSE TREE
+section.
+
+=item C<set_variable>
+
+Used to set a variable. Expects a variable identity array and the value to set. It
+will autovifiy as necessary.
+
+=item C<throw>
+
+Creates an exception object from the arguments and dies.
+
+=item C<undefined_any>
+
+Called during get_variable if a value is returned that is undefined. This could
+be used to magically create variables on the fly. This is similar to Template::Stash::undefined.
+It is suggested that undefined_get be used instead. Default behavior returns undef. You
+may also pass a coderef via the UNDEFINED_ANY configuration variable. Also, you can try using
+the DEBUG => 'undef', configuration option which will throw an error on undefined variables.
+
+=item C<undefined_get>
+
+Called when a variable is undefined during a GET directive. This is useful to
+see if a value that is about to get inserted into the text is undefined. undefined_any is a little
+too general for most cases. Also, you may pass a coderef via the UNDEFINED_GET configuration variable.
+
+=item C<vivify_args>
+
+Turns an arrayref of arg identities parsed by parse_args and turns
+them into the actual values.
+
+=back
+
+
+=head1 OTHER UTILITY METHODS
+
+The following is a brief list of other methods used by CET. Generally, these
+shouldn't be overwritten by subclasses.
+
+=over 4
+
+=item C<apply_precedence>
+
+Allows for parsed operator array to be translated to a tree based
+upon operator precedence.
+
+=item C<context>
+
+Used to create a "pseudo" context object that allows for portability
+of TT plugins, filters, and perl blocks that need a context object.
+
+=ITEM C<DEBUG>
+
+TT2 Holdover that is used once for binmode setting during a TT2 test.
+
+=item C<debug_node>
+
+Used to get debug info on a directive if DEBUG_DIRS is set.
+
+=item C<filter_*>
+
+Methods by these names implement filters that are more than one line.
+
+=item C<get_line_number_by_index>
+
+Used to turn string index position into line number
+
+=item C<interpolate_node>
+
+Used for parsing text nodes for dollar variables when interpolate is on.
+
+=item C<parse_*>
+
+Methods by these names are used by parse_tree to parse the template. These are the grammar.
+
+=item C<play_*>
+
+Methods by these names are used by execute_tree to execute the parsed tree.
+
+=item C<play_operator>
+
+Used to execute any found operators
+
+=item C<_process>
+
+Called by process and the PROCESS, INCLUDE and other directives.
+
+=item C<slurp>
+
+Reads contents of passed filename - throws file exception on error.
+
+=item C<split_paths>
+
+Used to split INCLUDE_PATH or other directives if an arrayref is not passed.
+
+=item C<_vars>
+
+Return a reference to the current stash of variables. This is currently only used
+by the pseudo context object and may disappear at some point.
+
+=item C<vmethod_*>
+
+Methods by these names implement virtual methods that are more than one line.
+
+=item C<weak_copy>
+
+Used to create a weak reference to self to avoid circular references. (this
+is needed by macros)
+
+=back
+
+
+=head1 AUTHOR
+
+Paul Seamons <paul at seamons dot com>
+
+=cut
package CGI::Ex::Validate;
-### CGI Extended Validator
+=head1 NAME
+
+CGI::Ex::Validate - another form validator - but it does javascript in parallel
+
+=cut
###----------------------------------------------------------------###
-# Copyright 2004 - Paul Seamons #
+# Copyright 2006 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
-### See perldoc at bottom
-
use strict;
use vars qw($VERSION
- $ERROR_PACKAGE
$DEFAULT_EXT
%DEFAULT_OPTIONS
$JS_URI_PATH
@UNSUPPORTED_BROWSERS
);
-$VERSION = '1.14';
+$VERSION = '2.00';
-$ERROR_PACKAGE = 'CGI::Ex::Validate::Error';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
@UNSUPPORTED_BROWSERS = (qr/MSIE\s+5.0\d/i);
};
}
-sub conf {
- my $self = shift;
- return $self->{conf_obj} ||= CGI::Ex::Conf->new({
- default_ext => $DEFAULT_EXT,
- directive => 'LAST',
- });
-}
-
### the main validation routine
sub validate {
my $self = (! ref($_[0])) ? shift->new # $class->validate
### allow for validation passed as single group hash, single group array,
### or array of group hashes or group arrays
- my @ERRORS = ();
- my %EXTRA = ();
+ my @ERRORS = ();
+ my %EXTRA = ();
my @USED_GROUPS = ();
- my $group_order = (UNIVERSAL::isa($val_hash,'HASH')) ? [$val_hash] : $val_hash;
+ my $group_order = UNIVERSAL::isa($val_hash,'HASH') ? [$val_hash] : $val_hash;
foreach my $group_val (@$group_order) {
die "Validation groups must be a hashref" if ! UNIVERSAL::isa($group_val,'HASH');
my $title = $group_val->{'group title'};
### Look for a group order and then fail back to the keys of the group.
### We will keep track of what was added using %found - the keys will
### be the hash signatures of the field_val hashes (ignore the hash internals).
- my @order = sort keys %$group_val;
+ my @field_keys;
+ my @group_keys;
+ foreach (sort keys %$group_val) {
+ /^(group|general)\s+(\w+)/ ? push(@group_keys, [$1, $2, $_]) : push(@field_keys, $_);
+ }
my $fields = $group_val->{'group fields'};
- my %found = (); # attempt to keep track of what field_vals have been added
if ($fields) { # if I passed group fields array - use it
die "'group fields' must be an arrayref" if ! UNIVERSAL::isa($fields,'ARRAY');
} else { # other wise - create our own array
my @fields = ();
- if (my $order = $group_val->{'group order'} || \@order) {
+ if (my $order = $group_val->{'group order'} || \@field_keys) {
die "Validation 'group order' must be an arrayref" if ! UNIVERSAL::isa($order,'ARRAY');
foreach my $field (@$order) {
- next if $field =~ /^(group|general)\s/;
my $field_val = exists($group_val->{$field}) ? $group_val->{$field}
: ($field eq 'OR') ? 'OR' : die "No element found in group for $field";
- $found{"$field_val"} = 1; # do this before modifying on the next line
if (ref $field_val && ! $field_val->{'field'}) {
$field_val = { %$field_val, 'field' => $field }; # copy the values to add the key
}
}
### double check which field_vals have been used so far
- foreach my $field_val (@$fields) {
- my $field = $field_val->{'field'} || die "Missing field key in validation";
- $found{"$field_val"} = 1;
- }
-
### add any remaining field_vals from the order
### this is necessary for items that weren't in group fields or group order
- foreach my $field (@order) {
- next if $field =~ /^(group|general)\s/;
+ my %found = map {$_->{'field'} => 1} @$fields;
+ foreach my $field (@field_keys) {
+ next if $found{$field};
my $field_val = $group_val->{$field};
die "Found a nonhashref value on field $field" if ! UNIVERSAL::isa($field_val, 'HASH');
- next if $found{"$field_val"}; # do before modifying ref on next line
- $field_val = { %$field_val, 'field' => $field } if ! $field_val->{'field'}; # copy the values
push @$fields, $field_val;
}
}
### add on general options, and group options if errors in group occurred
- foreach my $field (@order) {
- next if $field !~ /^(general|group)\s+(\w+)$/;
- my $key = $2;
- next if $1 eq 'group' && ($#errors == -1 || $key =~ /^(field|order|title)$/);
- $EXTRA{$key} = $group_val->{$field};
+ foreach (@group_keys) {
+ my ($type, $short_key, $full_key) = @$_;
+ next if $type eq 'group' && ($#errors == -1 || $short_key =~ /^(field|order|title)$/);
+ $EXTRA{$short_key} = $group_val->{$full_key};
}
}
### store any extra items from self
- foreach my $key (keys %$self) {
- next if $key !~ $QR_EXTRA;
- $EXTRA{$key} = $self->{$key};
- }
+ $EXTRA{$_} = $self->{$_} for grep {/$QR_EXTRA/o} keys %$self;
### allow for checking for unused keys
if ($EXTRA{no_extra_fields}) {
my $keys = $self->get_validation_keys($ref);
foreach my $key (sort keys %$form) {
next if $keys->{$key};
- $self->add_error(\@ERRORS, $key, 'no_extra_fields', {}, undef);
+ push @ERRORS, [$key, 'no_extra_fields', {}, undef];
}
}
### return what they want
if ($#ERRORS != -1) {
- my $err_obj = $ERROR_PACKAGE->new(\@ERRORS, \%EXTRA);
- die $err_obj if $EXTRA{raise_error};
+ my $err_obj = $self->new_error(\@ERRORS, \%EXTRA);
+ die $err_obj if $EXTRA{'raise_error'};
return $err_obj;
} else {
return wantarray ? () : undef;
}
}
+sub new_error {
+ my $self = shift;
+ return CGI::Ex::Validate::Error->new(@_);
+}
### allow for optional validation on groups and on individual items
sub check_conditional {
my $types = [sort keys %$field_val];
### allow for not running some tests in the cgi
- if (scalar $self->filter_type('exclude_cgi',$types)) {
+ if ($field_val->{'exclude_cgi'}) {
delete $field_val->{'was_validated'};
return wantarray ? @errors : $#errors + 1;
}
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 @match = (undef, $1, $2, $3, $4, $5); # limit to the matches
push @errors, $self->validate_buddy($form, $_field, $field_val, $N_level, \@match);
}
return wantarray ? @errors : $#errors + 1;
}
+ my $values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $form->{$field} : [$form->{$field}];
+ my $n_values = $#$values + 1;
+
### allow for default value
- foreach my $type ($self->filter_type('default', $types)) {
- if (! defined($form->{$field}) || (! ref($form->{$field}) && ! length($form->{$field}))) {
- $form->{$field} = $field_val->{$type};
+ 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'};
}
}
- my $n_values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $#{ $form->{$field} } + 1 : 1;
- my $values = ($n_values > 1) ? $form->{$field} : [$form->{$field}];
-
### allow for a few form modifiers
my $modified = 0;
foreach my $value (@$values) {
next if ! defined $value;
- if (! scalar $self->filter_type('do_not_trim',$types)) { # whitespace
+ if (! $field_val->{'do_not_trim'}) { # whitespace
$value =~ s/^\s+//;
$value =~ s/\s+$//;
$modified = 1;
}
- if (scalar $self->filter_type('to_upper_case',$types)) { # uppercase
+ if ($field_val->{'to_upper_case'}) { # uppercase
$value = uc($value);
$modified = 1;
- } elsif (scalar $self->filter_type('to_lower_case',$types)) { # lowercase
+ } elsif ($field_val->{'to_lower_case'}) { # lowercase
$value = lc($value);
$modified = 1;
}
}
# allow for inline specified modifications (ie s/foo/bar/)
- foreach my $type ($self->filter_type('replace',$types)) {
+ 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 match ($rx)";
+ die "Not sure how to parse that replace ($rx)";
}
- my ($pat,$swap,$opt) = ($2,$3,$4);
+ 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 @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;
}else{
foreach my $value (@$values) {
$value =~ s{(?$opt:$pat)}{
- my @match = (undef,$1,$2,$3,$4,$5,$6); # limit on the number of matches
+ 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;
### only continue if a validate_if is not present or passes test
my $needs_val = 0;
my $n_vif = 0;
- foreach my $type ($self->filter_type('validate_if',$types)) {
+ foreach my $type (grep {/^validate_if_?\d*$/} @$types) {
$n_vif ++;
my $ifs = $field_val->{$type};
my $ret = $self->check_conditional($form, $ifs, $N_level, $ifs_match);
### check for simple existence
### optionally check only if another condition is met
- my $is_required = '';
- foreach my $type ($self->filter_type('required',$types)) {
- next if ! $field_val->{$type};
- $is_required = $type;
- last;
- }
+ my $is_required = $field_val->{'required'} ? 'required' : '';
if (! $is_required) {
- foreach my $type ($self->filter_type('required_if',$types)) {
+ foreach my $type (grep {/^required_if_?\d*$/} @$types) {
my $ifs = $field_val->{$type};
next if ! $self->check_conditional($form, $ifs, $N_level, $ifs_match);
$is_required = $type;
last;
}
}
- if ($is_required && (! defined($form->{$field})
- || ((UNIVERSAL::isa($form->{$field},'ARRAY') && $#{ $form->{$field} } == -1)
- || ! length($form->{$field})))) {
+ if ($is_required
+ && ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length $values->[0])))) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $is_required, $field_val, $ifs_match);
+ push @errors, [$field, $is_required, $field_val, $ifs_match];
return @errors;
}
### min values check
- foreach my $type ($self->filter_type('min_values',$types)) {
- my $n = $field_val->{$type} || 0;
- if ($n_values < $n) {
- return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
- return @errors;
- }
+ my $n = exists($field_val->{'min_values'}) ? $field_val->{'min_values'} || 0 : 0;
+ if ($n_values < $n) {
+ return 1 if ! wantarray;
+ push @errors, [$field, 'min_values', $field_val, $ifs_match];
+ return @errors;
}
### max values check
- my @keys = $self->filter_type('max_values',$types);
- if ($#keys == -1) {
- push @keys, 'max_values';
- $field_val->{'max_values'} = 1;
- }
- foreach my $type (@keys) {
- my $n = $field_val->{$type} || 0;
- if ($n_values > $n) {
- return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
- return @errors;
- }
+ $field_val->{'max_values'} = 1 if ! exists $field_val->{'max_values'};
+ $n = $field_val->{'max_values'} || 0;
+ if ($n_values > $n) {
+ return 1 if ! wantarray;
+ push @errors, [$field, 'max_values', $field_val, $ifs_match];
+ return @errors;
}
### max_in_set and min_in_set checks
- foreach my $minmax (qw(min max)) {
- my @keys = $self->filter_type("${minmax}_in_set",$types);
- foreach my $type (@keys) {
+ 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;
if ( ($minmax eq 'min' && $n > 0)
|| ($minmax eq 'max' && $n < 0)) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
return @errors;
}
}
foreach my $value (@$values) {
### allow for enum types
- foreach my $type ($self->filter_type('enum',$types)) {
- my $ref = ref($field_val->{$type}) ? $field_val->{$type} : [split(/\s*\|\|\s*/,$field_val->{$type})];
+ 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 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, 'enum', $field_val, $ifs_match];
}
$content_checked = 1;
}
### field equality test
- foreach my $type ($self->filter_type('equals',$types)) {
+ foreach my $type (grep {/^equals_?\d*$/} @$types) {
my $field2 = $field_val->{$type};
my $not = ($field2 =~ s/^!\s*//) ? 1 : 0;
my $success = 0;
}
if ($not ? $success : ! $success) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
}
$content_checked = 1;
}
### length min check
- foreach my $type ($self->filter_type('min_len',$types)) {
- my $n = $field_val->{$type};
+ if (exists $field_val->{'min_len'}) {
+ my $n = $field_val->{'min_len'};
if (! defined($value) || length($value) < $n) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, 'min_len', $field_val, $ifs_match];
}
}
### length max check
- foreach my $type ($self->filter_type('max_len',$types)) {
- my $n = $field_val->{$type};
+ if (exists $field_val->{'max_len'}) {
+ my $n = $field_val->{'max_len'};
if (defined($value) && length($value) > $n) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, 'max_len', $field_val, $ifs_match];
}
}
### now do match types
- foreach my $type ($self->filter_type('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) {
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
}
} else {
if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
|| (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/))
) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
}
}
}
}
### allow for comparison checks
- foreach my $type ($self->filter_type('compare',$types)) {
+ 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) {
}
if (! $test) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
}
}
$content_checked = 1;
}
### server side sql type
- foreach my $type ($self->filter_type('sql',$types)) {
+ 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) {
if ( (! $return && $field_val->{"${type}_error_if"})
|| ($return && ! $field_val->{"${type}_error_if"}) ) {
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
}
$content_checked = 1;
}
### server side custom type
- foreach my $type ($self->filter_type('custom',$types)) {
+ 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 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ push @errors, [$field, $type, $field_val, $ifs_match];
$content_checked = 1;
}
### do specific type checks
- foreach my $type ($self->filter_type('type',$types)) {
+ foreach my $type (grep {/^type_?\d*$/} @$types) {
if (! $self->check_type($value,$field_val->{'type'},$field,$form)){
return 1 if ! wantarray;
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ 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
- foreach my $type ($self->filter_type('untaint',$types)) {
- last if $#errors != -1;
+ if ($field_val->{'untaint'} && $#errors == -1) {
if (! $content_checked) {
- $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ 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;
return wantarray ? @errors : $#errors + 1;
}
-### simple error adder abstraction
-sub add_error {
- my $self = shift;
- my $errors = shift;
- push @$errors, \@_;
-}
-
-### allow for multiple validations in the same hash
-### ie Match, Match1, Match2, Match234
-sub filter_type {
- my $self = shift;
- my $type = shift;
- my $order = shift || die "Missing order array";
- my @array = ();
- foreach (@$order) {
- push @array, $_ if /^\Q$type\E_?\d*$/;
- }
- return wantarray ? @array : $#array + 1;
-}
-
###----------------------------------------------------------------###
### used to validate specific types
### 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/[^a-z0-9.\-!&+]/;
return 0 if $value =~ m/^[\.\-]/;
return 0 if $value =~ m/[\.\-\&]$/;
return 0 if $value =~ m/(\.\-|\-\.|\.\.)/;
sub get_validation {
my $self = shift;
my $val = shift;
- return $self->conf->read($val, {html_key => 'validation'});
+ return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => $DEFAULT_EXT});
}
### returns all keys from all groups - even if group has validate_if
### spit out a chunk that will do the validation
sub generate_js {
- ### allow for some browsers to not receive the validation
- if ($ENV{HTTP_USER_AGENT}) {
- foreach (@UNSUPPORTED_BROWSERS) {
- next if $ENV{HTTP_USER_AGENT} !~ $_;
- return "<!-- JS Validation not supported in this browser $_ -->"
- }
- }
-
- 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);
- require YAML;
+ ### allow for some browsers to not receive the validation js
+ return "<!-- JS validation not supported in this browser $_ -->"
+ 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);
+
+ ### 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 $js_uri_path_validate = $JS_URI_PATH_VALIDATE || do {
+ die "Missing \$js_uri_path" if ! $js_uri_path;
+ "$js_uri_path/CGI/Ex/validate.js";
+ };
+
+ if (eval { require JSON }) {
+ my $json = JSON->new(pretty => 1)->objToJson($val_hash);
+
+ return qq{<script src="$js_uri_path_validate"></script>
+<script>
+document.validation = $json;
+if (document.check_form) document.check_form("$form_name");
+</script>
+};
- ### store any extra items from self
- my %EXTRA = ();
- foreach my $key (keys %$self) {
- next if $key !~ $QR_EXTRA;
- $EXTRA{"general $key"} = $self->{$key};
- }
+ } elsif (eval { require YAML }) {
- my $str = &YAML::Dump((scalar keys %EXTRA) ? (\%EXTRA) : () , $val_hash);
- $str =~ s/(?<!\\)\\(?=[sSdDwWbB0-9?.*+|\-\^\${}()\[\]])/\\\\/g;
- $str =~ s/\n/\\n\\\n/g; # allow for one big string
- $str =~ s/\"/\\\"/g; # quotify it
+ my $str = YAML::Dump((scalar keys %EXTRA) ? (\%EXTRA) : () , $val_hash);
+ $str =~ s/(?<!\\)\\(?=[sSdDwWbB0-9?.*+|\-\^\${}()\[\]])/\\\\/g; # fix some issues with YAML
+ $str =~ s/\n/\\n\\\n/g; # allow for one big string that flows on multiple lines
+ $str =~ s/\"/\\\"/g; # quotify it
- ### get the paths
- my $js_uri_path_yaml = $JS_URI_PATH_YAML || do {
- die "Missing \$js_uri_path" if ! $js_uri_path;
- "$js_uri_path/CGI/Ex/yaml_load.js";
- };
- my $js_uri_path_validate = $JS_URI_PATH_VALIDATE || do {
- die "Missing \$js_uri_path" if ! $js_uri_path;
- "$js_uri_path/CGI/Ex/validate.js";
- };
+ ### get the paths
+ my $js_uri_path_yaml = $JS_URI_PATH_YAML || do {
+ die "Missing \$js_uri_path" if ! $js_uri_path;
+ "$js_uri_path/CGI/Ex/yaml_load.js";
+ };
- ### return the string
- return qq{<script src="$js_uri_path_yaml"></script>
+ ### return the string
+ return qq{<script src="$js_uri_path_yaml"></script>
<script src="$js_uri_path_validate"></script>
-<script><!--
+<script>
document.validation = "$str";
if (document.check_form) document.check_form("$form_name");
-//--></script>
+</script>
};
-
+ } else {
+ return '<!-- no JSON or YAML support found for JS validation -->';
+ }
}
###----------------------------------------------------------------###
__END__
-=head1 NAME
-
-CGI::Ex::Validate - Yet another form validator - does good javascript too
-
-$Id: Validate.pm,v 1.79 2005/02/23 21:28:11 pauls Exp $
-
=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
- },
- email2 => {validate_if => 'email'
- equals => 'email'
- },
- };
-
- ### ordered
- 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',
- validate_if => 'email',
- equals => 'email',
- }
- ],
- };
-
-
- my $vob = CGI::Ex::Validate->new;
- my $errobj = $vob->validate($form, $val_hash);
+ 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,
+ },
+ email2 => {
+ validate_if => 'email',
+ equals => 'email',
+ },
+ };
+
+ ### ordered
+ 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',
+ validate_if => 'email',
+ equals => 'email',
+ }],
+ };
+
+
+ my $vob = CGI::Ex::Validate->new;
+ my $errobj = $vob->validate($form, $val_hash);
# OR #
- my $errobj = $vob->validate($form, "/somefile/somewhere.val"); # import config using yaml file
+ my $errobj = $vob->validate($form, "/somefile/somewhere.val"); # import config using yaml file
# OR #
- my $errobj = $vob->validate($form, "/somefile/somewhere.pl"); # import config using perl file
+ my $errobj = $vob->validate($form, "/somefile/somewhere.pl"); # import config using perl file
# OR #
- my $errobj = $vob->validate($form, "--- # a yaml document\n"); # import config using yaml str
+ my $errobj = $vob->validate($form, "--- # a yaml document\n"); # import config using yaml str
- 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 {
- # form passed validation
- }
+ 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 {
+ # 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);
+ ### 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);
=head1 DESCRIPTION
-CGI::Ex::Validate is yet another module used for validating input. It
-aims to have all of the power of former modules, while advancing them
-with more flexibility, external validation files, and identical
-javascript validation. CGI::Ex::Validate can work in a simple way
-like all of the other validators do. However, it also allows for
-grouping of validation items and conditional validaion of groups or
-individual items. This is more in line with the normal validation
-procedures for a website.
+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.
+
+CGI::Ex::Validate can work in a simple way like all of the other
+validators do. However, it also allows for grouping of validation
+items and conditional validation of groups or individual items. This
+is more in line with the normal validation procedures for a website.
+
+It also has full support for providing the same validation in javascript.
+It provides methods for attaching the javascript to existing forms.
=head1 METHODS
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);
+ my $ref = $self->get_validation($file);
=item C<get_validation_keys>
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);
+ my $key_hashref = $self->get_validation_keys($val_hash);
The values 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.
-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).
+Arguments are a form hashref or cgi object, a validation hashref or
+filename, and an optional what_was_validated arrayref. 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' general option
-has been set, validate will die with a CGI::Ex::validate::Error object as the value.
+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' general 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);
+ my $err_obj = $self->validate($form, $val_hash);
# OR #
- $self->{raise_error} = 1; # raise error can also be listed in the val_hash
- eval { $self->validate($form, $val_hash) };
- if ($@) {
- my $err_obj = $@;
- }
+ $self->{raise_error} = 1; # raise error can also be listed in the
+ val_hash eval { $self->validate($form, $val_hash) }; if ($@) { my
+ $err_obj = $@; }
=item C<generate_js>
-Requires YAML to work properly (see L<YAML>).
+Requires JSON or YAML to work properly (see L<JSON> or L<YAML>).
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
The javascript uri path is highly dependent upon the server
-implementation and therefore must be configured manually. It may be
+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
will default to "$JS_URI_PATH/CGI/Ex/yaml_load.js" and
"$JS_URI_PATH/CGI/Ex/validate.js".
- $self->generate_js($val_hash, 'my_form', "/cgi-bin/js")
- # would generate something like the following...
- # <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script>
- # <script src="/cgi-bin/js/CGI/Ex/validate.js"></script>
- # ... more js follows ...
+ $self->generate_js($val_hash, 'my_form', "/cgi-bin/js")
+
+ # would generate something like the following...
+
+ <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script>
+ <script src="/cgi-bin/js/CGI/Ex/validate.js"></script>
+ ... more js follows ...
+
+ $CGI::Ex::Validate::JS_URI_PATH = "/stock/js";
+ $CGI::Ex::Validate::JS_URI_PATH_YAML = "/js/yaml_load.js";
+ $self->generate_js($val_hash, 'my_form')
- $CGI::Ex::Validate::JS_URI_PATH = "/stock/js";
- $CGI::Ex::Validate::JS_URI_PATH_YAML = "/js/yaml_load.js";
- $self->generate_js($val_hash, 'my_form')
- # would generate something like the following...
- # <script src="/js/yaml_load.js"></script>
- # <script src="/stock/js/CGI/Ex/validate.js"></script>
- # ... more js follows ...
+ # would generate something like the following...
+
+ <script src="/js/yaml_load.js"></script>
+ <script src="/stock/js/CGI/Ex/validate.js"></script>
+ ... 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 servers html directory. They 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 heirchy. See L<CGI::Ex> for more details.
+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
+ #!/usr/bin/perl -w
- use strict;
- use CGI::Ex;
+ use strict;
+ use CGI::Ex;
- ### path_info should contain something like /CGI/Ex/yaml_load.js
- my $info = $ENV{PATH_INFO} || '';
- die "Invalid path" if $info !~ m|^(/\w+)+.js$|;
- $info =~ s|^/+||;
+ ### path_info should contain something like /CGI/Ex/yaml_load.js
+ my $info = $ENV{PATH_INFO} || '';
+ die "Invalid path" if $info !~ m|^(/\w+)+.js$|;
+ $info =~ s|^/+||;
- CGI::Ex->new->print_js($info);
- exit;
+ CGI::Ex->new->print_js($info);
+ exit;
The print_js method in CGI::Ex is designed to cache the javascript in
the browser (caching is suggested as they are medium sized files).
Returns a CGI::Ex object. Used internally.
-=item C<-E<gt>conf>
-
-Returns a CGI::Ex::Conf object. Used internally.
-
=back
=head1 VALIDATION HASH
-The validation hash may be passed as a perl a hashref or
-as a filename, or as a YAML document string. If it is a filename,
-it will be translated into a hash using the %EXT_HANDLER for the
-extension on the file. If there is no extension, it will use $DEFAULT_EXT
-as a default.
+The validation hash may be passed as a perl a hashref or as a
+filename, or as a YAML document string. If it is a filename, it will
+be translated into a hash using the %EXT_HANDLER for the extension on
+the file. If there is no extension, it will use $DEFAULT_EXT as a
+default.
-The validation hash may also be an arrayref of hashrefs. In this
+The validation "hash" may also be an arrayref of hashrefs. In this
case, each arrayref is treated as a group and is validated separately.
+A group can have a validate_if function that allows for that
+particular group to apply only if certain conditions are met.
=head1 GROUPS
=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},
- }
+ # 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},
- }
+ # 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},
- }
+ # 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
-Each of the individual field validation hashrefs should contain
-the types listed in VALIDATION TYPES.
+Each of the individual field validation hashrefs should contain the
+types listed in VALIDATION TYPES.
-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.
+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)],
+ 'group order' => [qw(zip OR postalcode state OR region)],
Each individual validation hashref will operate on the field contained
in the 'field' key. This key may also be a regular expression in the
=head1 VALIDATION TYPES
-The following are the available validation types. Multiple instances of
-the same type may be used by adding a number to the type (ie match, match2,
-match232, match_94). Multiple instances are validated in sorted order.
+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, match_94). Multiple
+instances are validated in sorted order. Types that allow multiple
+values are:
+
+ compare
+ custom
+ equals
+ match
+ max_in_set
+ min_in_set
+ replace
+ required_if
+ sql
+ type
+ validate_if
=over 4
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 => {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', required => 1},
- validate_if => '! name',
- # SAME as
- validate_if => {field => 'name', max_in_set => '0 of name'},
+ validate_if => '! name',
+ # SAME as
+ validate_if => {field => 'name', max_in_set => '0 of name'},
- validate_if => {field => 'country', compare => "eq US"},
- # only if country's value is equal to US
+ 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 => '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)
+ 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.
+ {
+ 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']
+ 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)],
+ validate_if => [qw(zip OR postalcode)],
=item C<required_if>
available are the same as for validate_if. This is somewhat the same
as saying:
- validate_if => 'some_condition',
- required => 1
+ validate_if => 'some_condition',
+ required => 1
- required_if => 'some_condition',
+ 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.
- {
- field => 'm/^(\w+)_pass/',
- required_if => '$1_user',
- }
-
=item C<required>
Requires the form field to have some value. If the field is not present,
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 readibility.
+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",
+ 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 occurances of whatever
+ validate_if => {field => 'whatever', max_in_set => '0 of whatever'},
+ # only run validation if there were zero occurrences of whatever
=item C<enum>
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)],
- }
+ {
+ 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
- }
+ {
+ field => 'password',
+ equals => 'password_verify',
+ },
+ {
+ field => 'domain1',
+ equals => '!domain2', # make sure the fields are not the same
+ }
=item C<min_len and max_len>
Allows for check on the length of fields
- {
- field => 'site',
- min_len => 4,
- max_len => 100,
- }
+ {
+ field => 'site',
+ min_len => 4,
+ max_len => 100,
+ }
=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\./',
- }
+ {
+ field => 'my_ip',
+ match => 'm/^\d{1,3}(\.\d{1,3})3$/',
+ match_2 => '!/^0\./ || !/^192\./',
+ }
=item C<compare>
>, <, >=, <=, !=, ==, 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',
- }
+ {
+ field => 'my_number',
+ match => 'm/^\d+$/',
+ compare1 => '> 100',
+ compare2 => '< 255',
+ compare3 => '!= 150',
+ }
=item C<sql>
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}
- }
+ {
+ 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<custom>
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;
- },
- }
+ {
+ 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 either a boolean value predermined before calling validate, or may be
+May be either a boolean value pre-determined before calling validate, or may be
section of javascript that will be eval'ed. The last value (return value) of
the eval'ed javascript will determine if validation passed. A false value indicates
the value did not pass validation. A true value indicates that it did. See
the t/samples/js_validate_3.html page for a sample of usage.
- {
- 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 => "
- 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;
- (value > ''+y+'/'+m+'/'+d) ? 1 : 0;
- ",
- custom_js_error => 'The date was not greater than today.',
- }
+ {
+ 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 => "
+ 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;
+ (value > ''+y+'/'+m+'/'+d) ? 1 : 0;
+ ",
+ custom_js_error => 'The date was not greater than today.',
+ }
=item C<type>
-
-Allows for more strict type checking. Many types will be added and
-will be available from javascript as well. Currently support types
-are CC.
-
- {
- field => 'credit_card',
- type => 'CC',
- }
+
+Allows for more strict type checking. Currently supported types
+include CC (credit card). Other types will be added upon request provided
+we can add a perl and a javascript version.
+
+ {
+ field => 'credit_card',
+ type => 'CC',
+ }
=back
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',
- },
+ {
+ 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,
- }
+ {
+ 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,
- }
+ {
+ field => 'js_var',
+ required => 1,
+ exclude_cgi => 1,
+ }
=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>
from submitted values. Set do_not_trim to 1 to allow it to
not trim.
- {field => 'foo', do_not_trim => 1}
+ {field => 'foo', do_not_trim => 1}
=item C<replace>
Pass a swap pattern to change the actual value of the form.
-Any perl regex can be passed.
+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/'}
+ {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). Maybe someday well add default_if (but that
-would require some odd syntax for both the conditional and the default).
+or zero length string).
- {field => 'country', default => 'EN'}
+ {field => 'country', default => 'EN'}
=item C<to_upper_case> and C<to_lower_case>
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 the -T switch.
+This is for use in conjunction with perl's -T switch.
=back
=head1 ERROR OBJECT
-Failed validation results in an error object blessed into the class found in
-$ERROR_PACKAGE - which defaults to CGI::Ex::Validate::Error.
+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.
=item C<as_array>
Returns an array or arrayref (depending on scalar context) of errors that
-occurred in the order that they occured. Individual groups may have a heading
+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' general option). Each error that occured is a separate
-item and are prepended with 'as_array_prefix' (which is a general option - default
+via the 'as_array_title' general option). Each error that occurred is a separate
+item and are pre-pended with 'as_array_prefix' (which is a general 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:'.
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 prepended onto the error string. If 'as_string_footer' is set, it will be
-postpended onto the error string.
+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;
'as_hash_suffix' added on as a suffix. as_hash_suffix is available as a general 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 occured to that form element.
+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 occured 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 prepended
-onto the error string, 'as_hash_footer' which will be postpended, and 'as_hash_join' which
+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'.
=item C<'general as_string_header'>
-If set, will be prepended onto the string when as_string is called.
+If set, will be pre-pended onto the string when as_string is called.
=item C<'general as_string_footer'>
-If set, will be prepended onto the string when as_string is called.
+If set, will be pre-pended onto the string when as_string is called.
=item C<'general as_hash_suffix'>
=item C<'general 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 prepended on to the error string.
+a string that will be pre-pended on to the error string.
=item C<'general as_hash_footer'>
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 AUTHOR
Paul Seamons
--- /dev/null
+package CGI::Ex::Var;
+
+=head1 NAME
+
+CGI::Ex::Var - Variable and expression parsing and execution for CGI::Ex::Template (and other takers)
+
+=head1 DESCRIPTION
+
+Experimental - The storage structure will change to match CGI::Ex::Template by the next release.
+
+=cut
+
+###----------------------------------------------------------------###
+# Copyright 2006 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
+use strict;
+
+use vars qw(
+ $SCALAR_OPS
+ $FILTER_OPS
+ $LIST_OPS
+ $HASH_OPS
+ $FILTERS
+
+ $OPERATORS
+ $OP_UNARY
+ $OP_BINARY
+ $OP_TRINARY
+
+ $QR_OP
+ $QR_OP_UNARY
+ $QR_OP_PARENED
+ $QR_COMMENTS
+ $QR_AQ_NOTDOT
+ $QR_PRIVATE
+
+ $RT_NAMESPACE
+ $RT_FILTERS
+ $RT_CONTEXT_SUB
+ $RT_DEBUG_UNDEF
+ $RT_UNDEFINED_SUB
+ $RT_OPERATOR_PRECEDENCE
+ $RT_DURING_COMPILE
+
+ $TT_FILTERS
+ );
+use constant trace => 0;
+
+BEGIN {
+ $SCALAR_OPS = {
+ chunk => \&vmethod_chunk,
+ collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
+ defined => sub { 1 },
+ indent => \&vmethod_indent,
+ 'format' => \&vmethod_format,
+ hash => sub { {value => $_[0]} },
+ html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
+ lcfirst => sub { lcfirst $_[0] },
+ length => sub { defined($_[0]) ? length($_[0]) : 0 },
+ lower => sub { lc $_[0] },
+ match => \&vmethod_match,
+ null => sub { '' },
+ remove => sub { vmethod_replace(shift, shift, '', 1) },
+ repeat => \&vmethod_repeat,
+ replace => \&vmethod_replace,
+ search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
+ size => sub { 1 },
+ split => \&vmethod_split,
+ stderr => sub { print STDERR $_[0]; '' },
+ substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
+ trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
+ ucfirst => sub { ucfirst $_[0] },
+ upper => sub { uc $_[0] },
+ uri => sub { local $_ = $_[0]; s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; $_ },
+ };
+
+ $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
+ eval => [\&filter_eval, 1],
+ evaltt => [\&filter_eval, 1],
+ file => [\&filter_redirect, 1],
+ redirect => [\&filter_redirect, 1],
+ };
+
+ $LIST_OPS = {
+ first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
+ grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
+ hash => sub { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
+ join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
+ last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
+ list => sub { $_[0] },
+ max => sub { $#{ $_[0] } },
+ merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
+ nsort => \&vmethod_nsort,
+ pop => sub { pop @{ $_[0] } },
+ push => sub { my $ref = shift; push @$ref, @_; return '' },
+ reverse => sub { [ reverse @{ $_[0] } ] },
+ shift => sub { shift @{ $_[0] } },
+ size => sub { scalar @{ $_[0] } },
+ slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
+ sort => \&vmethod_sort,
+ splice => \&vmethod_splice,
+ unique => sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
+ unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
+ };
+
+ $HASH_OPS = {
+ defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
+ delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
+ each => sub { [%{ $_[0] }] },
+ exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
+ hash => sub { $_[0] },
+ import => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
+ keys => sub { [keys %{ $_[0] }] },
+ list => sub { [$_[0]] },
+ pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] },
+ nsort => sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] },
+ size => sub { scalar keys %{ $_[0] } },
+ sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
+ values => sub { [values %{ $_[0] }] },
+ };
+
+ ### Runtime set variables that control lookups of various pieces of info
+ $RT_NAMESPACE = {};
+ $RT_FILTERS = {};
+ $RT_CONTEXT_SUB = sub { {} };
+ $RT_DEBUG_UNDEF = 0;
+ $RT_OPERATOR_PRECEDENCE = 0;
+
+ ### setup the operator parsing
+ $OPERATORS ||= [
+ # name => # order, precedence, symbols, only_in_parens, sub to create
+ [2, 96, ['**', '^', 'pow'], 0, sub {bless(shift(), 'CGI::Ex::_pow')} ],
+ [1, 93, ['!'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ],
+ [1, 93, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_negate')} ],
+ [2, 90, ['*'], 0, sub {bless(shift(), 'CGI::Ex::_mult')} ],
+ [2, 90, ['/'], 0, sub {bless(shift(), 'CGI::Ex::_div')} ],
+ [2, 90, ['div', 'DIV'], 0, sub {bless(shift(), 'CGI::Ex::_intdiv')} ],
+ [2, 90, ['%', 'mod', 'MOD'], 0, sub {bless(shift(), 'CGI::Ex::_mod')} ],
+ [2, 85, ['+'], 0, sub {bless(shift(), 'CGI::Ex::_plus')} ],
+ [2, 85, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_subtr')} ],
+ [2, 85, ['_', '~'], 0, \&_concat ],
+ [2, 80, ['<'], 0, sub {bless(shift(), 'CGI::Ex::_num_lt')} ],
+ [2, 80, ['>'], 0, sub {bless(shift(), 'CGI::Ex::_num_gt')} ],
+ [2, 80, ['<='], 0, sub {bless(shift(), 'CGI::Ex::_num_le')} ],
+ [2, 80, ['>='], 0, sub {bless(shift(), 'CGI::Ex::_num_ge')} ],
+ [2, 80, ['lt'], 0, sub {bless(shift(), 'CGI::Ex::_str_lt')} ],
+ [2, 80, ['gt'], 0, sub {bless(shift(), 'CGI::Ex::_str_gt')} ],
+ [2, 80, ['le'], 0, sub {bless(shift(), 'CGI::Ex::_str_le')} ],
+ [2, 80, ['ge'], 0, sub {bless(shift(), 'CGI::Ex::_str_ge')} ],
+ [2, 75, ['==', 'eq'], 0, sub {bless(shift(), 'CGI::Ex::_eq')} ],
+ [2, 75, ['!=', 'ne'], 0, sub {bless(shift(), 'CGI::Ex::_ne')} ],
+ [2, 70, ['&&'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ],
+ [2, 65, ['||'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ],
+ [2, 60, ['..'], 0, sub {bless(shift(), 'CGI::Ex::_range')} ],
+ [3, 55, ['?', ':'], 0, sub {bless(shift(), 'CGI::Ex::_ifelse')} ],
+ [2, 52, ['='], 1, sub {bless(shift(), 'CGI::Ex::_set')} ],
+ [1, 50, ['not', 'NOT'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ],
+ [2, 45, ['and', 'AND'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ],
+ [2, 40, ['or', 'OR'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ],
+ ];
+
+ $OP_UNARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS};
+ $OP_BINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS};
+ $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$OPERATORS};
+ sub _op_qr { # no mixed \w\W operators
+ my %used;
+ my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
+ my $chr = join '', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
+ my $word = join '|', grep {++$used{$_} < 2} grep {/^\w+$/} @_;
+ $chr = "[$chr]" if $chr;
+ $word = "\\b(?:$word)\\b" if $word;
+ return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
+ }
+ sub _build_op_qr { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops
+ sub _build_op_qr_unary { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] == 1 } @$OPERATORS) } # unary operators
+ sub _build_op_qr_paren { _op_qr(sort map {@{ $_->[2] }} grep { $_->[3]} @$OPERATORS) } # paren
+ $QR_OP ||= _build_op_qr();
+ $QR_OP_UNARY ||= _build_op_qr_unary();
+ $QR_OP_PARENED ||= _build_op_qr_paren();
+
+ $QR_COMMENTS = '(?-s: \# .* \s*)*';
+ $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
+ $QR_PRIVATE = qr/^_/;
+};
+
+###----------------------------------------------------------------###
+
+sub _var { return bless(shift(), __PACKAGE__ ) }
+sub _literal { return bless(shift(), 'CGI::Ex::_literal') }
+sub _hash { return bless(shift(), 'CGI::Ex::_hash' ) }
+sub _array { return bless(shift(), 'CGI::Ex::_array' ) }
+sub _concat { return bless(shift(), 'CGI::Ex::_concat' ) }
+sub _autobox { return bless(shift(), 'CGI::Ex::_autobox') }
+sub _not { return bless(shift(), 'CGI::Ex::_not' ) }
+
+sub throw {
+ require CGI::Ex::Template;
+ CGI::Ex::Template->throw(@_);
+}
+
+###----------------------------------------------------------------###
+
+sub parse_exp {
+ my $str_ref = shift;
+ my $ARGS = shift || {};
+
+ ### allow for custom auto_quoting (such as hash constructors)
+ if ($ARGS->{'auto_quote'}) {
+ if ($$str_ref =~ $ARGS->{'auto_quote'}) {
+ my $str = $1;
+ substr($$str_ref, 0, length($str), '');
+ $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
+ return $str;
+ ### allow for auto-quoted $foo or ${foo.bar} type constructs
+ } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
+ || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ return parse_exp(\$name);
+ }
+ }
+
+ my $copy = $$str_ref; # copy while parsing to allow for errors
+
+ ### test for leading unary operators
+ my $has_unary;
+ if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) {
+ return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+ $has_unary = $1;
+ }
+
+ my @var;
+ my $is_literal;
+ my $is_construct;
+ my $is_namespace;
+
+ ### allow for numbers
+ if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) {
+ my $number = $1;
+ push @var, _literal(\ $number);
+ $is_literal = 1;
+
+ ### looks like a normal variable start
+ } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
+ push @var, $1;
+ $is_namespace = 1 if $RT_NAMESPACE->{$1};
+
+ ### allow for literal strings
+ } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
+ if ($1 eq "'") { # no interpolation on single quoted strings
+ my $str = $2;
+ $str =~ s{ \\\' }{\'}xg;
+ push @var, _literal(\ $str);
+ $is_literal = 1;
+ } else {
+ my $str = $2;
+ $str =~ s/\\n/\n/g;
+ $str =~ s/\\t/\t/g;
+ $str =~ s/\\r/\r/g;
+ $str =~ s/\\([\"\$])/$1/g;
+ my @pieces = $ARGS->{'auto_quote'}
+ ? split(m{ (\$\w+ | \$\{ [^\}]+ \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
+ : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
+ my $n = 0;
+ foreach my $piece (@pieces) {
+ next if ! ($n++ % 2);
+ next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
+ && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
+ my $name = $1;
+ $piece = parse_exp(\$name);
+ }
+ @pieces = grep {defined && length} @pieces;
+ if (@pieces == 1 && ! ref $pieces[0]) {
+ push @var, _literal(\ $pieces[0]);
+ $is_literal = 1;
+ } elsif (! @pieces) {
+ my $str = '';
+ push @var, _literal(\ $str);
+ $is_literal = 1;
+ } else {
+ push @var, _concat(\@pieces);
+ $is_construct = 1;
+ }
+ }
+ if ($ARGS->{'auto_quote'}){
+ $$str_ref = $copy;
+ return ${ $var[0] } if $is_literal;
+ return _var([@var, 0]);
+ }
+
+ ### allow for leading $foo or ${foo.bar} type constructs
+ } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
+ || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ push @var, parse_exp(\$name);
+
+ ### looks like an array constructor
+ } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
+ local $RT_OPERATOR_PRECEDENCE = 0; # reset presedence
+ my $arrayref = [];
+ while (defined(my $var = parse_exp(\$copy))) {
+ push @$arrayref, $var;
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ }
+ $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
+ || throw('parse.missing.square', "Missing close \]", undef, length($$str_ref) - length($copy));
+ push @var, _array($arrayref);
+ $is_construct = 1;
+
+ ### looks like a hash constructor
+ } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
+ local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
+ my $hashref = [];
+ while (defined(my $key = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
+ $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
+ my $val = parse_exp(\$copy);
+ push @$hashref, $key, $val;
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ }
+ $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
+ || throw('parse.missing.curly', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
+ push @var, _hash($hashref);
+ $is_construct = 1;
+
+ ### looks like a paren grouper
+ } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
+ my $var = parse_exp(\$copy, {allow_parened_ops => 1});
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ push @var, $var;
+ $is_construct = 1;
+
+ ### nothing to find - return failure
+ } else {
+ return;
+ }
+
+ return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+
+ ### looks for args for the initial
+ if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
+ my $args = parse_args(\$copy);
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ push @var, $args;
+ } else {
+ push @var, 0;
+ }
+
+ ### allow for nested items
+ while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
+ push(@var, $1) if ! $ARGS->{'no_dots'};
+
+ ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
+ if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
+ || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
+ my $name = $1;
+ my $var = parse_exp(\$name);
+ push @var, $var;
+ } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
+ push @var, $1;
+ } else {
+ throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
+ }
+
+ ### looks for args for the nested item
+ if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
+ my $args = parse_args(\$copy);
+ $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
+ || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ push @var, $args;
+ } else {
+ push @var, 0;
+ }
+
+ }
+
+ ### flatten literals and constants as much as possible
+ my $var;
+ if (@var == 2) {
+ if ($is_literal) {
+ $var = ${ $var[0] };
+ } elsif ($is_construct) {
+ $var = $var[0];
+ } else {
+ $var = _var(\@var);
+ }
+ } else {
+ if ($is_construct && ! $var[0]->does_autobox) {
+ $var[0] = _autobox([$var[0]]);
+ }
+
+ if ($is_namespace) { # attempt to "fold" constant variables into the parse tree
+ local $RT_DURING_COMPILE = 1;
+ $var = _var(\@var)->call({});
+ } else {
+ $var = _var(\@var);
+ }
+ }
+
+ ### allow for all "operators"
+ if (! $RT_OPERATOR_PRECEDENCE) {
+ my $tree;
+ my $found;
+ while ($copy =~ s{ ^ ($QR_OP) \s* $QR_COMMENTS }{}ox ## look for operators - then move along
+ || ($ARGS->{'allow_parened_ops'}
+ && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) {
+ local $RT_OPERATOR_PRECEDENCE = 1;
+ my $op = $1;
+ my $var2 = parse_exp(\$copy);
+
+ ### allow for unary operator precedence
+ if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) {
+ if ($tree) {
+ if (@$tree == 2) { # only one operator - keep simple things fast
+ $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
+ } else {
+ unshift @$tree, $var;
+ $var = apply_precedence($tree, $found);
+ }
+ undef $tree;
+ undef $found;
+ }
+ $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
+ undef $has_unary;
+ }
+
+ ### add the operator to the tree
+ push (@{ $tree ||= [] }, $op, $var2);
+ my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op};
+ $found->{$op} = $ref->[1];
+ }
+
+ ### if we found operators - tree the nodes by operator precedence
+ if ($tree) {
+ if (@$tree == 2 && $OP_BINARY->{$tree->[0]}) { # only one operator - keep simple things fast
+ $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
+ } else {
+ unshift @$tree, $var;
+ $var = apply_precedence($tree, $found);
+ }
+ }
+ }
+
+ ### allow for unary on non-chained variables
+ if ($has_unary) {
+ $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
+ }
+
+ $$str_ref = $copy; # commit the changes
+ return $var;
+}
+
+### this is used to put the parsed variables into the correct operations tree
+sub apply_precedence {
+ my ($tree, $found) = @_;
+
+ my @var;
+ my $trees;
+ ### look at the operators we found in the order we found them
+ for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) {
+ local $found->{$op};
+ delete $found->{$op};
+ my @trees;
+ my @trinary;
+
+ ### split the array on the current operator
+ for (my $i = 0; $i <= $#$tree; $i ++) {
+ my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] };
+ next if $tree->[$i] ne $op && ! $is_trinary;
+ push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
+ push @trinary, $tree->[0] if $is_trinary;
+ shift @$tree; # pull off the operator
+ $i = -1;
+ }
+ next if ! @trees; # this iteration didn't have the current operator
+ push @trees, $tree if scalar @$tree; # elements after last operator
+
+ ### now - for this level split on remaining operators, or add the variable to the tree
+ for my $node (@trees) {
+ if (@$node == 1) {
+ $node = $node->[0]; # single item - its not a tree
+ } elsif (@$node == 3) {
+ my $ref = $OP_BINARY->{$node->[1]} || $OP_TRINARY->{$node->[1]};
+ $node = $ref->[4]->([$node->[0], $node->[2]]); # single operator - put it straight on
+ } else {
+ $node = apply_precedence($node, $found); # more complicated - recurse
+ }
+ }
+
+ ### return binary
+ if ($OP_BINARY->{$op}) {
+ my $val = $trees[0];
+ $val = $OP_BINARY->{$op}->[4]->([$val, $trees[$_]]) for 1 .. $#trees;
+ return $val;
+ }
+
+ ### return simple trinary
+ if (@trinary == 2) {
+ return $OP_TRINARY->{$op}->[4]->(\@trees);
+ }
+
+ ### reorder complex trinary - rare case
+ while ($#trinary >= 1) {
+ ### if we look starting from the back - the first lead trinary op will always be next to its matching op
+ for (my $i = $#trinary; $i >= 0; $i --) {
+ next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i];
+ my ($op, $op2) = splice @trinary, $i, 2, (); # remove the found pair of operators
+ my $node = $OP_TRINARY->{$op}->[4]->([@trees[$i .. $i + 2]]);
+ splice @trees, $i, 3, $node; # replace the previous 3 pieces with the one new node
+ }
+ }
+ return $trees[0]; # at this point the trinary has been reduced to a single operator
+
+ }
+
+ throw('parse', "Couldn't apply precedence");
+}
+
+### look for arguments - both positional and named
+sub parse_args {
+ my $str_ref = shift;
+ my $ARGS = shift || {};
+ my $copy = $$str_ref;
+
+ my @args;
+ my @named;
+ while (length $$str_ref) {
+ my $copy = $$str_ref;
+ if (defined(my $name = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
+ && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
+ throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
+ my $val = parse_exp(\$copy);
+ $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ push @named, $name, $val;
+ $$str_ref = $copy;
+ } elsif (defined(my $arg = parse_exp($str_ref))) {
+ push @args, $arg;
+ $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ } else {
+ last;
+ }
+ }
+
+ ### allow for named arguments to be added also
+ push @args, _hash(\@named) if scalar @named;
+
+ return \@args;
+}
+
+sub get_exp { ref($_[0]) ? $_[0]->call($_[1]) : $_[0] }
+
+sub set_exp {
+ my $var = shift;
+ $var = _var([$var, 0]) if ! ref $var; # allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
+ return $var->set($_[0], $_[1]);
+}
+
+
+sub dump_parse {
+ my $str = shift;
+ require Data::Dumper;
+ return Data::Dumper::Dumper(parse_exp(\$str));
+}
+
+sub dump_get {
+ my ($str, $hash) = @_;
+ require Data::Dumper;
+ return Data::Dumper::Dumper(get_exp(parse_exp(\$str), $hash));
+}
+
+sub dump_set {
+ my ($str, $val, $hash) = @_;
+ $hash ||= {};
+ require Data::Dumper;
+ set_exp(parse_exp(\$str), $val, $hash);
+ return Data::Dumper::Dumper($hash);
+}
+
+sub vivify_args {
+ my $vars = shift;
+ my $hash = shift;
+ return [map {get_exp($_, $hash)} @$vars];
+}
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift;
+ return bless $_[0], $class;
+}
+
+sub does_autobox { 0 }
+
+sub call {
+ my $self = shift;
+ my $hash = shift || {};
+ my $i = 0;
+
+ ### determine the top level of this particular variable access
+ my $ref = $self->[$i++];
+ my $args = $self->[$i++];
+ warn "CGI::Ex::Var::call: begin \"$ref\"\n" if trace;
+
+ if (ref $ref) {
+ if ($ref->does_autobox) {
+ $ref = $ref->call($hash);
+ } else {
+ $ref = $ref->call($hash);
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ $ref = $hash->{$ref};
+ }
+ } else {
+ if ($RT_DURING_COMPILE) {
+ $ref = $RT_NAMESPACE->{$ref};
+ } else {
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ $ref = $hash->{$ref};
+ }
+ }
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the returned thing was a code
+ if (UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? (map {get_exp($_, $hash)} @$args) : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### descend one chained level
+ last if $i >= $#$self;
+ my $was_dot_call = $self->[$i++] eq '.';
+ my $name = $self->[$i++];
+ my $args = $self->[$i++];
+ warn "CGI::Ex::Var::get_exp: nested \"$name\"\n" if trace;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ $name = $name->call($hash);
+ if (! defined $name) {
+ $ref = undef;
+ last;
+ }
+ }
+
+ if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? (map {get_exp($_, $hash)} @$args) : ());
+
+ } elsif (my $filter = $RT_FILTERS->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || list_filters()->{$name}) { # filter defined in Template::Filters
+
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
+
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($RT_CONTEXT_SUB->(), $args ? (map {get_exp($_, $hash)} @$args) : ());
+ if (! $sub && $err) {
+ throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $self = [$name, 0, '|', @$filter, @{$self}[$i..$#$self]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$self->[$i - 5] || ''}) {
+ throw('filter', "invalid FILTER entry for '".$self->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
+
+ } else {
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? (map {get_exp($_, $hash)} @$args) : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
+ } elsif ($RT_DURING_COMPILE) {
+ return $self; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
+ }
+ }
+ }
+
+ } # end of while
+
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($RT_DEBUG_UNDEF) {
+ my $chunk = $self->[$i - 2];
+ $chunk = $chunk->call($hash) if ref $chunk;
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($self);
+ }
+ }
+
+ return $ref;
+}
+
+sub undefined_any { $RT_UNDEFINED_SUB ? $RT_UNDEFINED_SUB->(@_) : undef }
+
+sub set {
+ my ($self, $val, $hash) = @_;
+ my $i = 0;
+
+ ### determine the top level of this particular variable access
+ my $ref = $self->[$i++];
+ my $args = $self->[$i++];
+
+ if (ref $ref) {
+ $ref = $ref->call($hash);
+ return if ! defined $ref;
+ }
+
+ return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+
+ if ($#$self <= $i) {
+ $hash->{$ref} = $val;
+ return;
+ } else {
+ $ref = $hash->{$ref} ||= {};
+ }
+
+ ### let the top level thing be a code block
+ return if UNIVERSAL::isa($ref, 'CODE');
+
+ ### vivify the chained levels
+ while (defined $ref && $#$self > $i) {
+ my $was_dot_call = $self->[$i++] eq '.';
+ my $name = $self->[$i++];
+ my $args = $self->[$i++];
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ $name = $name->call($hash);
+ if (! defined $name) {
+ $ref = undef;
+ last;
+ }
+ }
+
+ if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ return;
+ }
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my $lvalueish;
+ my @args = $args ? (map {get_exp($_, $hash)} @$args) : ();
+ if ($i >= $#$self) {
+ $lvalueish = 1;
+ push @args, $val;
+ }
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ }
+ return if $lvalueish;
+ next;
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($#$self <= $i) {
+ $ref->{$name} = $val;
+ return;
+ } else {
+ $ref = $ref->{$name} ||= {};
+ next;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ if ($#$self <= $i) {
+ $ref->[$name] = $val;
+ return;
+ } else {
+ $ref = $ref->[$name] ||= {};
+ next;
+ }
+ } else {
+ return;
+ }
+
+ ### scalar access
+ } elsif (! ref($ref) && defined($ref)) {
+ return;
+ }
+
+ ### check at each point if the returned thing was a code
+ if (defined($ref) && UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? (map {get_exp($_, $hash)} @$args) : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ return;
+ }
+ }
+
+ }
+
+ return $ref;
+}
+
+###----------------------------------------------------------------###
+### filters and vmethod definition
+
+sub list_filters {
+ return $TT_FILTERS ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
+}
+
+sub vmethod_chunk {
+ my $str = shift;
+ my $size = shift || 1;
+ my @list;
+ if ($size < 0) { # chunk from the opposite end
+ $str = reverse $str;
+ $size = -$size;
+ unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
+ } else {
+ push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
+ }
+ return \@list;
+}
+
+sub vmethod_indent {
+ my $str = shift; $str = '' if ! defined $str;
+ my $pre = shift; $pre = 4 if ! defined $pre;
+ $pre = ' ' x $pre if $pre =~ /^\d+$/;
+ $str =~ s/^/$pre/mg;
+ return $str;
+}
+
+sub vmethod_format {
+ my $str = shift; $str = '' if ! defined $str;
+ my $pat = shift; $pat = '%s' if ! defined $pat;
+ return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+}
+
+sub vmethod_match {
+ my ($str, $pat, $global) = @_;
+ return [] if ! defined $str || ! defined $pat;
+ my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
+ return (@res >= 2) ? \@res : (@res == 1) ? $res[0] : '';
+}
+
+sub vmethod_nsort {
+ my ($list, $field) = @_;
+ return defined($field)
+ ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
+ : UNIVERSAL::can($_, $field) ? $_->$field()
+ : $_)]} @$list ]
+ : [sort {$a <=> $b} @$list];
+}
+
+sub vmethod_repeat {
+ my ($str, $n, $join) = @_;
+ return if ! length $str;
+ $n = 1 if ! defined($n) || ! length $n;
+ $join = '' if ! defined $join;
+ return join $join, ($str) x $n;
+}
+
+### This method is a combination of my submissions along
+### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
+sub vmethod_replace {
+ my ($text, $pattern, $replace, $global) = @_;
+ $text = '' unless defined $text;
+ $pattern = '' unless defined $pattern;
+ $replace = '' unless defined $replace;
+ $global = 1 unless defined $global;
+ my $expand = sub {
+ my ($chunk, $start, $end) = @_;
+ $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
+ $1 ? $1
+ : ($2 > $#$start || $2 == 0) ? ''
+ : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
+ }exg;
+ $chunk;
+ };
+ if ($global) {
+ $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
+ } else {
+ $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
+ }
+ return $text;
+}
+
+sub vmethod_sort {
+ my ($list, $field) = @_;
+ return defined($field)
+ ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
+ : UNIVERSAL::can($_, $field) ? $_->$field()
+ : $_)]} @$list ]
+ : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
+}
+
+sub vmethod_splice {
+ my ($ref, $i, $len, @replace) = @_;
+ @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
+ if (defined $len) {
+ return [splice @$ref, $i || 0, $len, @replace];
+ } else {
+ return [splice @$ref, $i || 0];
+ }
+}
+
+sub vmethod_split {
+ my ($str, $pat, @args) = @_;
+ $str = '' if ! defined $str;
+ return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
+}
+
+sub filter_eval {
+ my $context = shift;
+ return sub {
+ my $text = shift;
+ return $context->process(\$text);
+ };
+}
+
+sub filter_redirect {
+ my ($context, $file, $options) = @_;
+ my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
+
+ return sub {
+ my $text = shift;
+ if (! -d $path) {
+ require File::Path;
+ File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
+ }
+ local *FH;
+ open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
+ if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
+ if (+$bm == 1) { binmode FH }
+ else { binmode FH, $bm}
+ }
+ print FH $text;
+ close FH;
+ return '';
+ };
+}
+
+###----------------------------------------------------------------###
+### "here be dragons"
+
+package CGI::Ex::_literal;
+sub call { ${ $_[0] } }
+sub set {}
+sub does_autobox { 1 }
+
+package CGI::Ex::_autobox;
+sub call { $_[0]->[0]->call($_[1]) }
+sub set {}
+sub does_autobox { 1 }
+
+package CGI::Ex::_concat;
+sub call { join "", grep {defined} map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] } }
+sub set {}
+sub does_autobox { 1 }
+
+package CGI::Ex::_hash;
+sub call { return {map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }} }
+sub set {}
+sub does_autobox { 1 }
+
+package CGI::Ex::_array;
+sub call { return [map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }] }
+sub set {}
+sub does_autobox { 1 }
+
+package CGI::Ex::_set;
+sub call {
+ my ($var, $val) = @{ $_[0] };
+ $val = CGI::Ex::Var::get_exp($val, $_[1]);
+ CGI::Ex::Var::set_exp($var, $val, $_[1]);
+ return $val;
+}
+sub set {}
+sub does_autobox { 1 }
+
+
+package CGI::Ex::_not;
+sub call { ! (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || '' }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_and;
+sub call { (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) && (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_or;
+sub call { ((ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])) || '' }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_ifelse;
+sub call {
+ (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])
+ ? (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])
+ : (ref($_[0]->[2]) ? $_[0]->[2]->call($_[1]) : $_[0]->[2]);
+}
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_str_lt;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) lt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_str_gt;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) gt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_str_le;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) le (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_str_ge;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ge (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_eq;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) eq (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_ne;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ne (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_negate;
+sub call { local $^W; 0 - (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_pow;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ** (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_mult;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) * (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_div;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_intdiv;
+sub call { local $^W; int( (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) ) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_mod;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) % (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_plus;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) + (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_subtr;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) - (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_num_lt;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) < (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_num_gt;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) > (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_num_le;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) <= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_num_ge;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) >= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
+sub set {}
+sub does_autobox { 0 }
+
+package CGI::Ex::_range;
+sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || 0 .. (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) || 0 }
+sub set {}
+sub does_autobox { 0 }
+
+###----------------------------------------------------------------###
+
+=head1 DESCRIPTION
+
+Experimental. An attempt for abstracting out a fast parser and hash
+from CGI::Ex::Template. It is functional - but currently too
+cumbersome for use in CET.
+
+=cut
+
+1;
/**----------------------------------------------------------------***
-* Copyright 2004 - Paul Seamons *
+* Copyright 2006 - Paul Seamons *
* Distributed under the Perl Artistic License without warranty *
* Based upon CGI/Ex/Validate.pm v1.14 from Perl *
* For instructions on usage, see perldoc of CGI::Ex::Validate *
***----------------------------------------------------------------**/
-// $Revision: 1.31 $
+// $Revision: 1.34 $
function Validate () {
this.error = vob_error;
/// look for a group order and then fail back to the keys of the group
var fields = group_val['group fields'];
var order = new Array();
- for (var key in group_val) order[order.length] = key;
+ for (var key in group_val) {
+ if (key == 'extend') continue; // Protoype Array() fix
+ order[order.length] = key;
+ }
order = order.sort();
if (fields) {
if (typeof(fields) != 'object' || ! fields.length)
/// store any extra items from self
for (var key in this) {
+ if (key == 'extend') continue; // Protoype Array() fix
if (! key.match('_error$')
&& ! key.match('^(raise_error|as_hash_\\w+|as_array_\\w+|as_string_\\w+)$')) continue;
EXTRA[key] = this[key];
var errors = new Array();
var types = new Array();
- for (var key in field_val) types[types.length] = key;
+ for (var key in field_val) {
+ if (key == 'extend') continue; // Protoype Array() fix
+ types[types.length] = key;
+ }
types = types.sort();
/// allow for not running some tests in the cgi
/// the "username" portion of an email address
} else if (type == 'LOCAL_PART') {
if (typeof(value) == 'undefined' || ! value.length) return 0;
- if (! value.match('[^a-z0-9.\\-!&]')) return 0;
- if (! value.match('^[.\\-]')) return 0;
- if (! value.match('[.\\-&]$')) return 0;
+ if (! value.match('[^a-z0-9.\\-!&+]')) return 0;
+ if (! value.match('^[.\\-]')) return 0;
+ if (! value.match('[.\\-&]$')) return 0;
if (! value.match('(\\.-|-\\.|\\.\\.)')) return 0;
/// standard IP address
if (joiner) {
var header = eob_get_val('as_hash_header', extra2, extra1, '');
var footer = eob_get_val('as_hash_footer', extra2, extra1, '');
- for (var key in ret) ret[key] = header + ret[key].join(joiner) + footer;
+ for (var key in ret) {
+ if (key == 'extend') continue; // Protoype Array() fix
+ ret[key] = header + ret[key].join(joiner) + footer;
+ }
}
return ret;
// undo previous inline
if (document.did_inline) {
for (var key in document.did_inline) {
+ if (key == 'extend') continue; // Protoype Array() fix
var el = document.getElementById(key);
if (el) el.innerHTML = '';
}
var d = document.did_inline = new Array();
var hash = err_obj.as_hash();
for (var key in hash) {
+ if (key == 'extend') continue; // Protoype Array() fix
var el = document.getElementById(key);
if (el) el.innerHTML = hash[key];
d[key] = 1;
/**----------------------------------------------------------------***
-* Copyright 2003 - Paul Seamons *
+* Copyright 2006 - Paul Seamons *
* Distributed under the Perl Artistic License without warranty *
* Based upon YAML.pm v0.35 from Perl *
***----------------------------------------------------------------**/
-// $Revision: 1.16 $
+// $Revision: 1.17 $
// allow for missing methods in ie 5.0
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_auth.pl - Test relative performance of CGI::Ex::Auth
+
+=head1 SAMPLE OUTPUT
+
+ Benchmark: running cookie_bad, cookie_good, cookie_good2, form_bad, form_good, form_good2, form_good3, form_good4 for at least 2 CPU seconds...
+ cookie_bad: 3 wallclock secs ( 2.15 usr + 0.00 sys = 2.15 CPU) @ 6819.07/s (n=14661)
+ cookie_good: 3 wallclock secs ( 2.01 usr + 0.08 sys = 2.09 CPU) @ 6047.85/s (n=12640)
+ cookie_good2: 2 wallclock secs ( 1.95 usr + 0.10 sys = 2.05 CPU) @ 5087.80/s (n=10430)
+ form_bad: 3 wallclock secs ( 2.19 usr + 0.00 sys = 2.19 CPU) @ 6542.92/s (n=14329)
+ form_good: 3 wallclock secs ( 2.08 usr + 0.05 sys = 2.13 CPU) @ 6108.45/s (n=13011)
+ form_good2: 3 wallclock secs ( 2.05 usr + 0.09 sys = 2.14 CPU) @ 5023.36/s (n=10750)
+ form_good3: 3 wallclock secs ( 2.17 usr + 0.01 sys = 2.18 CPU) @ 7040.83/s (n=15349)
+ form_good4: 3 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 1947.64/s (n=4129)
+ Rate form_good4 form_good2 cookie_good2 cookie_good form_good form_bad cookie_bad form_good3
+ form_good4 1948/s -- -61% -62% -68% -68% -70% -71% -72%
+ form_good2 5023/s 158% -- -1% -17% -18% -23% -26% -29%
+ cookie_good2 5088/s 161% 1% -- -16% -17% -22% -25% -28%
+ cookie_good 6048/s 211% 20% 19% -- -1% -8% -11% -14%
+ form_good 6108/s 214% 22% 20% 1% -- -7% -10% -13%
+ form_bad 6543/s 236% 30% 29% 8% 7% -- -4% -7%
+ cookie_bad 6819/s 250% 36% 34% 13% 12% 4% -- -3%
+ form_good3 7041/s 262% 40% 38% 16% 15% 8% 3% --
+
+=cut
+
+use strict;
+use Benchmark qw(cmpthese timethese);
+use CGI::Ex::Auth;
+use CGI::Ex::Dump qw(debug);
+
+{
+ package Auth;
+ use base qw(CGI::Ex::Auth);
+ use strict;
+ use vars qw($printed $set_cookie $deleted_cookie);
+
+ sub login_print { $printed = 1 }
+ sub set_cookie { $set_cookie = 1 }
+ sub delete_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'] }
+}
+
+{
+ package Aut2;
+ use base qw(Auth);
+ use vars qw($crypt);
+ BEGIN { $crypt = crypt('123qwe', 'SS') };
+ sub use_crypt { 1 }
+ sub get_pass_by_user { $crypt }
+}
+
+{
+ package Aut3;
+ use base qw(Auth);
+ sub use_blowfish { "This_is_my_key" }
+ sub use_base64 { 0 }
+ sub use_plaintext { 1 }
+}
+
+my $token = Auth->new->generate_token({user => 'test', real_pass => '123qwe', use_base64 => 1});
+my $token2 = Aut3->new->generate_token({user => 'test', real_pass => '123qwe'});
+
+my $form_bad = { cea_user => 'test', cea_pass => '123qw' };
+my $form_good = { cea_user => 'test', cea_pass => '123qwe' };
+my $form_good2 = { cea_user => $token };
+my $form_good3 = { cea_user => 'test/123qwe' };
+my $form_good4 = { cea_user => $token2 };
+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_good4 { Aut3->get_valid_auth({form => {%$form_good4}, 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::delete_cookie = 0;
+die "Didn't get good auth" if ! form_good();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+debug form_good2(), (my $e = $@);
+die "Didn't get good auth" if ! form_good2();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+die "Didn't get good auth" if ! form_good3();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+debug form_good4(), (my $e = $@);
+die "Didn't get good auth" if ! form_good4();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+die "Didn't get bad auth" if form_bad();
+die "printed was not set" if ! $Auth::printed;
+die "set_cookie called" if $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+die "Didn't get good auth" if ! cookie_good();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+die "Didn't get good auth" if ! cookie_good2();
+die "printed was set" if $Auth::printed;
+die "set_cookie not called" if ! $Auth::set_cookie;
+die "delete_cookie was called" if $Auth::deleted_cookie;
+
+$Auth::printed = $Auth::set_cookie = $Auth::delete_cookie = 0;
+die "Didn't get bad auth" if cookie_bad();
+die "printed was not set" if ! $Auth::printed;
+die "set_cookie called" if $Auth::set_cookie;
+die "delete_cookie was not called" if ! $Auth::deleted_cookie;
+
+print "Ready\n";
+
+my $r = eval { timethese (-2, {
+ form_good => \&form_good,
+ form_good2 => \&form_good2,
+ form_good3 => \&form_good3,
+ form_good4 => \&form_good4,
+ form_bad => \&form_bad,
+ cookie_good => \&cookie_good,
+ cookie_good2 => \&cookie_good2,
+ cookie_bad => \&cookie_bad,
+}) };
+if (! $r) {
+ debug "$@";
+ next;
+}
+eval { cmpthese $r };
--- /dev/null
+#!/usr/bin/perl -w
+
+# Benchmark: timing 1000 iterations of cgix_func, cgix_meth, hfif...
+# cgix_func: 1 wallclock secs ( 1.41 usr + 0.01 sys = 1.42 CPU) @ 704.23/s (n=1000)
+# cgix_meth: 2 wallclock secs ( 1.47 usr + 0.00 sys = 1.47 CPU) @ 680.27/s (n=1000)
+# hfif: 8 wallclock secs ( 8.34 usr + 0.04 sys = 8.38 CPU) @ 119.33/s (n=1000)
+# Rate hfif cgix_meth cgix_func
+# hfif 119/s -- -82% -83%
+# cgix_meth 680/s 470% -- -3%
+# cgix_func 704/s 490% 4% --
+
+use strict;
+
+use Benchmark qw(cmpthese);
+use HTML::FillInForm;
+use CGI::Ex;
+
+my $t = q{
+
+<!-- This is another thing -->
+<html>
+<form name=foo>
+
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+<br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br><br>
+
+<input type=text name=foo value="wow">
+
+<input type=password name="pass" value="">
+
+<select name=garbage>
+ <option value=lid>Lid</option>
+ <option value=can>Can</option>
+ <option value=wheel>Wheel</option>
+ <option value=truck>Truck</option>
+</select>
+
+<!-- </form> -->
+
+<textarea name=Mighty></textarea>
+
+</form>
+
+</html>
+};
+
+my $form = {
+ foo => "bar",
+ pass => "word",
+ garbage => ['can','lid'],
+ Mighty => 'ducks',
+};
+
+
+my $fif = HTML::FillInForm->new;
+my $fo = CGI::Ex->new;
+$fo->{remove_comments} = 1;
+
+my $x = $fo->fill(scalarref => \$t,
+ fdat => $form,
+ target => 'foo',
+ );
+#print $x;
+#exit;
+
+cmpthese(-2, {
+ hfif => sub {
+ my $copy = $t;
+ my $new = $fif->fill(scalarref => \$copy,
+ fdat => $form,
+ target => 'foo',
+ );
+ },
+ cgix_meth => sub {
+ my $copy = $t;
+ $fo->fill(scalarref => \$copy,
+ fdat => $form,
+ target => 'foo',
+ );
+ },
+ cgix_func => sub {
+ my $copy = $t;
+ &CGI::Ex::Fill::form_fill(\$copy, $form, 'foo');
+ },
+});
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use vars qw($PLACEHOLDER);
+use Benchmark qw(cmpthese);
+use CGI::Ex::Conf;
+use POSIX qw(tmpnam);
+
+$PLACEHOLDER = chr(186).'~'.chr(186);
+
+my $n = -2;
+
+my $cob = CGI::Ex::Conf->new;
+my %files = ();
+
+###----------------------------------------------------------------###
+
+# Rate yaml2 yaml xml ini g_conf pl sto sto2 yaml3
+#yaml2 159/s -- -1% -72% -80% -91% -95% -98% -98% -100%
+#yaml 160/s 1% -- -72% -80% -91% -95% -98% -98% -100%
+#xml 565/s 255% 253% -- -28% -68% -84% -93% -94% -100%
+#ini 785/s 393% 391% 39% -- -55% -78% -90% -91% -99%
+#g_conf 1756/s 1004% 998% 211% 124% -- -50% -78% -80% -98%
+#pl 3524/s 2115% 2103% 524% 349% 101% -- -55% -61% -97%
+#sto 7838/s 4826% 4799% 1288% 898% 346% 122% -- -12% -93%
+#sto2 8924/s 5508% 5477% 1480% 1037% 408% 153% 14% -- -92%
+#yaml3 113328/s 71115% 70730% 19961% 14336% 6353% 3116% 1346% 1170% -- #memory
+
+my $str = '{
+ foo => {key1 => "bar", key2 => "ralph"},
+ pass => {key1 => "word", key2 => "ralph"},
+ garbage => {key1 => "can", key2 => "ralph"},
+ mighty => {key1 => "ducks", key2 => "ralph"},
+ quack => {key1 => "moo", key2 => "ralph"},
+ one1 => {key1 => "val1", key2 => "ralph"},
+ one2 => {key1 => "val2", key2 => "ralph"},
+ one3 => {key1 => "val3", key2 => "ralph"},
+ one4 => {key1 => "val4", key2 => "ralph"},
+ one5 => {key1 => "val5", key2 => "ralph"},
+ one6 => {key1 => "val6", key2 => "ralph"},
+ one7 => {key1 => "val7", key2 => "ralph"},
+ one8 => {key1 => "val8", key2 => "ralph"},
+}';
+
+###----------------------------------------------------------------###
+
+# Rate yaml yaml2 xml g_conf pl sto sto2 yaml3
+#yaml 431/s -- -2% -61% -91% -94% -97% -98% -100%
+#yaml2 438/s 2% -- -60% -91% -94% -97% -98% -100%
+#xml 1099/s 155% 151% -- -78% -85% -92% -94% -99%
+#g_conf 4990/s 1057% 1038% 354% -- -33% -64% -72% -96%
+#pl 7492/s 1637% 1609% 582% 50% -- -46% -58% -93%
+#sto 13937/s 3130% 3078% 1169% 179% 86% -- -22% -88%
+#sto2 17925/s 4055% 3988% 1532% 259% 139% 29% -- -84%
+#yaml3 114429/s 26423% 25996% 10316% 2193% 1427% 721% 538% -- # memory
+
+#$str = '{
+# foo => "bar",
+# pass => "word",
+# garbage => "can",
+# mighty => "ducks",
+# quack => "moo",
+# one1 => "val1",
+# one2 => "val2",
+# one3 => "val3",
+# one4 => "val4",
+# one5 => "val5",
+# one6 => "val6",
+# one7 => "val7",
+# one8 => "val8",
+#}';
+
+###----------------------------------------------------------------###
+
+my $conf = eval $str;
+
+my %TESTS = ();
+
+### do perl
+my $file = tmpnam(). '.pl';
+open OUT, ">$file";
+print OUT $str;
+close OUT;
+$TESTS{pl} = sub {
+ my $hash = $cob->read_ref($file);
+};
+$files{pl} = $file;
+
+### do a generic conf_write
+my $file2 = tmpnam(). '.g_conf';
+&generic_conf_write($file2, $conf);
+local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read;
+$TESTS{g_conf} = sub {
+ my $hash = $cob->read_ref($file2);
+};
+$files{g_conf} = $file2;
+
+
+if (eval {require JSON}) {
+ my $_file = tmpnam(). '.json';
+ my $str = JSON::objToJson($conf, {pretty => 1, indent => 2});
+ open(my $fh, ">$_file");
+ print $fh $str;
+ $TESTS{json} = sub {
+ my $hash = $cob->read_ref($_file);
+ };
+ $TESTS{json2} = sub {
+ open(my $fh, "<$_file") || die "Couldn't open file: $!";
+ read($fh, my $str, -s $_file);
+ my $hash = JSON::jsonToObj($str);
+ };
+ $files{json} = $_file;
+}
+
+
+### load in the rest of the tests that we support
+if (eval {require Storable}) {
+ my $_file = tmpnam(). '.sto';
+ &Storable::store($conf, $_file);
+ $TESTS{sto} = sub {
+ my $hash = $cob->read_ref($_file);
+ };
+ $files{sto} = $_file;
+}
+
+if (eval {require Storable}) {
+ my $_file = tmpnam(). '.sto2';
+ &Storable::store($conf, $_file);
+ $TESTS{sto2} = sub {
+ my $hash = &Storable::retrieve($_file);
+ };
+ $files{sto2} = $_file;
+}
+
+if (eval {require YAML}) {
+ my $_file = tmpnam(). '.yaml';
+ &YAML::DumpFile($_file, $conf);
+ $TESTS{yaml} = sub {
+ my $hash = $cob->read_ref($_file);
+ };
+ $files{yaml} = $_file;
+}
+
+if (eval {require YAML}) {
+ my $_file = tmpnam(). '.yaml2';
+ &YAML::DumpFile($_file, $conf);
+ $TESTS{yaml2} = sub {
+ my $hash = &YAML::LoadFile($_file);
+ };
+ $files{yaml2} = $_file;
+}
+
+if (eval {require YAML}) {
+ my $_file = tmpnam(). '.yaml';
+ &YAML::DumpFile($_file, $conf);
+ $cob->preload_files($_file);
+ $TESTS{yaml3} = sub {
+ my $hash = $cob->read_ref($_file);
+ };
+ $files{yaml3} = $_file;
+}
+
+if (eval {require Config::IniHash}) {
+ my $_file = tmpnam(). '.ini';
+ &Config::IniHash::WriteINI($_file, $conf);
+ $TESTS{ini} = sub {
+ local $^W = 0;
+ my $hash = $cob->read_ref($_file);
+ };
+ $files{ini} = $_file;
+}
+
+if (eval {require XML::Simple}) {
+ my $_file = tmpnam(). '.xml';
+ my $xml = XML::Simple->new->XMLout($conf);
+ open OUT, ">$_file" || die $!;
+ print OUT $xml;
+ close OUT;
+ $TESTS{xml} = sub {
+ my $hash = $cob->read_ref($_file);
+ };
+ $files{xml} = $_file;
+}
+
+### tell file locations
+foreach my $key (sort keys %files) {
+ print "$key => $files{$key}\n";
+}
+
+cmpthese($n, \%TESTS);
+
+### comment out this line to inspect files
+unlink $_ foreach values %files;
+
+###----------------------------------------------------------------###
+
+sub generic_conf_read {
+ my $_file = shift || die "No filename supplied";
+ my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
+
+ ### fh will now lose scope and close itself if necessary
+ my $FH = do { local *FH; *FH };
+ open ($FH, $_file) || return {};
+
+ my $x = 0;
+ my $conf = {};
+ my $key = '';
+ my $val;
+ my $line;
+ my ($is_array,$is_hash,$is_multiline);
+ my $order;
+ $order = [] if wantarray;
+
+ while( defined($line = <$FH>) ){
+ last if ! defined $line;
+ last if $x++ > 10000;
+
+ next if index($line,'#') == 0;
+
+ if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
+ next if ! length($key);
+ $conf->{$key} .= $line;
+ $is_multiline = 1;
+
+ }else{
+ ### duplicate trim section
+ if( length($key) ){
+ $conf->{$key} =~ s/\s+$//;
+ if( $is_array || $is_hash ){
+ $conf->{$key} =~ s/^\s+//;
+ my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
+ my @pieces;
+ if ($sep_by_newlines) {
+ @pieces = split(/\s*\n\s*/,$conf->{$key});
+ @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
+ } else {
+ @pieces = split(/\s+/,$conf->{$key});
+ }
+ if( $urldec ){
+ foreach my $_val (@pieces){
+ $_val =~ y/+/ / if ! $sep_by_newlines;
+ $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+ if( $is_array ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ $conf->{$key} = \@pieces;
+ }elsif( $is_hash ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ shift(@pieces) if scalar(@pieces) % 2;
+ $conf->{$key} = {@pieces};
+ }
+ }elsif( ! $is_multiline ){
+ $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
+ $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+
+ ($key,$val) = split(/\s+/,$line,2);
+ $is_array = 0;
+ $is_hash = 0;
+ $is_multiline = 0;
+ if (! length($key)) {
+ next;
+ } elsif (index($key,'array:') == 0) {
+ $is_array = $key =~ s/^array://i;
+ } elsif (index($key,'hash:') == 0) {
+ $is_hash = $key =~ s/^hash://i;
+ }
+ $key =~ y/+/ / if ! $sep_by_newlines;
+ $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ $conf->{$key} = $val;
+ push @$order, $key if $order;
+ }
+ }
+
+ ### duplicate trim section
+ if( length($key) && defined($conf->{$key}) ){
+ $conf->{$key} =~ s/\s+$//;
+ if( $is_array || $is_hash ){
+ $conf->{$key} =~ s/^\s+//;
+ my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
+ my @pieces;
+ if ($sep_by_newlines) {
+ @pieces = split(/\s*\n\s*/,$conf->{$key});
+ @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
+ } else {
+ @pieces = split(/\s+/,$conf->{$key});
+ }
+ if( $urldec ){
+ foreach my $_val (@pieces){
+ $_val =~ y/+/ / if ! $sep_by_newlines;
+ $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+ if( $is_array ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ $conf->{$key} = \@pieces;
+ }elsif( $is_hash ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ shift(@pieces) if scalar(@pieces) % 2;
+ $conf->{$key} = {@pieces};
+ }
+ }elsif( ! $is_multiline ){
+ $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
+ $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+
+
+ close($FH);
+ return $order ? ($conf,$order) : $conf;
+}
+
+
+sub generic_conf_write{
+ my $_file = shift || die "No filename supplied";
+
+ if (! @_) {
+ return;
+ }
+
+ my $new_conf = shift || die "Missing update hashref";
+ return if ! keys %$new_conf;
+
+
+ ### do we allow writing out hashes in a nice way
+ my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
+
+ ### touch the file if necessary
+ if( ! -e $_file ){
+ open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
+ close(TOUCH);
+ }
+
+ ### read old values
+ my $conf = &generic_conf_read($_file) || {};
+ my $key;
+ my $val;
+
+ ### remove duplicates and undefs
+ while (($key,$val) = each %$new_conf){
+ $conf->{$key} = $new_conf->{$key};
+ }
+
+ ### prepare output
+ my $output = '';
+ my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/;
+ foreach $key (sort keys %$conf){
+ next if ! defined $conf->{$key};
+ $val = delete $conf->{$key};
+ $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg;
+ $key =~ tr/\ /+/;
+ my $ref = ref($val);
+ if( $ref ){
+ if( $ref eq 'HASH' ){
+ $output .= "hash:$key\n";
+ foreach my $_key (sort keys %$val){
+ my $_val = $val->{$_key};
+ next if ! defined $_val;
+ $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ if ($sep_by_newlines) {
+ $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
+ $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
+ $_key =~ s/\ /%20/g;
+ } else {
+ $_val =~ tr/\ /+/;
+ $_key =~ tr/\ /+/;
+ }
+ $_val = $PLACEHOLDER if ! length($_val);
+ $output .= "\t$_key\t$_val\n";
+ }
+ }elsif( $ref eq 'ARRAY' ){
+ $output .= "array:$key\n";
+ foreach (@$val){
+ my $_val = $_;
+ $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ if ($sep_by_newlines) {
+ $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
+ $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
+ } else {
+ $_val =~ tr/\ /+/;
+ }
+ $_val = $PLACEHOLDER if ! length($_val);
+ $output .= "\t$_val\n";
+ }
+ }else{
+ $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
+ }
+ }else{
+ if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding
+ if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){
+ if ($sep_by_newlines) {
+ $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg;
+ } else {
+ $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
+ $val =~ y/ /+/;
+ }
+ }
+ }else{
+ $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
+ $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg;
+ $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg;
+ }
+ $output .= "$key\t$val\n";
+ }
+ }
+
+ open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
+ print CONF $output;
+ truncate CONF, length($output);
+ close CONF;
+
+ return 1;
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use vars qw($PLACEHOLDER);
+use Benchmark qw(cmpthese timethese);
+use CGI::Ex::Conf;
+use POSIX qw(tmpnam);
+
+$PLACEHOLDER = chr(186).'~'.chr(186);
+
+my $n = -2;
+
+my $cob = CGI::Ex::Conf->new;
+my %files = ();
+
+###----------------------------------------------------------------###
+
+# Rate yaml yaml2 sto pl xml g_conf ini sto2
+#yaml 250/s -- -1% -14% -14% -61% -77% -95% -95%
+#yaml2 254/s 1% -- -13% -13% -60% -77% -95% -95%
+#sto 292/s 17% 15% -- -0% -54% -73% -94% -95%
+#pl 292/s 17% 15% 0% -- -54% -73% -94% -95%
+#xml 636/s 155% 151% 118% 118% -- -42% -88% -88%
+#g_conf 1088/s 335% 329% 273% 272% 71% -- -79% -80%
+#ini 5144/s 1958% 1929% 1662% 1660% 708% 373% -- -3%
+#sto2 5321/s 2029% 1999% 1723% 1721% 736% 389% 3% --
+
+my $str = {
+ foo => {key1 => "bar", key2 => "ralph"},
+ pass => {key1 => "word", key2 => "ralph"},
+ garbage => {key1 => "can", key2 => "ralph"},
+ mighty => {key1 => "ducks", key2 => "ralph"},
+ quack => {key1 => "moo", key2 => "ralph"},
+ one1 => {key1 => "val1", key2 => "ralph"},
+ one2 => {key1 => "val2", key2 => "ralph"},
+ one3 => {key1 => "val3", key2 => "ralph"},
+ one4 => {key1 => "val4", key2 => "ralph"},
+ one5 => {key1 => "val5", key2 => "ralph"},
+ one6 => {key1 => "val6", key2 => "ralph"},
+ one7 => {key1 => "val7", key2 => "ralph"},
+ one8 => {key1 => "val8", key2 => "ralph"},
+};
+
+###----------------------------------------------------------------###
+
+# Rate yaml yaml2 pl sto xml g_conf sto2
+#yaml 736/s -- -3% -20% -21% -62% -72% -89%
+#yaml2 755/s 3% -- -18% -19% -61% -71% -89%
+#pl 923/s 25% 22% -- -1% -53% -65% -86%
+#sto 928/s 26% 23% 1% -- -53% -65% -86%
+#xml 1961/s 166% 160% 113% 111% -- -26% -71%
+#g_conf 2635/s 258% 249% 185% 184% 34% -- -61%
+#sto2 6824/s 827% 803% 639% 635% 248% 159% --
+
+#$str = {
+# foo => "bar",
+# pass => "word",
+# garbage => "can",
+# mighty => "ducks",
+# quack => "moo",
+# one1 => "val1",
+# one2 => "val2",
+# one3 => "val3",
+# one4 => "val4",
+# one5 => "val5",
+# one6 => "val6",
+# one7 => "val7",
+# one8 => "val8",
+#};
+
+###----------------------------------------------------------------###
+
+my $conf = eval $str;
+
+my %TESTS = ();
+
+### do perl
+my $dir = tmpnam;
+mkdir $dir, 0755;
+my $tmpnam = "$dir/bench";
+my $file = $tmpnam. '.pl';
+$TESTS{pl} = sub {
+ $cob->write_ref($file, $str);
+};
+$files{pl} = $file;
+
+### do a generic conf_write
+my $file2 = $tmpnam. '.g_conf';
+local $CGI::Ex::Conf::EXT_WRITERS{g_conf} = \&generic_conf_write;
+$TESTS{g_conf} = sub {
+ $cob->write_ref($file2, $str);
+};
+$files{g_conf} = $file2;
+
+
+### load in the rest of the tests that we support
+if (eval {require JSON}) {
+ my $_file = tmpnam(). '.json';
+ $TESTS{json} = sub {
+ $cob->write_ref($file, $str);
+ };
+ $files{json} = $_file;
+}
+
+if (eval {require Storable}) {
+ my $_file = $tmpnam. '.sto';
+ $TESTS{sto} = sub {
+ $cob->write_ref($file, $str);
+ };
+ $files{sto} = $_file;
+}
+
+if (eval {require Storable}) {
+ my $_file = $tmpnam. '.sto2';
+ $TESTS{sto2} = sub {
+ &Storable::store($str, $_file);
+ };
+ $files{sto2} = $_file;
+}
+
+if (eval {require YAML}) {
+ my $_file = $tmpnam. '.yaml';
+ $TESTS{yaml} = sub {
+ $cob->write_ref($_file, $str);
+ };
+ $files{yaml} = $_file;
+}
+
+if (eval {require YAML}) {
+ my $_file = $tmpnam. '.yaml2';
+ $TESTS{yaml2} = sub {
+ &YAML::DumpFile($_file, $str);
+ };
+ $files{yaml2} = $_file;
+}
+
+if (eval {require Config::IniHash}) {
+ my $_file = $tmpnam. '.ini';
+ $TESTS{ini} = sub {
+ local $^W = 0;
+ $cob->write_ref($_file, $str);
+ };
+ $files{ini} = $_file;
+}
+
+if (eval {require XML::Simple}) {
+ my $_file = $tmpnam. '.xml';
+ $TESTS{xml} = sub {
+ $cob->write_ref($_file, $str);
+ };
+ $files{xml} = $_file;
+}
+
+### tell file locations
+foreach my $key (sort keys %files) {
+ print "$key => $files{$key}\n";
+}
+
+foreach my $key (keys %TESTS) {
+ eval { &{ $TESTS{$key} } };
+ if ($@) {
+ warn "Test for $key failed - skipping";
+ delete $TESTS{$key};
+ }
+}
+
+
+cmpthese timethese ($n, \%TESTS);
+
+### comment out this line to inspect files
+unlink $_ foreach values %files;
+rmdir $dir;
+
+###----------------------------------------------------------------###
+
+sub generic_conf_read {
+ my $_file = shift || die "No filename supplied";
+ my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
+
+ ### fh will now lose scope and close itself if necessary
+ my $FH = do { local *FH; *FH };
+ open ($FH, $_file) || return {};
+
+ my $x = 0;
+ my $conf = {};
+ my $key = '';
+ my $val;
+ my $line;
+ my ($is_array,$is_hash,$is_multiline);
+ my $order;
+ $order = [] if wantarray;
+
+ while( defined($line = <$FH>) ){
+ last if ! defined $line;
+ last if $x++ > 10000;
+
+ next if index($line,'#') == 0;
+
+ if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
+ next if ! length($key);
+ $conf->{$key} .= $line;
+ $is_multiline = 1;
+
+ }else{
+ ### duplicate trim section
+ if( length($key) ){
+ $conf->{$key} =~ s/\s+$//;
+ if( $is_array || $is_hash ){
+ $conf->{$key} =~ s/^\s+//;
+ my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
+ my @pieces;
+ if ($sep_by_newlines) {
+ @pieces = split(/\s*\n\s*/,$conf->{$key});
+ @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
+ } else {
+ @pieces = split(/\s+/,$conf->{$key});
+ }
+ if( $urldec ){
+ foreach my $_val (@pieces){
+ $_val =~ y/+/ / if ! $sep_by_newlines;
+ $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+ if( $is_array ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ $conf->{$key} = \@pieces;
+ }elsif( $is_hash ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ shift(@pieces) if scalar(@pieces) % 2;
+ $conf->{$key} = {@pieces};
+ }
+ }elsif( ! $is_multiline ){
+ $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
+ $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+
+ ($key,$val) = split(/\s+/,$line,2);
+ $is_array = 0;
+ $is_hash = 0;
+ $is_multiline = 0;
+ if (! length($key)) {
+ next;
+ } elsif (index($key,'array:') == 0) {
+ $is_array = $key =~ s/^array://i;
+ } elsif (index($key,'hash:') == 0) {
+ $is_hash = $key =~ s/^hash://i;
+ }
+ $key =~ y/+/ / if ! $sep_by_newlines;
+ $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ $conf->{$key} = $val;
+ push @$order, $key if $order;
+ }
+ }
+
+ ### duplicate trim section
+ if( length($key) && defined($conf->{$key}) ){
+ $conf->{$key} =~ s/\s+$//;
+ if( $is_array || $is_hash ){
+ $conf->{$key} =~ s/^\s+//;
+ my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
+ my @pieces;
+ if ($sep_by_newlines) {
+ @pieces = split(/\s*\n\s*/,$conf->{$key});
+ @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
+ } else {
+ @pieces = split(/\s+/,$conf->{$key});
+ }
+ if( $urldec ){
+ foreach my $_val (@pieces){
+ $_val =~ y/+/ / if ! $sep_by_newlines;
+ $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+ if( $is_array ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ $conf->{$key} = \@pieces;
+ }elsif( $is_hash ){
+ foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
+ shift(@pieces) if scalar(@pieces) % 2;
+ $conf->{$key} = {@pieces};
+ }
+ }elsif( ! $is_multiline ){
+ $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
+ $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
+ }
+ }
+
+
+ close($FH);
+ return $order ? ($conf,$order) : $conf;
+}
+
+
+sub generic_conf_write{
+ my $_file = shift || die "No filename supplied";
+
+ if (! @_) {
+ return;
+ }
+
+ my $new_conf = shift || die "Missing update hashref";
+ return if ! keys %$new_conf;
+
+
+ ### do we allow writing out hashes in a nice way
+ my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;
+
+ ### touch the file if necessary
+ if( ! -e $_file ){
+ open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
+ close(TOUCH);
+ }
+
+ ### read old values
+ my $conf = &generic_conf_read($_file) || {};
+ my $key;
+ my $val;
+
+ ### remove duplicates and undefs
+ while (($key,$val) = each %$new_conf){
+ $conf->{$key} = $new_conf->{$key};
+ }
+
+ ### prepare output
+ my $output = '';
+ my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/;
+ foreach $key (sort keys %$conf){
+ next if ! defined $conf->{$key};
+ $val = delete $conf->{$key};
+ $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg;
+ $key =~ tr/\ /+/;
+ my $ref = ref($val);
+ if( $ref ){
+ if( $ref eq 'HASH' ){
+ $output .= "hash:$key\n";
+ foreach my $_key (sort keys %$val){
+ my $_val = $val->{$_key};
+ next if ! defined $_val;
+ $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ if ($sep_by_newlines) {
+ $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
+ $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
+ $_key =~ s/\ /%20/g;
+ } else {
+ $_val =~ tr/\ /+/;
+ $_key =~ tr/\ /+/;
+ }
+ $_val = $PLACEHOLDER if ! length($_val);
+ $output .= "\t$_key\t$_val\n";
+ }
+ }elsif( $ref eq 'ARRAY' ){
+ $output .= "array:$key\n";
+ foreach (@$val){
+ my $_val = $_;
+ $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
+ if ($sep_by_newlines) {
+ $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
+ $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
+ } else {
+ $_val =~ tr/\ /+/;
+ }
+ $_val = $PLACEHOLDER if ! length($_val);
+ $output .= "\t$_val\n";
+ }
+ }else{
+ $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
+ }
+ }else{
+ if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding
+ if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){
+ if ($sep_by_newlines) {
+ $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg;
+ } else {
+ $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
+ $val =~ y/ /+/;
+ }
+ }
+ }else{
+ $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
+ $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg;
+ $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg;
+ }
+ $output .= "$key\t$val\n";
+ }
+ }
+
+ open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
+ print CONF $output;
+ truncate CONF, length($output);
+ close CONF;
+
+ return 1;
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Benchmark qw(cmpthese);
+use CGI::Ex::Dump qw(debug);
+
+my $n = 500_000;
+
+{
+ package A;
+ use vars qw($AUTOLOAD);
+ sub AUTOLOAD {
+ my $self = shift;
+ my $meth = ($AUTOLOAD =~ /::(\w+)$/) ? $1 : die "Bad method $AUTOLOAD";
+ die "Unknown property $meth" if ! exists $self->{$meth};
+ if ($#_ != -1) {
+ $self->{$meth} = shift;
+ } else {
+ return $self->{$meth}
+ }
+ }
+ sub DETROY {}
+}
+
+{
+ package B;
+ sub add_property {
+ my $self = shift;
+ my $prop = shift;
+ no strict 'refs';
+ * {"B::$prop"} = sub {
+ my $self = shift;
+ if ($#_ != -1) {
+ $self->{$prop} = shift;
+ } else {
+ return $self->{$prop};
+ }
+ };
+ $self->$prop(@_) if $#_ != -1;
+ }
+}
+
+{
+ package C;
+ sub add_property {
+ my $self = shift;
+ my $prop = shift;
+ no strict 'refs';
+ my $name = __PACKAGE__ ."::". $prop;
+ *$name = sub : lvalue {
+ my $self = shift;
+ $self->{$prop} = shift() if $#_ != -1;
+ $self->{$prop};
+ } if ! defined &$name;
+ $self->$prop() = shift() if $#_ != -1;
+ }
+}
+
+my $a = bless {}, 'A';
+$a->{foo} = 1;
+#debug $a->foo();
+#$a->foo(2);
+#debug $a->foo();
+
+my $b = bless {}, 'B';
+$b->add_property('foo', 1);
+#debug $b->foo();
+#$b->foo(2);
+#debug $b->foo();
+
+my $c = bless {}, 'C';
+$c->add_property('foo', 1);
+#debug $c->foo();
+#$c->foo(2);
+#debug $c->foo();
+
+my $d = bless {}, 'C';
+$d->add_property('foo', 1);
+#debug $d->foo();
+#$d->foo = 2;
+#debug $d->foo();
+
+
+use constant do_set => 1;
+
+cmpthese($n, {
+ autoloadonly => sub {
+ my $v = $a->foo();
+ if (do_set) {
+ $a->foo(2);
+ }
+ },
+ addproperty => sub {
+ my $v = $b->foo();
+ if (do_set) {
+ $b->foo(2);
+ }
+ },
+ addproperty_withlvalue => sub {
+ my $v = $c->foo();
+ if (do_set) {
+ $c->foo(2);
+ }
+ },
+ addproperty_withlvalue2 => sub {
+ my $v = $d->foo();
+ if (do_set) {
+ $d->foo = 2;
+ }
+ },
+});
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_optree.pl - Look at different ways of storing data that transform fast.
+
+=cut
+
+use strict;
+use Benchmark qw(cmpthese timethese);
+use CGI::Ex::Dump qw(debug);
+use constant skip_execute => 1;
+
+#my $obj = bless [1, 2], __PACKAGE__;
+#my $struct1 = \ [ '-', 1, 2 ];
+#my $struct2 = ['-', 1, 2];
+#
+#sub call { $_[0]->[0] - $_[0]->[1] }
+#
+#sub obj_meth { $obj->call }
+#sub ref_type { if (ref($struct1) eq 'REF') { if (${$struct1}->[0] eq '-') { ${$struct1}->[1] - ${$struct1}->[2] } } }
+#
+#print "(".obj_meth().")\n";
+#print "(".ref_type().")\n";
+#cmpthese timethese(-2, {
+# obj_meth => \&obj_meth,
+# ref_type => \&ref_type,
+#}, 'auto');
+
+
+###----------------------------------------------------------------###
+### setup a new way of storing and executing the variable tree
+
+sub get_var2 { ref($_[1]) ? $_[1]->call($_[0]) : $_[1] }
+
+{
+ package Num;
+ sub new { my $c = shift; bless \@_, $c };
+ sub call { $_[0]->[0] }
+ package A::B;
+ sub new { my $c = shift; bless \@_, $c }
+# sub new { my $c = shift; bless [map{ref$_?$_:Num->new($_)} @_], $c }
+ package A::B::Minus;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) - $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Plus;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) + $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Mult;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) * $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Div;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) / $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Var;
+ our @ISA = qw(A::B);
+use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC);
+BEGIN {
+ $HASH_OPS = $CGI::Ex::Template::HASH_OPS;
+ $LIST_OPS = $CGI::Ex::Template::LIST_OPS;
+ $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS;
+ $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS;
+ $OP_FUNC = $CGI::Ex::Template::OP_FUNC;
+}
+use constant trace => 0;
+sub call {
+ my $var = shift;
+ my $self = shift;
+ my $ARGS = shift || {};
+ my $i = 0;
+ my $generated_list;
+
+ ### determine the top level of this particular variable access
+ my $ref = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: begin \"$ref\"\n" if trace;
+
+ if (defined $ref) {
+ if ($ARGS->{'is_namespace_during_compile'}) {
+ $ref = $self->{'NAMESPACE'}->{$ref};
+ } else {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the returned thing was a code
+ if (UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? @{ $self->vivify_args($args) } : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### descend one chained level
+ last if $i >= $#$var;
+ my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
+ my $name = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: nested \"$name\"\n" if trace;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ $name = $name->call($self);
+ if (! defined($name) || $name =~ /^[_.]/) {
+ $ref = undef;
+ last;
+ }
+ }
+
+ if ($name =~ /^_/) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || $self->list_filters->{$name}) { # filter defined in Template::Filters
+
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
+
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ());
+ if (! $sub && $err) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$var->[$i - 5] || ''}) {
+ $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
+
+ } else {
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ } elsif ($ARGS->{'is_namespace_during_compile'}) {
+ return $var; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ }
+ }
+ }
+
+ } # end of while
+
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($self->{'_debug_undef'}) {
+ my $chunk = $var->[$i - 2];
+ $chunk = $chunk->call($self) if ref $chunk;
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($var);
+ }
+ }
+
+ ### allow for special behavior for the '..' operator
+ if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+
+ return $ref;
+}
+};
+sub plus ($$) { A::B::Plus->new( @_) }
+sub minus ($$) { A::B::Minus->new(@_) }
+sub mult ($$) { A::B::Mult->new( @_) }
+sub div ($$) { A::B::Div->new( @_) }
+sub var { A::B::Var->new( @_) };
+$INC{'A/B.pm'} = 1;
+$INC{'A/B/Plus.pm'} = 1;
+$INC{'A/B/Minus.pm'} = 1;
+$INC{'A/B/Mult.pm'} = 1;
+$INC{'A/B/Div.pm'} = 1;
+$INC{'A/B/Var.pm'} = 1;
+
+###----------------------------------------------------------------###
+### now benchmark the different variable storage methods
+
+my $vars = {
+ foo => {bar => {baz => [qw(a b c)]}},
+ bing => 'bang',
+};
+my $self = bless {'_vars' => $vars}, __PACKAGE__;
+
+#pauls@pslaptop:~/perl/CGI-Ex/lib$ perl -e 'my $a = "1 + 2 * (3 + (4 / 5) * 9) - 20";
+# use CGI::Ex::Template;
+# use Data::Dumper;
+# print Dumper(CGI::Ex::Template->new->parse_variable(\$a));'
+
+###----------------------------------------------------------------###
+
+my $Y0 = '$self->{_vars}->{bing}';
+my $Y1 = [ 'bing', 0 ];
+my $Y2 = var('bing', 0);
+debug $Y2;
+
+### are they all the same
+print eval($Y0)."\n";
+print $self->get_variable($Y1)."\n";
+print $self->get_var2($Y2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $Y0 },
+ bare_data => sub { $self->get_variable($Y1) },
+ method_call => sub { $self->get_var2($Y2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+my $Z0 = '$self->{_vars}->{foo}->{bar}->{baz}->[1]';
+my $Z1 = [ 'foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0];
+my $Z2 = var('foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0);
+debug $Z2;
+
+### are they all the same
+print eval($Z0)."\n";
+print $self->get_variable($Z1)."\n";
+print $self->get_var2($Z2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $Z0 },
+ bare_data => sub { $self->get_variable($Z1) },
+ method_call => sub { $self->get_var2($Z2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+### $A0 = perl, $A1 = old optree, $A2 = new optree
+my $A0 = "1 + 2 * (3 + (4 / 5) * 9) - 20";
+my $A1 = [ \[ '-', [ \[ '+', '1', [ \[ '*', '2', [ \[ '+', '3', [ \[ '*', [ \[ '/', '4', '5' ], 0 ], '9' ], 0 ] ], 0 ] ], 0 ] ], 0 ], '20' ], 0 ];
+my $A2 = minus(plus(1, mult(2, plus(3, mult(div(4,5), 9)))), 20);
+debug $A2;
+
+### are they all the same
+print eval($A0)."\n";
+print $self->get_variable($A1)."\n";
+print $self->get_var2($A2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $A0 },
+ bare_data => sub { $self->get_variable($A1) },
+ method_call => sub { $self->get_var2($A2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+my $B0 = "1 + 2";
+my $B1 = [ \[ '+', 1, 2] ];
+my $B2 = plus(1, 2);
+debug $B2;
+
+### are they all the same
+print eval($B0)."\n";
+print $self->get_variable($B1)."\n";
+print $self->get_var2($B2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $B0 },
+ bare_data => sub { $self->get_variable($B1) },
+ method_call => sub { $self->get_var2($B2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+### Test (de)serialization speed
+
+use Storable;
+my $d1 = Storable::freeze($A1);
+my $d2 = Storable::freeze($A2);
+Storable::thaw($d1); # load lib
+print length($d1)."\n";
+print length($d2)."\n";
+
+cmpthese timethese (-2, {
+ freeze_bare => sub { Storable::freeze($A1) },
+ freeze_meth => sub { Storable::freeze($A2) },
+}, 'auto');
+
+cmpthese timethese (-2, {
+ thaw_bare => sub { Storable::thaw($d1) },
+ thaw_meth => sub { Storable::thaw($d2) },
+}, 'auto');
+
+###----------------------------------------------------------------###
+### create libraries similar to those from CGI::Ex::Template 1.201
+
+use CGI::Ex::Template;
+use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC);
+BEGIN {
+ $HASH_OPS = $CGI::Ex::Template::HASH_OPS;
+ $LIST_OPS = $CGI::Ex::Template::LIST_OPS;
+ $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS;
+ $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS;
+ $OP_FUNC = $CGI::Ex::Template::OP_FUNC;
+}
+use constant trace => 0;
+
+sub get_variable {
+ ### allow for the parse tree to store literals
+ return $_[1] if ! ref $_[1];
+
+ my $self = shift;
+ my $var = shift;
+ my $ARGS = shift || {};
+ my $i = 0;
+ my $generated_list;
+
+ ### determine the top level of this particular variable access
+ my $ref = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: begin \"$ref\"\n" if trace;
+ if (ref $ref) {
+ if (ref($ref) eq 'SCALAR') { # a scalar literal
+ $ref = $$ref;
+ } elsif (ref($ref) eq 'REF') { # operator
+ return $self->play_operator($$ref) if ${ $ref }->[0] eq '\\'; # return the closure
+ $generated_list = 1 if ${ $ref }->[0] eq '..';
+ $ref = $self->play_operator($$ref);
+ } else { # a named variable access (ie via $name.foo)
+ $ref = $self->get_variable($ref);
+ if (defined $ref) {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+ } elsif (defined $ref) {
+ if ($ARGS->{'is_namespace_during_compile'}) {
+ $ref = $self->{'NAMESPACE'}->{$ref};
+ } else {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the returned thing was a code
+ if (UNIVERSAL::isa($ref, 'CODE')) {
+ my @results = $ref->($args ? @{ $self->vivify_args($args) } : ());
+ if (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### descend one chained level
+ last if $i >= $#$var;
+ my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
+ my $name = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: nested \"$name\"\n" if trace;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ if (ref($name) eq 'ARRAY') {
+ $name = $self->get_variable($name);
+ if (! defined($name) || $name =~ /^[_.]/) {
+ $ref = undef;
+ last;
+ }
+ } else {
+ die "Shouldn't get a ". ref($name) ." during a vivify on chain";
+ }
+ }
+ if ($name =~ /^_/) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || $self->list_filters->{$name}) { # filter defined in Template::Filters
+
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
+
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ());
+ if (! $sub && $err) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$var->[$i - 5] || ''}) {
+ $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
+
+ } else {
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ } elsif ($ARGS->{'is_namespace_during_compile'}) {
+ return $var; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ }
+ }
+ }
+
+ } # end of while
+
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($self->{'_debug_undef'}) {
+ my $chunk = $var->[$i - 2];
+ $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY';
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($var);
+ }
+ }
+
+ ### allow for special behavior for the '..' operator
+ if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+
+ return $ref;
+}
+
+sub vivify_args {
+ my $self = shift;
+ my $vars = shift;
+ my $args = shift || {};
+ return [map {$self->get_variable($_, $args)} @$vars];
+}
+
+sub play_operator {
+ my $self = shift;
+ my $tree = shift;
+ my $ARGS = shift || {};
+ my $op = $tree->[0];
+ $tree = [@$tree[1..$#$tree]];
+
+ ### allow for operator function override
+ if (exists $OP_FUNC->{$op}) {
+ return $OP_FUNC->{$op}->($self, $op, $tree, $ARGS);
+ }
+
+ ### do constructors and short-circuitable operators
+ if ($op eq '~' || $op eq '_') {
+ return join "", grep {defined} @{ $self->vivify_args($tree) };
+ } elsif ($op eq 'arrayref') {
+ return $self->vivify_args($tree, {list_context => 1});
+ } elsif ($op eq 'hashref') {
+ my $args = $self->vivify_args($tree);
+ push @$args, undef if ! ($#$args % 2);
+ return {@$args};
+ } elsif ($op eq '?') {
+ if ($self->get_variable($tree->[0])) {
+ return defined($tree->[1]) ? $self->get_variable($tree->[1]) : undef;
+ } else {
+ return defined($tree->[2]) ? $self->get_variable($tree->[2]) : undef;
+ }
+ } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
+ for my $node (@$tree) {
+ my $var = $self->get_variable($node);
+ return $var if $var;
+ }
+ return '';
+ } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
+ my $var;
+ for my $node (@$tree) {
+ $var = $self->get_variable($node);
+ return 0 if ! $var;
+ }
+ return $var;
+
+ } elsif ($op eq '!') {
+ my $var = ! $self->get_variable($tree->[0]);
+ return defined($var) ? $var : '';
+
+ }
+
+ ### equality operators
+ local $^W = 0;
+ my $n = $self->get_variable($tree->[0]);
+ $tree = [@$tree[1..$#$tree]];
+ if ($op eq '==') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 }
+ elsif ($op eq '!=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 }
+ elsif ($op eq 'eq') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 }
+ elsif ($op eq 'ne') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 }
+ elsif ($op eq '<') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n < $_); $n = $_ }; return 1 }
+ elsif ($op eq '>') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n > $_); $n = $_ }; return 1 }
+ elsif ($op eq '<=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n <= $_); $n = $_ }; return 1 }
+ elsif ($op eq '>=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n >= $_); $n = $_ }; return 1 }
+ elsif ($op eq 'lt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n lt $_); $n = $_ }; return 1 }
+ elsif ($op eq 'gt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n gt $_); $n = $_ }; return 1 }
+ elsif ($op eq 'le') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n le $_); $n = $_ }; return 1 }
+ elsif ($op eq 'ge') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ge $_); $n = $_ }; return 1 }
+
+ ### numeric operators
+ my $args = $self->vivify_args($tree);
+ if (! @$args) {
+ if ($op eq '-') { return - $n }
+ $self->throw('operator', "Not enough args for operator \"$op\"");
+ }
+ if ($op eq '..') { return [($n || 0) .. ($args->[-1] || 0)] }
+ elsif ($op eq '+') { $n += $_ for @$args; return $n }
+ elsif ($op eq '-') { $n -= $_ for @$args; return $n }
+ elsif ($op eq '*') { $n *= $_ for @$args; return $n }
+ elsif ($op eq '/') { $n /= $_ for @$args; return $n }
+ elsif ($op eq 'div'
+ || $op eq 'DIV') { $n = int($n / $_) for @$args; return $n }
+ elsif ($op eq '%'
+ || $op eq 'mod'
+ || $op eq 'MOD') { $n %= $_ for @$args; return $n }
+ elsif ($op eq '**'
+ || $op eq 'pow') { $n **= $_ for @$args; return $n }
+
+ $self->throw('operator', "Un-implemented operation $op");
+}
+
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_template.pl - Test relative performance of CGI::Ex::Template to Template::Toolkit
+
+=cut
+
+use strict;
+use Benchmark qw(cmpthese timethese);
+use POSIX qw(tmpnam);
+use File::Path qw(rmtree);
+use CGI::Ex::Template;
+use CGI::Ex::Dump qw(debug);
+use Template;
+use constant test_taint => 0 && eval { require Taint::Runtime }; # s/0/1/ to check tainting
+
+Taint::Runtime::taint_start() if test_taint;
+
+my $tt_cache_dir = tmpnam;
+END { rmtree $tt_cache_dir };
+mkdir $tt_cache_dir, 0755;
+
+my $swap = {
+ one => "ONE",
+ a_var => "a",
+ foo => '[% bar %]',
+ bar => "baz",
+ hash => {a => 1, b => 2, c => { d => [{hee => ["hmm"]}] }},
+ array => [qw(A B C D E a A)],
+ code => sub {"(@_)"},
+ filt => sub {sub {$_[0]x2}},
+};
+
+use Template::Stash;;
+my $s = Template::Stash->new($swap);
+#use Template::Stash::XS;
+#$s = Template::Stash::XS->new($swap);
+
+###----------------------------------------------------------------###
+### get objects ready
+
+my @config1 = (STASH => $s, ABSOLUTE => 1, CONSTANTS => {simple => 'var'}, EVAL_PERL => 1, INCLUDE_PATH => $tt_cache_dir);
+#push @config1, (INTERPOLATE => 1);
+my @config2 = (@config1, COMPILE_EXT => '.ttc');
+
+#use CGI::Ex::Template209;
+#my $tt1 = CGI::Ex::Template209->new(@config1);
+my $tt1 = Template->new(@config1);
+my $tt2 = Template->new(@config2);
+
+my $cet = CGI::Ex::Template->new(@config1);
+my $cetc = CGI::Ex::Template->new(@config2);
+
+#$swap->{$_} = $_ for (1 .. 1000); # swap size affects benchmark speed
+
+###----------------------------------------------------------------###
+### write out some file to be used later
+
+my $fh;
+my $bar_template = "$tt_cache_dir/bar.tt";
+END { unlink $bar_template };
+open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!";
+print $fh "BAR";
+close $fh;
+
+my $baz_template = "$tt_cache_dir/baz.tt";
+END { unlink $baz_template };
+open($fh, ">$baz_template") || die "Couldn't open $baz_template: $!";
+print $fh "[% SET baz = 42 %][% baz %][% bing %]";
+close $fh;
+
+my $longer_template = "[% INCLUDE bar.tt %]"
+ ."[% array.join('|') %]"
+ .("123"x200)
+ ."[% FOREACH a IN array %]foobar[% IF a == 'A' %][% INCLUDE baz.tt %][% END %]bazbing[% END %]"
+ .("456"x200)
+ ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]"
+ .("789"x200)
+ ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]"
+ .("012"x200)
+ ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]"
+ ."[% array.join('|') %]"
+ ."[% PROCESS bar.tt %]";
+
+###----------------------------------------------------------------###
+### set a few globals that will be available in our subs
+my $show_list = grep {$_ eq '--list'} @ARGV;
+my $run_all = grep {$_ eq '--all'} @ARGV;
+my @run = $run_all ? () : @ARGV;
+my $str_ref;
+my $filename;
+
+### uncomment to run a specific test - otherwise all tests run
+#@run = qw(07);
+
+# ### All percents are CGI::Ex::Template vs TT2
+# ### (The percent that CET is faster than TT)
+# Existing object by string ref #
+# New object with CACHE_EXT set # #
+# New object each time (undef CACHE_SIZE) # # #
+# This percent is compiled in memory (repeated calls) # # # #
+my $tests = { # # # # #
+ '01_empty' => "", # 231% # 571% # 310% # 431% # 20798.0/s #
+ '02_var_sma' => "[% one %]", # 162% # 531% # 409% # 436% # 14964.9/s #
+ '03_var_lar' => "[% one %]"x100, # 22% # 338% # 63% # 331% # 948.8/s #
+ '04_set_sma' => "[% SET one = 2 %]", # 160% # 478% # 391% # 370% # 14835.7/s #
+ '05_set_lar' => "[% SET one = 2 %]"x100, # 12% # 280% # 28% # 272% # 919.7/s #
+ '06_set_range' => "[% SET one = [0..30] %]", # 42% # 289% # 230% # 192% # 7909.3/s #
+ '07_chain_sm' => "[% hash.a %]", # 163% # 551% # 397% # 450% # 13791.3/s #
+ '08_mixed_sma' => "".((" "x100)."[% one %]\n")x10, # 72% # 467% # 234% # 440% # 5941.1/s #
+ '09_mixed_med' => "".((" "x10)."[% one %]\n")x100, # 17% # 416% # 99% # 394% # 879.7/s #
+ '10_str_sma' => "".("[% \"".(" "x100)."\$one\" %]\n")x10, # -12% # 1391% # 96% # 1448% # 2939.5/s #
+ '11_str_lar' => "".("[% \"".(" "x10)."\$one\" %]\n")x100, # -50% # 303% # -1% # 303% # 365.3/s #
+ '12_num_lterl' => "[% 2 %]", # 170% # 534% # 430% # 422% # 16592.1/s #
+ '13_plus' => "[% 1 + 2 %]", # 116% # 426% # 351% # 311% # 13151.4/s #
+ '14_chained' => "[% c.d.0.hee.0 %]", # 168% # 567% # 390% # 486% # 14451.2/s #
+ '15_chain_set' => "[% SET c.d.0.hee.0 = 2 %]", # 153% # 465% # 337% # 389% # 11123.9/s #
+ '16_chain_lar' => "[% c.d.0.hee.0 %]"x100, # 58% # 468% # 74% # 465% # 828.2/s #
+ '17_chain_sl' => "[% SET c.d.0.hee.0 = 2 %]"x100, # 111% # 343% # 85% # 346% # 367.4/s #
+ '18_cplx_comp' => "[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]", # 81% # 254% # 253% # 188% # 9677.4/s #
+ '19_if_sim_t' => "[% a=1 %][% IF a %]Two[% END %]", # 119% # 428% # 316% # 352% # 11600.5/s #
+ '20_if_sim_f' => " [% IF a %]Two[% END %]", # 163% # 536% # 398% # 459% # 14693.3/s #
+ '21_if_else' => "[% IF a %]A[% ELSE %]B[% END %]", # 139% # 483% # 363% # 393% # 13480.3/s #
+ '22_if_elsif' => "[% IF a %]A[% ELSIF b %]B[% ELSE %]C[% END %]", # 133% # 453% # 334% # 379% # 12151.0/s #
+ '23_for_i_sml' => "[% FOREACH i = [0..10] ; i ; END %]", # 12% # 197% # 131% # 140% # 2497.6/s #
+ '24_for_i_med' => "[% FOREACH i = [0..100] ; i ; END %]", # -23% # 21% # 0% # 5% # 357.3/s #
+ '25_for_sml' => "[% FOREACH [0..10] ; i ; END %]", # 23% # 220% # 151% # 160% # 2670.6/s #
+ '26_for_med' => "[% FOREACH [0..100] ; i ; END %]", # -5% # 41% # 19% # 24% # 404.5/s #
+ '27_while' => "[% f = 10 %][%WHILE f%][%f=f- 1%][%f%][% END %]", # 0% # 161% # 65% # 120% # 1604.2/s #
+ '28_whl_set_l' => "[% f = 10; WHILE (g=f) ; f = f - 1 ; f ; END %]", # -3% # 128% # 50% # 91% # 1285.6/s #
+ '29_whl_set_s' => "[% f = 1; WHILE (g=f) ; f = f - 1 ; f ; END %]", # 51% # 287% # 196% # 227% # 5914.2/s #
+ '30_file_proc' => "[% PROCESS bar.tt %]", # 231% # 492% # 370% # 468% # 10900.5/s #
+ '31_file_incl' => "[% INCLUDE baz.tt %]", # 150% # 403% # 278% # 335% # 6915.6/s #
+ '32_process' => "[% BLOCK foo %]Hi[% END %][% PROCESS foo %]", # 159% # 519% # 396% # 463% # 10647.0/s #
+ '33_include' => "[% BLOCK foo %]Hi[% END %][% INCLUDE foo %]", # 137% # 491% # 367% # 424% # 9087.9/s #
+ '34_macro' => "[% MACRO foo BLOCK %]Hi[% END %][% foo %]", # 76% # 364% # 276% # 285% # 7838.4/s #
+ '35_macro_arg' => "[% MACRO foo(n) BLOCK %]Hi[%n%][%END%][%foo(2)%]", # 64% # 263% # 251% # 200% # 6532.9/s #
+ '36_macro_pro' => "[% MACRO foo PROCESS bar;BLOCK bar%]7[%END;foo%]", # 95% # 393% # 300% # 333% # 6369.2/s #
+ '37_filter2' => "[% n = 1 %][% n | repeat(2) %]", # 129% # 394% # 342% # 313% # 10703.2/s #
+ '38_filter' => "[% n = 1 %][% n FILTER repeat(2) %]", # 90% # 322% # 286% # 245% # 8865.2/s #
+ '39_fltr_name' => "[% n=1; n FILTER echo=repeat(2); n FILTER echo%]", # 36% # 284% # 211% # 229% # 5824.9/s #
+ '40_constant' => "[% constants.simple %]", # 174% # 515% # 435% # 425% # 16588.0/s #
+ '41_perl' => "[%one='ONE'%][% PERL %]print \"[%one%]\"[%END%]", # 62% # 403% # 278% # 332% # 6885.4/s #
+ '42_filtervar' => "[% 'hi' | \$filt %]", # 95% # 454% # 328% # 370% # 10167.3/s #
+ '43_filteruri' => "[% ' ' | uri %]", # 132% # 550% # 379% # 471% # 12524.4/s #
+ '44_filterevl' => "[% foo | eval %]", # 303% # 530% # 434% # 478% # 5475.5/s #
+ '45_capture' => "[% foo = BLOCK %]Hi[% END %][% foo %]", # 102% # 386% # 291% # 304% # 10606.5/s #
+ '46_complex' => "$longer_template", # 55% # 288% # 133% # 251% # 1230.3/s #
+ # overall # 95% # 406% # 251% # 346% #
+
+
+ # With Stash::XS
+ #'46_complex' => "$longer_template", # -4% # 274% # 93% # 228% # 1201.9/s #
+ ## overall # 30% # 377% # 211% # 317% #
+};
+
+### load the code representation
+my $text = {};
+seek DATA, 0, 0;
+my $data = do { local $/ = undef; <DATA> };
+foreach my $key (keys %$tests) {
+ $data =~ m/(.*\Q$key\E.*)/ || next;
+ $text->{$key} = $1;
+}
+
+if ($show_list) {
+ foreach my $text (sort values %$text) {
+ print "$text\n";
+ }
+ exit;
+}
+
+my $run = join("|", @run);
+@run = grep {/$run/} sort keys %$tests;
+
+###----------------------------------------------------------------###
+
+sub file_TT_new {
+ my $out = '';
+ my $t = Template->new(@config1);
+ $t->process($filename, $swap, \$out);
+ return $out;
+}
+
+sub str_TT_new {
+ my $out = '';
+ my $t = Template->new(@config1);
+ $t->process($str_ref, $swap, \$out);
+ return $out;
+}
+
+sub file_TT {
+ my $out = '';
+ $tt1->process($filename, $swap, \$out);
+ return $out;
+}
+
+sub str_TT {
+ my $out = '';
+ $tt1->process($str_ref, $swap, \$out) || debug $tt1->error;
+ return $out;
+}
+
+sub file_TT_cache_new {
+ my $out = '';
+ my $t = Template->new(@config2);
+ $t->process($filename, $swap, \$out);
+ return $out;
+}
+
+###----------------------------------------------------------------###
+
+sub file_CET_new {
+ my $out = '';
+ my $t = CGI::Ex::Template->new(@config1);
+ $t->process($filename, $swap, \$out);
+ return $out;
+}
+
+sub str_CET_new {
+ my $out = '';
+ my $t = CGI::Ex::Template->new(@config1);
+ $t->process($str_ref, $swap, \$out);
+ return $out;
+}
+
+sub file_CET {
+ my $out = '';
+ $cet->process($filename, $swap, \$out);
+ return $out;
+}
+
+sub str_CET {
+ my $out = '';
+ $cet->process($str_ref, $swap, \$out);
+ return $out;
+}
+
+sub str_CET_swap {
+ my $txt = $cet->swap($str_ref, $swap);
+ return $txt;
+}
+
+sub file_CET_cache_new {
+ my $out = '';
+ my $t = CGI::Ex::Template->new(@config2);
+ $t->process($filename, $swap, \$out);
+ return $out;
+}
+
+###----------------------------------------------------------------###
+
+@run = sort(keys %$tests) if $#run == -1;
+
+my $output = '';
+my %cumulative;
+foreach my $test_name (@run) {
+ die "Invalid test $test_name" if ! exists $tests->{$test_name};
+ my $txt = $tests->{$test_name};
+ my $sample =$text->{$test_name};
+ $sample =~ s/^.+=>//;
+ $sample =~ s/\#.+$//;
+ print "-------------------------------------------------------------\n";
+ print "Running test $test_name\n";
+ print "Test text: $sample\n";
+
+ ### set the global file types
+ $str_ref = \$txt;
+ $filename = $tt_cache_dir ."/$test_name.tt";
+ open(my $fh, ">$filename") || die "Couldn't open $filename: $!";
+ print $fh $txt;
+ close $fh;
+
+ #debug file_CET(), str_TT();
+ #debug $cet->parse_tree($file);
+
+ ### check out put - and also allow for caching
+ for (1..2) {
+ if (file_CET() ne str_TT()) {
+ debug $cet->parse_tree($str_ref);
+ debug file_CET(), str_TT();
+ die "file_CET didn't match";
+ }
+ die "file_TT didn't match " if file_TT() ne str_TT();
+ die "str_CET didn't match " if str_CET() ne str_TT();
+# die "str_CET_swap didn't match " if str_CET_swap() ne str_TT();
+ die "file_CET_cache_new didn't match " if file_CET_cache_new() ne str_TT();
+ die "file_TT_cache_new didn't match " if file_TT_cache_new() ne str_TT();
+ }
+
+ next if test_taint;
+
+###----------------------------------------------------------------###
+
+ my $r = eval { timethese (-2, {
+ file_TT_n => \&file_TT_new,
+# str_TT_n => \&str_TT_new,
+ file_TT => \&file_TT,
+ str_TT => \&str_TT,
+ file_TT_c_n => \&file_TT_cache_new,
+
+ file_CT_n => \&file_CET_new,
+# str_CT_n => \&str_CET_new,
+ file_CT => \&file_CET,
+ str_CT => \&str_CET,
+# str_CT_sw => \&str_CET_swap,
+ file_CT_c_n => \&file_CET_cache_new,
+ }) };
+ if (! $r) {
+ debug "$@";
+ next;
+ }
+ eval { cmpthese $r };
+
+ my $copy = $text->{$test_name};
+ $copy =~ s/\#.+//;
+ $output .= $copy;
+
+ eval {
+ my $hash = {
+ '1 cached_in_memory ' => ['file_CT', 'file_TT'],
+ '2 new_object ' => ['file_CT_n', 'file_TT_n'],
+ '3 cached_on_file (new_object)' => ['file_CT_c_n', 'file_TT_c_n'],
+ '4 string reference ' => ['str_CT', 'str_TT'],
+ '5 CT new vs TT in mem ' => ['file_CT_n', 'file_TT'],
+ '6 CT in mem vs TT new ' => ['file_CT', 'file_TT_n'],
+ '7 CT in mem vs CT new ' => ['file_CT', 'file_CT_n'],
+ '8 TT in mem vs TT new ' => ['file_TT', 'file_TT_n'],
+ };
+ foreach my $type (sort keys %$hash) {
+ my ($key1, $key2) = @{ $hash->{$type} };
+ my $ct = $r->{$key1};
+ my $tt = $r->{$key2};
+ my $ct_s = $ct->iters / ($ct->cpu_a || 1);
+ my $tt_s = $tt->iters / ($tt->cpu_a || 1);
+ my $p = int(100 * ($ct_s - $tt_s) / ($tt_s || 1));
+ print "$type - CT is $p% faster than TT\n";
+
+ $output .= sprintf('# %3s%% ', $p) if $type =~ /^[1234]/;
+
+ ### store cumulatives
+ if (abs($p) < 10000) {
+ $cumulative{$type} ||= [0, 0];
+ $cumulative{$type}->[0] += $p;
+ $cumulative{$type}->[1] ++;
+ }
+ }
+ };
+ debug "$@"
+ if $@;
+
+ $output .= "# ".sprintf("%.1f", $r->{'file_CT'}->iters / ($r->{'file_CT'}->cpu_a || 1))."/s #\n";
+# $output .= "#\n";
+
+ foreach my $row (values %cumulative) {
+ $row->[2] = sprintf('%.1f', $row->[0] / ($row->[1]||1));
+ }
+
+ if ($#run > 0) {
+ foreach (sort keys %cumulative) {
+ printf "Cumulative $_: %6.1f\n", $cumulative{$_}->[2];
+ }
+ }
+
+}
+
+### add the final total row
+if ($#run > 0) {
+ $output .= " # overall" . (" "x61);
+ foreach my $type (sort keys %cumulative) {
+ $output .= sprintf('# %3s%% ', int $cumulative{$type}->[2]) if $type =~ /^[1234]/;
+ }
+ $output .= "#\n";
+
+ print $output;
+}
+
+
+
+#print `ls -lR $tt_cache_dir`;
+__DATA__
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Benchmark qw(timethese cmpthese countit timestr);
+use IO::Socket;
+
+my $str = "--[% one %][% two %]--\n";
+# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
+# grammar: 4 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 36585.78/s (n=74635)
+# index: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 81146.23/s (n=172030)
+# index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 71674.76/s (n=150517)
+# match: 4 wallclock secs ( 2.12 usr + 0.01 sys = 2.13 CPU) @ 57690.14/s (n=122880)
+# split: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 36230.58/s (n=74635)
+# Rate split grammar match index2 index
+# split 36231/s -- -1% -37% -49% -55%
+# grammar 36586/s 1% -- -37% -49% -55%
+# match 57690/s 59% 58% -- -20% -29%
+# index2 71675/s 98% 96% 24% -- -12%
+# index 81146/s 124% 122% 41% 13% --
+
+#my $str = ((" "x1000)."[% one %]\n")x10;
+# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
+# grammar: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 689.52/s (n=1448)
+# index: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 10239.52/s (n=21503)
+# index2: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 10095.31/s (n=21503)
+# match: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 6727.23/s (n=14329)
+# split: 4 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 5023.83/s (n=10751)
+# Rate grammar split match index2 index
+# grammar 690/s -- -86% -90% -93% -93%
+# split 5024/s 629% -- -25% -50% -51%
+# match 6727/s 876% 34% -- -33% -34%
+# index2 10095/s 1364% 101% 50% -- -1%
+# index 10240/s 1385% 104% 52% 1% --
+
+#my $str = ((" "x10)."[% one %]\n")x1000;
+# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
+# grammar: 3 wallclock secs ( 2.10 usr + 0.01 sys = 2.11 CPU) @ 81.52/s (n=172)
+# index: 4 wallclock secs ( 2.11 usr + 0.01 sys = 2.12 CPU) @ 207.55/s (n=440)
+# index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 209.52/s (n=440)
+# match: 3 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 173.43/s (n=359)
+# split: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 91.98/s (n=195)
+# Rate grammar split match index index2
+# grammar 81.5/s -- -11% -53% -61% -61%
+# split 92.0/s 13% -- -47% -56% -56%
+# match 173/s 113% 89% -- -16% -17%
+# index 208/s 155% 126% 20% -- -1%
+# index2 210/s 157% 128% 21% 1% --
+
+###----------------------------------------------------------------###
+
+### use a regular expression to go through the string
+sub parse_match {
+ my $new = '';
+ my $START = quotemeta '[%';
+ my $END = quotemeta '%]';
+
+ my $pos;
+ local pos($_[0]) = 0;
+ while ($_[0] =~ / \G (.*?) $START (.*?) $END /gsx) {
+ my ($begin, $tag) = ($1, $2);
+ $pos = pos($_[0]);
+ $new .= $begin;
+ $new .= "($tag)";
+ }
+ return $pos ? $new . substr($_[0], $pos) : $_[0];
+}
+
+### good ole index - hard coded
+sub parse_index {
+ my $new = '';
+
+ my $last = 0;
+ while (1) {
+ my $i = index($_[0], '[%', $last);
+ last if $i == -1;
+ $new .= substr($_[0], $last, $i - $last),
+ my $j = index($_[0], '%]', $i + 2);
+ die "Unclosed tag" if $j == -1;
+ my $tag = substr($_[0], $i + 2, $j - ($i + 2));
+ $new .= "($tag)";
+ $last = $j + 2;
+ }
+ return $last ? $new . substr($_[0], $last) : $_[0];
+}
+
+### index searching - but configurable
+sub parse_index2 {
+ my $new = '';
+ my $START = '[%';
+ my $END = '%]';
+ my $len_s = length $START;
+ my $len_e = length $END;
+
+ my $last = 0;
+ while (1) {
+ my $i = index($_[0], $START, $last);
+ last if $i == -1;
+ $new .= substr($_[0], $last, $i - $last),
+ my $j = index($_[0], $END, $i + $len_s);
+ $last = $j + $len_e;
+ if ($j == -1) { # missing closing tag
+ $last = length($_[0]);
+ last;
+ }
+ my $tag = substr($_[0], $i + $len_s, $j - ($i + $len_s));
+ $new .= "($tag)";
+ }
+ return $last ? $new . substr($_[0], $last) : $_[0];
+}
+
+### using a split method (several other split methods were also tried - but were slower)
+sub parse_split {
+ my $new = '';
+ my $START = quotemeta '[%';
+ my $END = quotemeta '%]';
+
+ my @all = split /($START .*? $END)/sx, $_[0];
+ for my $piece (@all) {
+ next if ! length $piece;
+ if ($piece !~ /^$START (.*) $END$/sx) {
+ $new .= $piece;
+ next;
+ }
+ my $tag = $1;
+ $new .= "($tag)";
+ }
+ return $new;
+}
+
+### a regex grammar type matcher
+sub parse_grammar {
+ my $new = '';
+ my $START = quotemeta '[%';
+ my $END = quotemeta '%]';
+
+ my $in_tag;
+ local pos($_[0]) = 0;
+ while (1) {
+ ### find the start tag
+ if (! $in_tag) {
+ if ($_[0] =~ /\G (.*?) $START /gcxs) {
+ $new .= $1;
+ $in_tag = 1;
+ next;
+ } else {
+ $new .= substr $_[0], pos($_[0]);
+ last;
+ }
+ }
+
+ ### end
+ if ($_[0] =~ /\G $END /gcx) {
+ $in_tag = 0;
+ }
+
+ if ($_[0] =~ /\G (\s*\w+\s*) /gcx) {
+ my $tag = $1;
+ $new .= "($tag)";
+ }
+ }
+ return $new;
+}
+
+###----------------------------------------------------------------###
+### check compliance
+
+#print parse_match($str);
+#print "---\n";
+#print parse_split($str);
+#print "---\n";
+#print parse_grammar($str);
+#print "---\n";
+#print parse_index($str);
+die "parse_split didn't match" if parse_split($str) ne parse_match($str);
+die "parse_grammar didn't match" if parse_grammar($str) ne parse_match($str);
+die "parse_index didn't match" if parse_index($str) ne parse_match($str);
+die "parse_index2 didn't match" if parse_index2($str) ne parse_match($str);
+#exit;
+
+### and run them
+cmpthese timethese (-2, {
+ index => sub { parse_index($str) },
+ index2 => sub { parse_index2($str) },
+ match => sub { parse_match($str) },
+ split => sub { parse_split($str) },
+ grammar => sub { parse_grammar($str) },
+});
--- /dev/null
+#!/usr/bin/perl -w
+
+use Benchmark qw(timethese cmpthese countit timestr);
+use CGI::Ex::Validate;
+use Data::FormValidator;
+
+my $form = {
+ username => "++foobar++",
+ password => "123",
+ password2 => "1234",
+};
+
+my $val_hash_ce = {
+ username => {
+ required => 1,
+ match => 'm/^\w+$/',
+ match_error => '$name may only contain letters and numbers',
+ untaint => 1,
+ },
+ password => {
+ required => 1,
+ match => 'm/^[ -~]{6,30}$/',
+# min_len => 6,
+# max_len => 30,
+# match => 'm/^[ -~]+$/',
+ untaint => 1,
+ },
+ password2 => {
+ validate_if => 'password',
+ equals => 'password',
+ },
+ email => {
+ required => 1,
+ match => 'm/^[\w\.\-]+\@[\w\.\-]+$/',
+ untaint => 1,
+ },
+};
+
+my $val_hash_df = {
+ required => [qw(username password email)],
+ dependencies => {
+ password => [qw(password2)],
+ },
+ constraints => {
+ email => qr/^[\w\.\-]+\@[\w\.\-]+$/,
+ password => qr/^[ -~]{6,30}$/,
+ username => qr/^\w+$/,
+ },
+ untaint_all_constraints => 1,
+ msgs => {
+ format => '%s',
+ prefix => 'error_',
+ },
+};
+
+sub check_form {
+ my $form = shift;
+ my $hash = {};
+ if (! exists $form->{'username'}) {
+ push @{ $hash->{'username_error'} }, 'Username required';
+ } elsif ($form->{'username'} !~ m/^(\w+)$/) {
+ push @{ $hash->{'username_error'} }, 'Username may only contain letters and numbers';
+ } else {
+ $form->{'username'} = $1;
+ }
+ if (! exists $form->{'password'}) {
+ push @{ $hash->{'password_error'} }, 'Password required';
+ } else {
+ if ($form->{'password'} !~ m/^([ -~]+)$/) {
+ push @{ $hash->{'password_error'} }, 'Password contained bad characters';
+ } else {
+ $form->{'password'} = $1;
+ }
+ if (length($form->{'password'}) < 6) {
+ push @{ $hash->{'password_error'} }, 'Password must be more than 6 characters';
+ } elsif (length($form->{'password'}) > 30) {
+ push @{ $hash->{'password_error'} }, 'Password must be less than 30 characters';
+ }
+
+ if (! defined($form->{'password2'})
+ || $form->{'password2'} ne $form->{'password'}) {
+ push @{ $hash->{'password2_error'} }, 'Password2 and password must be the same';
+ }
+ }
+
+ if (! exists $form->{'email'}) {
+ push @{ $hash->{'email_error'} }, 'Email required';
+ } elsif ($form->{'email'} !~ m/^[\w\.\-]+\@[\w\.\-]+$/) {
+ push @{ $hash->{'email_error'} }, 'Please type a valid email address';
+ }
+
+ return $hash;
+}
+
+
+cmpthese (-2,{
+ cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce) },
+ data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df) },
+ homegrown => sub { my $t = scalar keys %{ check_form($form) } },
+},'auto');
+
+cmpthese (-2,{
+ cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash },
+ data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df)->msgs },
+ homegrown => sub { my $t = 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.12 usr + 0.00 sys = 2.12 CPU) @ 1430.66/s (n=3033)
+# data_val: 2 wallclock secs ( 2.01 usr + 0.00 sys = 2.01 CPU) @ 2588.56/s (n=5203)
+# homegrown: 2 wallclock secs ( 2.19 usr + 0.01 sys = 2.20 CPU) @ 54733.18/s (n=120413)
+# Rate cgi_ex data_val homegrown
+# cgi_ex 1431/s -- -45% -97%
+# data_val 2589/s 81% -- -95%
+# homegrown 54733/s 3726% 2014% --
+# Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds...
+# cgi_ex: 2 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 1218.57/s (n=2559)
+# data_val: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 2092.99/s (n=4479)
+# homegrown: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 56267.76/s (n=120413)
+# Rate cgi_ex data_val homegrown
+# cgi_ex 1219/s -- -42% -98%
+# data_val 2093/s 72% -- -96%
+# homegrown 56268/s 4518% 2588% --
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_various_templaters.pl - test the relative performance of several different types of template engines.
+
+=cut
+
+use strict;
+use Benchmark qw(timethese cmpthese);
+
+my $file = $0;
+$file =~ s|[^/]+$|WrapEx.pm|;
+#require $file;
+
+use Template;
+use Template::Stash;
+use Text::Template;
+use CGI::Ex::Dump qw(debug);
+use CGI::Ex::Template;
+use POSIX qw(tmpnam);
+use File::Path qw(mkpath rmtree);
+
+my $dir = tmpnam;
+mkpath($dir);
+END {rmtree $dir};
+my @dirs = ($dir);
+
+my $form = {
+ foo => 'bar',
+ pass_in_something => 'what ever you want',
+};
+
+###----------------------------------------------------------------###
+
+my $stash_w = {
+ shell => {
+ header => "This is a header",
+ footer => "This is a footer",
+ start => "<html>",
+ end => "<end>",
+ foo => $form->{'foo'},
+ },
+ a => {
+ stuff => [qw(one two three four)],
+ },
+};
+
+my $stash_t = {
+ shell_header => "This is a header",
+ shell_footer => "This is a footer",
+ shell_start => "<html>",
+ shell_end => "<end>",
+ a_stuff => [qw(one two three four)],
+};
+
+$FOO::shell_header = $FOO::shell_footer = $FOO::shell_start = $FOO::shell_end = $FOO::a_stuff;
+$FOO::shell_header = "This is a header";
+$FOO::shell_footer = "This is a footer";
+$FOO::shell_start = "<html>";
+$FOO::shell_end = "<end>";
+$FOO::a_stuff = [qw(one two three four)];
+
+
+###----------------------------------------------------------------###
+
+my $content_w = q{[shell.header]
+[shell.start]
+
+[if shell.foo q{
+This is some text.
+}]
+
+[loop i a.stuff.length q{[a.stuff]}]
+[form.pass_in_something]
+
+[shell.end]
+[shell.footer]
+};
+
+my $content_t = q{[% shell_header %]
+[% shell_start %]
+
+[% IF foo %]
+This is some text.
+[% END %]
+
+[% FOREACH i IN a_stuff %][% i %][% END %]
+[% pass_in_something %]
+
+[% shell_end %]
+[% shell_footer %]
+};
+
+my $content_h = q{<TMPL_VAR NAME=shell_header>
+[% shell_start %]
+
+[% IF foo %]
+This is some text.
+[% END %]
+
+[% FOREACH i IN a_stuff %][% i %][% END %]
+[% pass_in_something %]
+
+[% shell_end %]
+[% shell_footer %]
+};
+
+if (open (my $fh, ">$dir/foo.tt")) {
+ print $fh $content_t;
+ close $fh;
+}
+
+my $content_p = q{{$shell_header}
+{$shell_start}
+
+{ if ($foo) {
+ $OUT .= "
+This is some text.
+";
+ }
+}
+
+{ $OUT .= $_ foreach @$a_stuff; }
+{$pass_in_something}
+
+{$shell_end}
+{$shell_footer}
+};
+
+#my $wrap = WrapEx->new({
+# dirs => \@dirs,
+# W => $stash_w,
+# form => [$form],
+#});
+
+ my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash->new($stash_t),
+});
+
+my $ct = CGI::Ex::Template->new({
+ INCLUDE_PATH => \@dirs,
+ VARIABLES => $stash_t,
+});
+
+my $pt = Text::Template->new(TYPE => 'STRING', SOURCE => $content_p, HASH => $form);
+
+###----------------------------------------------------------------###
+### make sure everything is ok
+
+#my $out_wr = $content_w;
+#$wrap->wrap(\$out_wr);
+
+my $out_tt = "";
+$tt->process(\$content_t, $form, \$out_tt);
+
+my $out_ct = "";
+$ct->process(\$content_t, $form, \$out_ct);
+
+my $out_c2 = "";
+$ct->process('foo.tt', $form, \$out_c2);
+
+my $out_c3 = '';
+$ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out_c3);
+
+my $out_pt = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
+
+if ($out_wr ne $out_tt) {
+ debug $out_wr, $out_tt;
+ die "Wrap didn't match tt";
+}
+if ($out_ct ne $out_tt) {
+ debug $out_ct, $out_tt;
+ die "CGI::Ex::Template didn't match tt";
+}
+if ($out_c2 ne $out_tt) {
+ debug $out_c2, $out_tt;
+ die "CGI::Ex::Template from file didn't match tt";
+}
+if ($out_c3 ne $out_tt) {
+ debug $out_c3, $out_tt;
+ die "CGI::Ex::Template by swap didn't match tt";
+}
+if ($out_pt ne $out_tt) {
+ debug $out_pt, $out_tt;
+ die "Text Template didn't match tt";
+}
+
+###----------------------------------------------------------------###
+
+cmpthese timethese (-2, {
+# wrap => sub {
+# my $out = $content_w;
+# $wrap->wrap(\$out);
+# },
+ TemplateToolkit => sub {
+ my $out = "";
+ $tt->process(\$content_t, $form, \$out);
+ },
+ CET => sub {
+ my $out = "";
+ $ct->process(\$content_t, $form, \$out);
+ },
+ CET_mem => sub {
+ my $out = "";
+ $ct->process('foo.tt', $form, \$out);
+ },
+ CET_process_s => sub {
+ my $out = '';
+ $ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out);
+ },
+ CET_cache => sub {
+ my $ct = CGI::Ex::Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash->new($stash_t),
+ CACHE_DIR => $dir,
+ });
+ my $out = '';
+ $ct->process('foo.tt', {%$stash_t, %$form}, \$out);
+ },
+ TextTemplate => sub {
+ my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
+ },
+ TextTemplate2 => sub {
+ my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => {%$stash_t, %$form});
+ },
+});
+
+###----------------------------------------------------------------###
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+cgi_ex_1.cgi - Show a basic example using some of the CGI::Ex tools
+
+=cut
+
+if (__FILE__ eq $0) {
+ handler();
+}
+
+###----------------------------------------------------------------###
+
+use strict;
+use CGI::Ex;
+use CGI::Ex::Validate ();
+use CGI::Ex::Dump qw(debug);
+
+###----------------------------------------------------------------###
+
+sub handler {
+ my $cgix = CGI::Ex->new;
+ my $vob = CGI::Ex::Validate->new;
+ my $form = $cgix->get_form();
+
+ ### allow for js validation libraries
+ ### path_info should contain something like /CGI/Ex/yaml_load.js
+ ### see the line with 'js_val' below
+ my $info = $ENV{PATH_INFO} || '';
+ if ($info =~ m|^(/\w+)+.js$|) {
+ $info =~ s|^/+||;
+ $cgix->print_js($info);
+ return;
+ }
+
+
+ debug $form;
+
+
+ ### check for errors - if they have submitted information
+ my $has_info = ($form->{processing}) ? 1 : 0;
+ my $errob = $has_info ? $vob->validate($form, validation_hash()) : undef;
+ my $form_name = 'formfoo';
+
+ ### failed validation - send out the template
+ if (! $has_info || $errob) {
+
+ ### get a template and swap defaults
+ my $swap = defaults_hash();
+
+ ### add errors to the swap (if any)
+ if ($errob) {
+ my $hash = $errob->as_hash();
+ $swap->{$_} = delete($hash->{$_}) foreach keys %$hash;
+ $swap->{'error_header'} = 'Please correct the form information below';
+ }
+
+ ### get js validation ready
+ $swap->{'form_name'} = $form_name;
+ $swap->{'js_val'} = $vob->generate_js(validation_hash(), # filename or valhash
+ $form_name, # name of form
+ $ENV{SCRIPT_NAME}); # browser path to cgi that calls print_js
+
+ ### swap in defaults, errors and js_validation
+ my $content = $cgix->swap_template(get_content_form(), $swap);
+
+ ### fill form fields
+ $cgix->fill(\$content, $form);
+ #debug $content;
+
+ ### print it out
+ $cgix->print_content_type();
+ print $content;
+ return;
+ }
+
+
+ ### show some sort of success if there were no errors
+ $cgix->print_content_type;
+ my $content = $cgix->swap_template(get_content_success(), defaults_hash());
+ print $content;
+ return;
+
+}
+
+###----------------------------------------------------------------###
+
+sub validation_hash {
+ return {
+ 'group order' => ['username', 'password'],
+ username => {
+ required => 1,
+ min_len => 3,
+ max_len => 30,
+ match => 'm/^\w+$/',
+ # could probably all be done with match => 'm/^\w{3,30}$/'
+ },
+ password => {
+ required => 1,
+ max_len => 20,
+ },
+ password_verify => {
+ validate_if => 'password',
+ equals => 'password',
+ },
+ };
+}
+
+sub defaults_hash {
+ return {
+ title => 'My Application',
+ script => $ENV{SCRIPT_NAME},
+ color => ['#ccf', '#aaf'],
+ }
+}
+
+###----------------------------------------------------------------###
+
+sub get_content_form {
+ return qq{
+ <html>
+ <head>
+ <title>[% title %]</title>
+ <style>
+ .error {
+ display: block;
+ color: red;
+ font-weight: bold;
+ }
+ </style>
+ </head>
+ <body>
+ <h1 style='color:blue'>Please Enter information</h1>
+ <span style='color:red'>[% error_header %]</span>
+ <br>
+
+ <form name="[% form_name %]">
+ <input type=hidden name=processing value=1>
+
+ <table>
+ <tr bgcolor=[% color.0 %]>
+ <td>Username:</td>
+ <td>
+ <input type=text size=30 name=username>
+ <span class=error id=username_error>[% username_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td>Password:</td>
+ <td><input type=password size=20 name=password>
+ <span class=error id=password_error>[% password_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.0 %]>
+ <td>Password Verify:</td>
+ <td><input type=password size=20 name=password_verify>
+ <span class=error id=password_verify_error>[% password_verify_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td colspan=2 align=right><input type=submit value=Submit></td>
+ </tr>
+
+ </table>
+
+ </form>
+
+ [% js_val %]
+ </body>
+ </html>
+ };
+}
+
+sub get_content_success {
+ return qq{
+ <html>
+ <head><title>[% title %]</title></head>
+ <body>
+ <h1 style='color:green'>Success</h1>
+ <br>
+ print "I can now continue on with the rest of my script!";
+ </body>
+ </html>
+ };
+}
+
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+cgi_ex_2.cgi - Rewrite of cgi_ex_1.cgi using CGI::Ex::App
+
+=cut
+
+if (__FILE__ eq $0) {
+ handler();
+}
+
+sub handler {
+ MyCGI->navigate;
+}
+
+###----------------------------------------------------------------###
+
+package MyCGI;
+
+use strict;
+use base CGI::Ex::App;
+use CGI::Ex::Dump qw(debug);
+
+sub pre_loop {
+ my $self = shift;
+ my $path = shift;
+ if ($#$path == -1) {
+ push @$path, 'userinfo';
+ }
+}
+
+### this will work for both userinfo_hash_common and success_hash_common
+sub hash_common {
+ my $self = shift;
+ return {
+ title => 'My Application',
+ script => $ENV{SCRIPT_NAME},
+ color => ['#ccf', '#aaf'],
+ history => $self->history,
+ }
+}
+
+sub ready_validate {
+ my $self = shift;
+ return $self->form->{processing} ? 1 : 0;
+}
+
+###----------------------------------------------------------------###
+
+sub userinfo_hash_validation {
+ return {
+ 'group order' => ['username', 'password'],
+ username => {
+ required => 1,
+ min_len => 3,
+ max_len => 30,
+ match => 'm/^\w+$/',
+ # could probably all be done with match => 'm/^\w{3,30}$/'
+ },
+ password => {
+ required => 1,
+ max_len => 20,
+ },
+ password_verify => {
+ validate_if => 'password',
+ equals => 'password',
+ },
+ };
+}
+
+sub userinfo_hash_swap {
+ my $self = shift;
+ my $hash = $self->form;
+ $hash->{form_name} = 'formfoo';
+ $hash->{js_val} = $self->vob->generate_js($self->userinfo_hash_validation(),
+ $hash->{form_name},
+ "$ENV{SCRIPT_NAME}/js");
+ return $hash;
+}
+
+###----------------------------------------------------------------###
+
+sub userinfo_file_print {
+ return \ qq {
+ <html>
+ <head>
+ <title>[% title %]</title>
+ <style>
+ .error {
+ display: block;
+ color: red;
+ font-weight: bold;
+ }
+ </style>
+ </head>
+ <body>
+ <h1 style='color:blue'>Please Enter information</h1>
+ <span style='color:red'>[% error_header %]</span>
+ <br>
+
+ <form name="[% form_name %]">
+ <input type=hidden name=processing value=1>
+
+ <table>
+ <tr bgcolor=[% color.0 %]>
+ <td>Username:</td>
+ <td>
+ <input type=text size=30 name=username>
+ <span class=error id=username_error>[% username_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td>Password:</td>
+ <td><input type=password size=20 name=password>
+ <span class=error id=password_error>[% password_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.0 %]>
+ <td>Password Verify:</td>
+ <td><input type=password size=20 name=password_verify>
+ <span class=error id=password_verify_error>[% password_verify_error %]</span></td>
+ </tr>
+ <tr bgcolor=[% color.1 %]>
+ <td colspan=2 align=right><input type=submit value=Submit></td>
+ </tr>
+
+ </table>
+
+ </form>
+
+ [% js_validation %]
+ </body>
+ </html>
+ };
+}
+
+sub success_file_print {
+ return \ qq{
+ <html>
+ <head><title>[% title %]</title></head>
+ <body>
+ <h1 style='color:green'>Success</h1>
+ <br>
+ print "I can now continue on with the rest of my script!";
+ </body>
+ </html>
+ };
+}
+
+
+1;
--- /dev/null
+{
+ quantity => 20,
+ color => 'red',
+ foo_immutable => 'file1',
+};
--- /dev/null
+{
+ immutable => 1,
+ quantity => 20,
+ color => 'orange',
+ foo => 'file1',
+};
--- /dev/null
+{
+ quantity => 30,
+ color => 'green',
+ foo => 'file2',
+};
--- /dev/null
+{
+ quantity => 30,
+ color => 'orange',
+ foo => 'file2',
+};
--- /dev/null
+# -*-perl-*-
+# run with perl -d:DProf $0
+
+use CGI::Ex::Conf qw(conf_read conf_write);
+use POSIX qw(tmpnam);
+use Data::Dumper qw(Dumper);
+
+#my $cob = CGI::Ex::Conf->new;
+my $tmp = tmpnam .".sto";
+END { unlink $tmp };
+
+my $conf = {
+ one => 1,
+ two => 2,
+ three => 3,
+ four => 4,
+ five => 5,
+ six => 6,
+ seven => 7,
+ eight => 8,
+ nine => 9,
+ ten => 10,
+};
+
+#$cob->write($tmp, $conf);
+conf_write($tmp, $conf);
+#print `cat $tmp`; exit;
+
+for (1 .. 100_000) {
+# my $ref = $cob->read($tmp);
+# my $ref = conf_read($tmp);
+# print Dumper $ref; exit;
+
+ conf_write($tmp, $conf);
+}
+
+
+__END__
+
+### conf_read
+%Time ExclSec CumulS #Calls sec/call Csec/c Name
+ 38.5 2.120 0.000 100000 0.0000 0.0000 Storable::_retrieve
+ 38.1 2.100 2.100 100000 0.0000 0.0000 Storable::pretrieve
+ 20.9 1.150 5.860 100000 0.0000 0.0001 CGI::Ex::Conf::read_ref
+ 8.73 0.480 6.720 100000 0.0000 0.0001 CGI::Ex::Conf::conf_read
+ 6.91 0.380 0.380 100001 0.0000 0.0000 CGI::Ex::Conf::new
+ 4.73 0.260 0.000 100000 0.0000 0.0000 Storable::retrieve
+ 4.18 0.230 4.710 100000 0.0000 0.0000 CGI::Ex::Conf::read_handler_storab
+ le
+ 0.36 0.020 0.040 3 0.0067 0.0133 main::BEGIN
+ 0.18 0.010 0.010 6 0.0017 0.0017 Exporter::import
+ 0.18 0.010 0.010 4 0.0025 0.0025 CGI::Ex::Conf::BEGIN
+ 0.18 0.010 0.020 1 0.0100 0.0199 CGI::Ex::Conf::write_handler_stora
+ ble
+ 0.18 0.010 0.010 5 0.0020 0.0020 AutoLoader::AUTOLOAD
+ 0.00 0.000 0.000 1 0.0000 0.0000 POSIX::load_imports
+ 0.00 0.000 0.000 1 0.0000 0.0000 Exporter::Heavy::heavy_export
+ 0.00 0.000 0.000 1 0.0000 0.0000 Storable::store
+
+### conf_write
+%Time ExclSec CumulS #Calls sec/call Csec/c Name
+ 60.3 9.510 9.510 100001 0.0001 0.0001 Storable::pstore
+ 32.8 5.170 0.000 100001 0.0001 0.0000 Storable::_store
+ 7.68 1.210 16.450 100001 0.0000 0.0002 CGI::Ex::Conf::write_ref
+ 2.60 0.410 17.220 100001 0.0000 0.0002 CGI::Ex::Conf::conf_write
+ 2.28 0.360 0.360 100001 0.0000 0.0000 CGI::Ex::Conf::new
+ 2.16 0.340 15.240 100001 0.0000 0.0002 CGI::Ex::Conf::write_handler_stora
+ ble
+ 1.33 0.210 0.000 100001 0.0000 0.0000 Storable::store
+ 0.06 0.010 0.010 3 0.0033 0.0033 AutoLoader::import
+ 0.06 0.010 0.010 2 0.0050 0.0050 DynaLoader::BEGIN
+ 0.06 0.010 0.010 4 0.0025 0.0025 CGI::Ex::Conf::BEGIN
+ 0.06 0.010 0.030 3 0.0033 0.0099 main::BEGIN
+ 0.00 0.000 0.000 1 0.0000 0.0000 POSIX::load_imports
+ 0.00 0.000 0.000 1 0.0000 0.0000 Exporter::Heavy::heavy_export
+ 0.00 - -0.000 1 - - main::END
+ 0.00 - -0.000 1 - - bytes::import
--- /dev/null
+# -*-perl-*-
+# run with perl -d:DProf $0 ; dprofpp
+
+use strict;
+use POSIX qw(tmpnam);
+use File::Path qw(rmtree);
+use CGI::Ex::Template;
+#use CGI::Ex::Template_60;
+
+my $tt_cache_dir = tmpnam;
+END { rmtree $tt_cache_dir };
+mkdir $tt_cache_dir, 0755;
+
+my $cet = CGI::Ex::Template->new(ABSOLUTE => 1);
+#use Template;
+#my $cet = Template->new(ABSOLUTE => 1);
+
+###----------------------------------------------------------------###
+
+my $swap = {
+ one => "ONE",
+ two => "TWO",
+ three => "THREE",
+ a_var => "a",
+ hash => {a => 1, b => 2, c => { d => ["hmm"] }},
+ array => [qw(A B C D E a A)],
+ code => sub {"($_[0])"},
+ cet => $cet,
+};
+
+my $txt = '';
+$txt .= "[% one %]\n";
+$txt .= ((" "x1000)."[% one %]\n")x100;
+$txt .= "[%f=10; WHILE (g=f) ; f = f - 1 ; f ; END %]";
+$txt .= ("[% \"".(" "x10)."\$one\" %]\n")x1000;
+
+my $file = \$txt;
+
+if (1) {
+ $file = $tt_cache_dir .'/template.txt';
+ open(my $fh, ">$file") || die "Couldn't open $file: $!";
+ print $fh $txt;
+ close $fh;
+}
+
+###----------------------------------------------------------------###
+
+sub cet {
+ my $out = '';
+ $cet->process($file, $swap, \$out);
+ return $out;
+}
+
+cet() for 1 .. 500;
--- /dev/null
+# -*-perl-*-
+# run with perl -d:DProf $0
+
+use CGI::Ex::Validate;
+
+my $form = {
+ username => "++foobar++",
+ password => "123",
+ password2 => "1234",
+};
+
+my $val_hash_ce = {
+ username => {
+ required => 1,
+ match => 'm/^\w+$/',
+ match_error => '$name may only contain letters and numbers',
+ untaint => 1,
+ },
+ password => {
+ required => 1,
+ min_len => 6,
+ max_len => 30,
+ match => 'm/^[ -~]+$/',
+ untaint => 1,
+ },
+ password2 => {
+ validate_if => 'password',
+ equals => 'password',
+ },
+ email => {
+ required => 1,
+ match => 'm/^[\w\.\-]+\@[\w\.\-]+$/',
+ untaint => 1,
+ },
+};
+
+
+for (1 .. 10_000) {
+ my $err_obj = CGI::Ex::Validate->validate($form, $val_hash_ce);
+# my $err_obj = CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use CGI::Ex::Validate;
+
+### sampe
+my $js_path = "/cgi-bin/js";
+my $form_name = "my_form";
+my $val_hash = {
+ 'general as_hash_join' => "<br>\n<br>",
+ 'general group_order' => [qw(username password)],
+ username => {
+ required => 1,
+ match => 'm/^\w+$/',
+ max_len => 20,
+ },
+ password => {
+ match => ['m/\d/', 'm/[a-z]/'],
+ match_error => "\$name Must contain a letter and a number",
+ },
+};
+
+
+### generate the js
+my $val_obj = CGI::Ex::Validate->new;
+my $val = $val_obj->generate_js($val_hash, $form_name, $js_path);
+
+
+### sample document out put
+### not that you should ever inline your html
+$val_obj->cgix->content_type;
+print "<html>
+<body>
+<form name='my_form'>
+
+Username: <input type=text size=20 name=username><br>
+<span class=error id=username_error></span><br>
+Password: <input type=text size=20 name=password><br>
+<span class=error id=password_error></span><br>
+<input type=submit>
+
+</form>
+
+$val
+
+</body>
+</html>
+";
--- /dev/null
+<form name="foo">
+<input type=text name=user>
+<input type=text name=foo>
+<input type=hidden name=bar value=1>
+</form>
+
+
+<script>
+document.validation="\n\
+ user:\n\
+ required: 1\n\
+ foo: {required_if: 'bar'}\n\
+";
+</script>
--- /dev/null
+<form name="foo">
+<input type=text name=user validation="
+ required: 1
+">
+<input type=text name=foo validation="
+ required_if: 'bar'
+">
+<input type=hidden name=bar value=1>
+</form>
+
--- /dev/null
+<html>
+<style>
+.error {
+ color: red;
+ font-size: 75%;
+}
+</style>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+if (! document.validate) {
+ document.writeln('<span style="color:red"><h1>Missing document.validate</h1>Path to ../lib/CGI/Ex/validate.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.validate</h1></span>');
+}
+
+</script>
+
+
+<form name=a>
+<table>
+<tr>
+ <td valign=top>Username:</td>
+ <td>
+ <input type=text size=20 name=username><br>
+ <span id=username_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Password:</td>
+ <td>
+ <input type=password size=20 name=password><br>
+ <span id=password_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Verify Password:</td>
+ <td>
+ <input type=password size=20 name=password2><br>
+ <span id=password2_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Email:</td>
+ <td>
+ <input type=text size=40 name=email><br>
+ <span id=email_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Verify Email:</td>
+ <td>
+ <input type=text size=40 name=email2><br>
+ <span id=email2_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>State/Region:</td>
+ <td>
+ Specify State <input type=text size=2 name=state><br>
+ OR Region <input type=text size=20 name=region>
+ <span id=state_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Enum Check:</td>
+ <td>
+ <input type=text size=10 name=enum><br>
+ <span id=enum_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Compare Check:</td>
+ <td>
+ <input type=text size=10 name=compare><br>
+ <span id=compare_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Check one:</td>
+ <td>
+ <input type=checkbox name=checkone value=1> Foo<br>
+ <input type=checkbox name=checkone value=2> Bar<br>
+ <input type=checkbox name=checkone value=3> Baz<br>
+ <span id=checkone_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Check two:</td>
+ <td>
+ <input type=checkbox name=checktwo value=1> Foo<br>
+ <input type=checkbox name=checktwo value=2> Bar<br>
+ <input type=checkbox name=checktwo value=3> Baz<br>
+ <span id=checktwo_error class=error></span>
+ </td>
+</tr>
+<tr><td colspan=2><hr></td></tr>
+<tr>
+ <td valign=top>Fill In two:</td>
+ <td>
+ <span id=foo_error class=error></span><br>
+ <input type=text name=foo value="" size=30> Foo<br>
+ <input type=text name=bar value="" size=30> Bar<br>
+ <input type=text name=baz value="" size=30> Baz<br>
+ </td>
+</tr>
+<tr>
+ <td colspan=2 align=right>
+ <input type=submit>
+ </td>
+</tr>
+</table>
+</form>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+document.validation = "\n\
+#general no_inline: 1\n\
+general no_confirm: 1\n\
+general no_alert: 1\n\
+general as_array_prefix: ' -- '\n\
+#general as_hash_header: '<ul><li>'\n\
+#general as_hash_join: '</li><li>'\n\
+#general as_hash_footer: '</li></ul>'\n\
+group order: [username, password, password2, email, email2, state, region, s_r_combo, enum, compare, checkone, checktwo, foo]\n\
+username:\n\
+ name: Username\n\
+ required: 1\n\
+ min_len: 3\n\
+ max_len: 30\n\
+password: &pa\n\
+ name: Password\n\
+ required: 1\n\
+ min_len: 6\n\
+ max_len: 30\n\
+ match: [m/\\d/, 'm/[a-z]/']\n\
+ match_error: '$name must contain both a letter and a number.'\n\
+password2:\n\
+ name: Verify password\n\
+ validate_if: *pa\n\
+ equals: password\n\
+ equals_name: password\n\
+email: &em\n\
+ name: Email\n\
+ required: 1\n\
+ max_len: 100\n\
+ match: 'm/^[^@]+@([\\w-]+\.)+\\w+$/'\n\
+ match_error: '$name must be a valid email address.'\n\
+email2:\n\
+ name: Verify email\n\
+ validate_if: *em\n\
+ equals: email\n\
+ equals_name: email\n\
+state:\n\
+ validate_if: [state, '! region']\n\
+ match: 'm/^\\w{2}$/'\n\
+ match_error: Please type a two letter state code.\n\
+region:\n\
+ validate_if: [region, '! state']\n\
+ delegate_error: state\n\
+ compare: 'eq Manitoba'\n\
+ compare_error: For this test - the region should be Manitoba.\n\
+s_r_combo:\n\
+ field: state\n\
+ delegate_error: state\n\
+ max_in_set: 1 of state region\n\
+ max_in_set_error: Specify only one of state and region.\n\
+ min_in_set: 1 of state region\n\
+ min_in_set_error: Specify one of state and region.\n\
+enum:\n\
+ name: Enum check\n\
+ enum: [one, two, three, four]\n\
+ enum_error: '$name must be one of one, two, three, or four.'\n\
+compare:\n\
+ required: 1\n\
+ replace: 's/\\D//g'\n\
+ name: Compare check\n\
+ compare: ['> 99', '< 1000']\n\
+ compare_error: '$name must be greater than 99 and less than 1000.'\n\
+checkone:\n\
+ name: Check one\n\
+ required: 1\n\
+ max_values: 1\n\
+checktwo:\n\
+ name: Check two\n\
+ min_values: 2\n\
+ max_values: 2\n\
+foo:\n\
+ min_in_set: 2 of foo bar baz\n\
+ max_in_set: 2 of foo bar baz\n\
+";
+if (document.check_form) document.check_form('a');
+</script>
+
+</html>
\ No newline at end of file
--- /dev/null
+<html>
+<style>
+.error {
+ color: red;
+ font-size: 75%;
+}
+</style>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+if (! document.validate) {
+ document.writeln('<span style="color:red"><h1>Missing document.validate</h1>Path to ../lib/CGI/Ex/validate.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.validate</h1></span>');
+}
+
+</script>
+
+
+<form name=a validation="
+general no_confirm: 1
+general no_alert: 1
+general as_array_prefix: ' -- '
+">
+<table>
+<tr>
+ <td valign=top>Username:</td>
+ <td>
+ <input type=text size=20 name=username validation="
+ name: Username
+ required: 1
+ min_len: 3
+ max_len: 30
+ match: 'm/^\w/'
+ match_error: '$name may contain only letters and numbers'
+"><br>
+ <span id=username_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Password:</td>
+ <td>
+ <input type=password size=20 name=password validation=" &pa
+ 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.'
+"><br>
+ <span id=password_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Verify Password:</td>
+ <td>
+ <input type=password size=20 name=password2 validation="{name: Verify password, validate_if: *pa, equals: password, equals_name: password}"><br>
+ <span id=password2_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Email:</td>
+ <td>
+ <input type=text size=40 name=email validation="&em
+name: Email
+required: 1
+min_len: 6
+max_len: 100
+"><br>
+ <span id=email_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Verify Email:</td>
+ <td>
+ <input type=text size=40 name=email2 validation="
+name: Verify email
+validate_if: *em
+equals: email
+equals_name: email
+"><br>
+ <span id=email2_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td valign=top>Random Association:</td>
+ <td>
+ <input type=text size=40 name=random validation="
+name: random
+default: bull sun orange
+"><br> (type anything - will fill in default if none)<br>
+ <span id=email2_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td colspan=2 align=right>
+ <input type=submit>
+ </td>
+</tr>
+</table>
+</form>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+if (document.check_form) document.check_form('a');
+</script>
+
+</html>
\ No newline at end of file
--- /dev/null
+<html>
+<style>
+.error {
+ color: red;
+ font-size: 75%;
+}
+</style>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+if (! document.validate) {
+ document.writeln('<span style="color:red"><h1>Missing document.validate</h1>Path to ../lib/CGI/Ex/validate.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.validate</h1></span>');
+}
+
+</script>
+
+
+<form name=a validation="
+general no_confirm: 1
+general no_alert: 1
+general as_array_prefix: ' -- '
+">
+<table>
+<tr>
+ <td valign=top>Enter a date (YYYY/MM/DD) greater than today:<br>
+ (<script>var t=new Date();document.writeln(t.toGMTString())</script>)
+ </td>
+ <td>
+ <input type=text size=20 name=date validation="
+ name: 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: |
+ 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;
+ (value > ''+y+'/'+m+'/'+d) ? 1 : 0;
+ custom_js_error: The date was not greater than today.
+"><br>
+ <span id=date_error class=error></span>
+ </td>
+</tr>
+<tr>
+ <td colspan=2 align=right>
+ <input type=submit>
+ </td>
+</tr>
+</table>
+</form>
+
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script src="../lib/CGI/Ex/validate.js"></script>
+<script>
+if (document.check_form) document.check_form('a');
+</script>
+
+</html>
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl -w
+
+my $swap = {
+ one => "ONE",
+ two => "TWO",
+ three => "THREE",
+ a_var => "a",
+ hash => {a => 1, b => 2},
+ code => sub {"($_[0])"},
+};
+
+my $txt = "[% one %][% two %][% three %][% hash.keys.join %] [% code(one).length %] [% hash.\$a_var %]\n";
+
+###----------------------------------------------------------------###
+
+my $module;
+if (! fork) {
+ $module = 'CGI::Ex::Template';
+ $0 = "perl $module";
+} elsif (! fork) {
+ $module = 'Template';
+ $0 = "perl $module";
+}
+
+if ($module) {
+ my $pm = "$module.pm";
+ $pm =~ s|::|/|g;
+ require $pm;
+
+ my $t = $module->new(ABSOLUTE => 1);
+ my $out = '';
+ $t->process(\$txt, $swap, \$out);
+ print $out;
+}
+
+sleep 15; # go and check the 'ps fauwx|grep perl'
+
+
+###----------------------------------------------------------------###
--- /dev/null
+### this file is very simplistic
+### but it shows how easy the file can be
+{
+ user => {
+ required => 1,
+ },
+ foo => {
+ required_if => 'bar',
+ },
+}
+# last item returned must be the ref
--- /dev/null
+[
+ {
+ 'group validate_if' => 'foo',
+ bar => {
+ required => 1,
+ },
+ },
+ {
+ 'group validate_if' => 'hem',
+ haw => { required => 1 },
+ },
+ {
+ raspberry => {
+ required => 1,
+ },
+ },
+];
--- /dev/null
+user:
+ required: 1
+foo:
+ required_if: bar
+
+### you could also do
+# user: {required: 1}
+# foo: {required: 1}
--- /dev/null
+- group validate_if: foo
+ bar:
+ required: 1
+- group validate_if: hem
+ haw: { required: 1 }
+- raspberry:
+ required: 1
--- /dev/null
+---
+group validate_if: foo
+bar:
+ required: 1
+
+---
+group validate_if: hem
+haw: { required: 1 }
+
+---
+raspberry:
+ required: 1
+
--- /dev/null
+<html>
+<title>Yaml Test</title>
+<body>
+
+<table border=1 cellspacing=0>
+ <tr>
+ <td colspan=2>
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script>
+
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+</script>
+ </td>
+ </tr>
+
+ <tr><th colspan=2>YAML text</th></tr>
+ <tr>
+ <td colspan=2>
+<pre><script>
+var yaml = "foo: bar\nbaz: bee\nhem: haw\n";
+document.write(yaml)
+</script></pre>
+ </td>
+ </tr>
+
+
+ <tr>
+ <th>Produces</th><th>Should look like</th>
+ </tr>
+ <tr>
+ <td>
+<pre><script>
+var t1 = new Date();
+var y = document.yaml_load(yaml)
+var t2 = new Date();
+document.write(document.js_dump(y));
+</script></pre>
+ </td>
+ <td>
+<pre>Dump:
+[obj].0.baz=bee
+[obj].0.foo=bar
+[obj].0.hem=haw
+</pre>
+ </td>
+ </tr>
+
+ <tr>
+ <td colspan=2>
+<script>
+document.write("Elapsed time: "+((t2.getTime() - t1.getTime())/1000)+" seconds");
+</script>
+ </td>
+ </tr>
+
+</body>
+</html>
\ No newline at end of file
--- /dev/null
+<html>
+<title>Yaml Test</title>
+<body>
+
+<table border=1 cellspacing=0>
+ <tr>
+ <td colspan=2>
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script>
+
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+</script>
+ </td>
+ </tr>
+
+ <tr><th colspan=2>YAML text</th></tr>
+ <tr>
+ <td colspan=2>
+<pre><script>
+var yaml = "--- #YAML:1.0\n\
+- foo1: bar1\n\
+ foo2: {key1: val1, key2: 'value 2'}\n\
+ foo3:\n\
+ - a\n\
+ - list\n\
+ - of\n\
+ - items\n\
+ - 'with the last item being a long string'\n\
+ foo4: [another, list, of, values]\n\
+ foo5a: |\n\
+ A block of text\n\
+ that is on multiple lines.\n\
+ foo5b: |+\n\
+ A block\n\
+ of text\n\
+ that is on\n\
+ multiple lines.\n\
+ foo6a: >\n\
+ A block\n\
+ of text\n\
+ that is on\n\
+ multiple lines and is folded.\n\
+ foo6b: >+\n\
+ A block\n\
+ of text\n\
+ that is on\n\
+ multiple lines and is folded.\n\
+ foo7: 'singlequoted''with embedded quote'\n\
+ foo8: \"doublequoted\\\"with embedded quote\"\n\
+";
+//"
+document.write(yaml)
+</script></pre>
+ </td>
+ </tr>
+
+
+ <tr>
+ <th>Produces</th><th>Should look like</th>
+ </tr>
+ <tr>
+ <td>
+<pre><script>
+var t1 = new Date();
+var y = document.yaml_load(yaml)
+var t2 = new Date();
+document.write(document.js_dump(y));
+</script></pre>
+ </td>
+ <td>
+<pre>Dump:
+[obj].0.0.foo1=bar1
+[obj].0.0.foo2.key1=val1
+[obj].0.0.foo2.key2=value 2
+[obj].0.0.foo3.0=a
+[obj].0.0.foo3.1=list
+[obj].0.0.foo3.2=of
+[obj].0.0.foo3.3=items
+[obj].0.0.foo3.4=with the last item being a long string
+[obj].0.0.foo4.0=another
+[obj].0.0.foo4.1=list
+[obj].0.0.foo4.2=of
+[obj].0.0.foo4.3=values
+[obj].0.0.foo5a=A block of text
+that is on multiple lines.
+[obj].0.0.foo5b=A block
+of text
+ that is on
+multiple lines.
+
+[obj].0.0.foo6a=A block of text that is on multiple lines and is folded.
+[obj].0.0.foo6b=A block of text that is on multiple lines and is folded.
+
+[obj].0.0.foo7=singlequoted'with embedded quote
+[obj].0.0.foo8=doublequoted"with embedded quote
+</pre>
+ </td>
+ </tr>
+
+ <tr>
+ <td colspan=2>
+<script>
+document.write("Elapsed time: "+((t2.getTime() - t1.getTime())/1000)+" seconds");
+</script>
+ </td>
+ </tr>
+
+</body>
+</html>
\ No newline at end of file
--- /dev/null
+<html>
+<title>Yaml Test</title>
+<body>
+
+<table border=1 cellspacing=0>
+ <tr>
+ <td colspan=2>
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script>
+
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+</script>
+ </td>
+ </tr>
+
+ <tr><th colspan=2>YAML text</th></tr>
+ <tr>
+ <td colspan=2>
+<pre><script>
+var yaml = "\n\
+key1_a: &foo1 val1\n\
+key2_a: &foo2 { skey2_1: sval2_1 }\n\
+key3_a: &foo3\n\
+ skey3_1: sval3_1\n\
+key4_a: &foo4 [ sval4_1, sval4_2 ]\n\
+key5_a: &foo5\n\
+ - sval5_1\n\
+ - sval5_2\n\
+\n\
+key1_b: *foo1\n\
+key2_b: *foo2\n\
+key3_b: *foo3\n\
+key4_b: *foo4\n\
+key5_b: *foo5\n\
+";
+
+document.write(yaml)
+</script></pre>
+ </td>
+ </tr>
+
+
+ <tr>
+ <th>Produces</th><th>Should look like</th>
+ </tr>
+ <tr>
+ <td>
+<pre><script>
+var t1 = new Date();
+var y = document.yaml_load(yaml)
+var t2 = new Date();
+document.write(document.js_dump(y));
+</script></pre>
+ </td>
+ <td>
+<pre>Dump:
+[obj].0.key1_a=val1
+[obj].0.key1_b=val1
+[obj].0.key2_a.skey2_1=sval2_1
+[obj].0.key2_b.skey2_1=sval2_1
+[obj].0.key3_a.skey3_1=sval3_1
+[obj].0.key3_b.skey3_1=sval3_1
+[obj].0.key4_a.0=sval4_1
+[obj].0.key4_a.1=sval4_2
+[obj].0.key4_b.0=sval4_1
+[obj].0.key4_b.1=sval4_2
+[obj].0.key5_a.0=sval5_1
+[obj].0.key5_a.1=sval5_2
+[obj].0.key5_b.0=sval5_1
+[obj].0.key5_b.1=sval5_2
+</pre>
+ </td>
+ </tr>
+
+ <tr>
+ <td colspan=2>
+<script>
+document.write("Elapsed time: "+((t2.getTime() - t1.getTime())/1000)+" seconds");
+</script>
+ </td>
+ </tr>
+
+</body>
+</html>
\ No newline at end of file
--- /dev/null
+<html>
+<title>Yaml Test</title>
+<body>
+
+<table border=1 cellspacing=0>
+ <tr>
+ <td colspan=2>
+<script src="../lib/CGI/Ex/yaml_load.js"></script>
+<script>
+
+if (! document.yaml_load) {
+ document.writeln('<span style="color:red"><h1>Missing document.yaml_load</h1>Path to ../lib/CGI/Ex/yaml_load.js may be invalid.</span>');
+} else {
+ document.writeln('<span style="color:green"><h1>Found document.yaml_load</h1></span>');
+}
+
+</script>
+ </td>
+ </tr>
+
+ <tr><th colspan=2>YAML text</th></tr>
+ <tr>
+ <td colspan=2>
+<pre><script>
+var yaml = "---\n\
+foo: bar\n\
+---\n\
+- baz\n\
+- bee\n\
+---\n\
+hem: haw\n\
+";
+document.write(yaml)
+</script></pre>
+ </td>
+ </tr>
+
+
+ <tr>
+ <th>Produces</th><th>Should look like</th>
+ </tr>
+ <tr>
+ <td>
+<pre><script>
+var t1 = new Date();
+var y = document.yaml_load(yaml)
+var t2 = new Date();
+document.write(document.js_dump(y));
+</script></pre>
+ </td>
+ <td>
+<pre>Dump:
+[obj].0.foo=bar
+[obj].1.0=baz
+[obj].1.1=bee
+[obj].2.hem=haw
+</pre>
+ </td>
+ </tr>
+
+ <tr>
+ <td colspan=2>
+<script>
+document.write("Elapsed time: "+((t2.getTime() - t1.getTime())/1000)+" seconds");
+</script>
+ </td>
+ </tr>
+
+</body>
+</html>
\ No newline at end of file
+# -*- Mode: Perl; -*-
-BEGIN {
- print "1..1\n";
+=head1 NAME
+
+0_ex_00_base.t - Testing of the base CGI::Ex module.
+
+=cut
+
+use strict;
+use Test::More tests => 63;
+
+use_ok('CGI::Ex');
+
+my $cgix = CGI::Ex->new;
+ok($cgix, "Got object");
+
+### test out form and cookies from the CGI object
+SKIP: {
+ skip("CGI.pm not found", 9) if ! eval { require CGI };
+ local $ENV{'REQUEST_METHOD'} = 'GET';
+ local $ENV{'QUERY_STRING'} = 'foo=bar&foo=baz&us=them';
+ local $ENV{'HTTP_COOKIE'} = 'bar=baz; bing=blam';
+
+ my $form = $cgix->form;
+ ok($form, "Got form");
+ ok(ref($form) eq 'HASH', "Good form");
+ ok($form->{'foo'}, "Found foo");
+ ok(ref($form->{'foo'}) eq 'ARRAY', "Foo is array");
+ ok(@{ $form->{'foo'} } == 2, "Correct number");
+ ok($form->{'us'}, "Found us");
+ ok($form->{'us'} eq 'them', "Us is correct");
+
+ my $cookies = $cgix->cookies;
+ ok($cookies, "Got cookies");
+ ok($cookies->{'bar'} eq 'baz', "Found correct bar");
+};
+
+### set a new form
+my $form = {foo => 'bar', mult => [qw(a b c)]};
+$cgix->form($form);
+$cgix->cookies($form);
+
+$form = $cgix->form;
+ok($form->{'foo'} eq 'bar', "Could set form");
+
+my $cookies = $cgix->cookies;
+ok($cookies->{'foo'} eq 'bar', "Could set form");
+
+
+### try out make_form
+my $str = $cgix->make_form($form);
+ok($str =~ /foo=bar/, "Make form works");
+ok($str =~ /mult=a&mult=b&mult=c/, "Make form works 2");
+
+$str = $cgix->make_form($form, ['foo']);
+ok($str eq 'foo=bar', "Make form works with keys");
+
+### can't test these without being in apache (well we could test STDOUT - but that is for another day - TODO)
+foreach my $meth (qw(
+ apache_request
+ content_typed
+ expires
+ is_mod_perl_1
+ is_mod_perl_2
+ last_modified
+ location_bounce
+ mod_perl_version
+ print_content_type
+ print_js
+ send_status
+ send_header
+ set_apache_request
+ set_cookie
+ )) {
+ ok($cgix->can($meth), "Has method $meth");
}
-use CGI::Ex;
+### try out time_calc
+my $sec;
+ok(($sec = CGI::Ex::time_calc('1m')) == time + 60, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc('-1m')) == time - 60, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc('1 m')) == time + 60, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc('1 min')) == time + 60, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc('1')) == 1, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc('now')) == time, "Time_calc ($sec)");
+ok(($sec = CGI::Ex::time_calc(__FILE__)), "Time_calc ($sec)");
+
+###----------------------------------------------------------------###
+
+my $html = "<input type=text name=foo value=''>";
+$form = {foo => 'bar'};
+my $out;
+
+ok(($out = $cgix->fill(scalarref => \$html, form => $form)) =~ /value=([\"\'])bar\1/, "Filled $out");
+ok(($out = $cgix->fill(arrayref => [$html], form => $form)) =~ /value=([\"\'])bar\1/, "Filled $out");
+
+$cgix->fill(text => \$html, form => $form);
+ok($html =~ /value=([\"\'])bar\1/, "Filled $html");
+
+$html = "<form name=foo><input type=text name=baz value=''></form><form name=bar><input type=password name=bim value=''></form>";
+
+$form = {baz => 'bing', bim => 'bang'};
+
+$out = $cgix->fill(scalarref => \$html, form => $form, target => 'foo');
+ok($out =~ /bing/, "Got bing");
+ok($out !~ /bang/, "Didn't get bang");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, target => 'bar');
+ok($out =~ /bang/, "Got bang");
+ok($out !~ /bing/, "Didn't get bing");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, ignore_fields => ['baz']);
+ok($out =~ /bang/, "Got bang");
+ok($out !~ /bing/, "Didn't get bing");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, ignore_fields => ['bim']);
+ok($out =~ /bing/, "Got bing");
+ok($out !~ /bang/, "Didn't get bang");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => 1);
+ok($out =~ /bing/, "Got bing");
+ok($out =~ /bang/, "Got bang");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => undef);
+ok($out =~ /bing/, "Got bing");
+ok($out =~ /bang/, "Got bang");
+
+$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => 0);
+ok($out =~ /bing/, "Got bing");
+ok($out !~ /bang/, "Didn't get bang");
+
+###----------------------------------------------------------------###
+
+$form = {foo => 'bar'};
+my $val = {foo => {'required' => 1}};
+
+my $e = $cgix->validate($form, $val);
+ok(! $e, "No error");
+
+$form = {};
+$e = $cgix->validate($form, $val);
+ok($e, "Got error");
+ok("$e" =~ /required/i, "Had error message ($e)");
+
+###----------------------------------------------------------------###
+
+### defer testing to the conf test modules
+foreach my $meth (qw(
+ conf_obj
+ conf_read
+ )) {
+ ok($cgix->can($meth), "Has method $meth");
+}
+
+###----------------------------------------------------------------###
+
+$form = {foo => 'bar'};
+my $args = {VARIABLES => {bim => 'bam'}};
+my $temp = "([% foo %])([% bim %])";
+
+$out = $cgix->swap_template($temp, $form, $args);
+ok($out =~ /bar/, "Got bar");
+ok($out =~ /bam/, "Got bam");
+
+$cgix->swap_template(\$temp, $form, $args);
+ok($temp =~ /bar/, "Got bar");
+ok($temp =~ /bam/, "Got bam");
-BEGIN { print "ok 1\n"; }
+###----------------------------------------------------------------###
+# -*- Mode: Perl; -*-
-BEGIN {
- print "1..1\n";
-}
+=head1 NAME
-use CGI::Ex::Validate;
+1_validate_00_base.t - Test CGI::Ex::Validate's ability to compile and execute
-BEGIN { print "ok 1\n"; }
+=cut
+
+use strict;
+use Test::More tests => 3;
+
+use_ok('CGI::Ex::Validate');
+
+my $form = {
+ user => 'abc',
+ pass => '123',
+};
+my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+};
+
+my $err_obj = CGI::Ex::Validate::validate($form, $val);
+ok(! $err_obj, "Basic function works");
+
+###----------------------------------------------------------------###
+
+$form = {
+ user => 'abc',
+# pass => '123',
+};
+
+$err_obj = CGI::Ex::Validate::validate($form,$val);
+
+ok($err_obj, "Successfully failed");
# -*- Mode: Perl; -*-
+=head1 NAME
+
+1_validate_03_cgi.t - Test CGI::Ex::Validate's ability to interact with CGI.pm.
+
+=cut
+
use strict;
+use Test::More tests => 3;
-$^W = 1;
+use_ok('CGI::Ex::Validate');
-print "1..2\n";
+SKIP: {
+ skip("CGI.pm not installed", 2) if ! eval { require CGI };
-use CGI::Ex;
-use CGI;
+ my $form = CGI->new({
+ user => 'abc',
+ pass => '123',
+ });
+ my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+ };
-print "ok 1\n";
+ my $err_obj = CGI::Ex::Validate::validate($form,$val);
+ ok(! $err_obj, "Correctly didn't get an error object");
-my $form = CGI->new({
- user => 'abc',
- pass => '123',
-});
-my $val = {
- user => {
- required => 1,
- },
- pass => {
- required => 1,
- },
-};
+ $form = CGI->new({
+ user => 'abc',
+ #pass => '123',
+ });
-my $err_obj = CGI::Ex->new->validate($form,$val);
+ $err_obj = CGI::Ex::Validate::validate($form, $val);
+ ok($err_obj, "Correctly did get an error object");
-if (! $err_obj) {
- print "ok 2\n";
-} else {
- warn "$err_obj\n";
- print "not ok 2\n";
}
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+1_validate_05_types.t - Test CGI::Ex::Validate's ability to do multitudinous types of validate
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+=cut
-require CGI::Ex::Validate;
+use strict;
+use Test::More tests => 104;
-my ($N, $v, $e, $ok) = (0);
+use_ok('CGI::Ex::Validate');
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
+my $v;
+my $e;
+sub validate { scalar &CGI::Ex::Validate::validate(@_) }
### required
$v = {foo => {required => 1}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({foo => 1}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1}, $v);
+ok(! $e);
### validate_if
$v = {foo => {required => 1, validate_if => 'bar'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({bar => 1}, $v);
-&print_ok($e);
+$e = validate({bar => 1}, $v);
+ok($e);
### required_if
$v = {foo => {required_if => 'bar'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({bar => 1}, $v);
-&print_ok($e);
+$e = validate({bar => 1}, $v);
+ok($e);
### max_values
$v = {foo => {required => 1}};
-$e = &validate({foo => [1,2]}, $v);
-&print_ok($e);
+$e = validate({foo => [1,2]}, $v);
+ok($e);
$v = {foo => {max_values => 2}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({foo => "str"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "str"}, $v);
+ok(! $e);
-$e = &validate({foo => [1]}, $v);
-&print_ok(! $e);
+$e = validate({foo => [1]}, $v);
+ok(! $e);
-$e = &validate({foo => [1,2]}, $v);
-&print_ok(! $e);
+$e = validate({foo => [1,2]}, $v);
+ok(! $e);
-$e = &validate({foo => [1,2,3]}, $v);
-&print_ok($e);
+$e = validate({foo => [1,2,3]}, $v);
+ok($e);
### min_values
$v = {foo => {min_values => 3, max_values => 10}};
-$e = &validate({foo => [1,2,3]}, $v);
-&print_ok(! $e);
+$e = validate({foo => [1,2,3]}, $v);
+ok(! $e);
-$e = &validate({foo => [1,2,3,4]}, $v);
-&print_ok(! $e);
+$e = validate({foo => [1,2,3,4]}, $v);
+ok(! $e);
-$e = &validate({foo => [1,2]}, $v);
-&print_ok($e);
+$e = validate({foo => [1,2]}, $v);
+ok($e);
-$e = &validate({foo => "str"}, $v);
-&print_ok($e);
+$e = validate({foo => "str"}, $v);
+ok($e);
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
### enum
$v = {foo => {enum => [1, 2, 3]}, bar => {enum => "1 || 2||3"}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok(! $e);
-$e = &validate({foo => 1, bar => 2}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1, bar => 2}, $v);
+ok(! $e);
-$e = &validate({foo => 1, bar => 3}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1, bar => 3}, $v);
+ok(! $e);
-$e = &validate({foo => 1, bar => 4}, $v);
-&print_ok($e);
+$e = validate({foo => 1, bar => 4}, $v);
+ok($e);
# equals
$v = {foo => {equals => 'bar'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({foo => 1}, $v);
-&print_ok($e);
+$e = validate({foo => 1}, $v);
+ok($e);
-$e = &validate({bar => 1}, $v);
-&print_ok($e);
+$e = validate({bar => 1}, $v);
+ok($e);
-$e = &validate({foo => 1, bar => 2}, $v);
-&print_ok($e);
+$e = validate({foo => 1, bar => 2}, $v);
+ok($e);
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok(! $e);
$v = {foo => {equals => '"bar"'}};
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok($e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok($e);
-$e = &validate({foo => 'bar', bar => 1}, $v);
-&print_ok(! $e);
+$e = validate({foo => 'bar', bar => 1}, $v);
+ok(! $e);
### min_len
$v = {foo => {min_len => 10}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({foo => ""}, $v);
-&print_ok($e);
+$e = validate({foo => ""}, $v);
+ok($e);
-$e = &validate({foo => "123456789"}, $v);
-&print_ok($e);
+$e = validate({foo => "123456789"}, $v);
+ok($e);
-$e = &validate({foo => "1234567890"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "1234567890"}, $v);
+ok(! $e);
### max_len
$v = {foo => {max_len => 10}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({foo => ""}, $v);
-&print_ok(! $e);
+$e = validate({foo => ""}, $v);
+ok(! $e);
-$e = &validate({foo => "1234567890"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "1234567890"}, $v);
+ok(! $e);
-$e = &validate({foo => "12345678901"}, $v);
-&print_ok($e);
+$e = validate({foo => "12345678901"}, $v);
+ok($e);
### match
$v = {foo => {match => qr/^\w+$/}};
-$e = &validate({foo => "abc"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "abc"}, $v);
+ok(! $e);
-$e = &validate({foo => "abc."}, $v);
-&print_ok($e);
+$e = validate({foo => "abc."}, $v);
+ok($e);
$v = {foo => {match => [qr/^\w+$/, qr/^[a-z]+$/]}};
-$e = &validate({foo => "abc"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "abc"}, $v);
+ok(! $e);
-$e = &validate({foo => "abc1"}, $v);
-&print_ok($e);
+$e = validate({foo => "abc1"}, $v);
+ok($e);
$v = {foo => {match => 'm/^\w+$/'}};
-$e = &validate({foo => "abc"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "abc"}, $v);
+ok(! $e);
-$e = &validate({foo => "abc."}, $v);
-&print_ok($e);
+$e = validate({foo => "abc."}, $v);
+ok($e);
$v = {foo => {match => 'm/^\w+$/ || m/^[a-z]+$/'}};
-$e = &validate({foo => "abc"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "abc"}, $v);
+ok(! $e);
-$e = &validate({foo => "abc1"}, $v);
-&print_ok($e);
+$e = validate({foo => "abc1"}, $v);
+ok($e);
$v = {foo => {match => '! m/^\w+$/'}};
-$e = &validate({foo => "abc"}, $v);
-&print_ok($e);
+$e = validate({foo => "abc"}, $v);
+ok($e);
-$e = &validate({foo => "abc."}, $v);
-&print_ok(! $e);
+$e = validate({foo => "abc."}, $v);
+ok(! $e);
$v = {foo => {match => 'm/^\w+$/'}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
$v = {foo => {match => '! m/^\w+$/'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
### compare
$v = {foo => {compare => '> 0'}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
$v = {foo => {compare => '== 0'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
$v = {foo => {compare => '< 0'}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
$v = {foo => {compare => '> 10'}};
-$e = &validate({foo => 11}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 10}, $v);
-&print_ok($e);
+$e = validate({foo => 11}, $v);
+ok(! $e);
+$e = validate({foo => 10}, $v);
+ok($e);
$v = {foo => {compare => '== 10'}};
-$e = &validate({foo => 11}, $v);
-&print_ok($e);
-$e = &validate({foo => 10}, $v);
-&print_ok(! $e);
+$e = validate({foo => 11}, $v);
+ok($e);
+$e = validate({foo => 10}, $v);
+ok(! $e);
$v = {foo => {compare => '< 10'}};
-$e = &validate({foo => 9}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 10}, $v);
-&print_ok($e);
+$e = validate({foo => 9}, $v);
+ok(! $e);
+$e = validate({foo => 10}, $v);
+ok($e);
$v = {foo => {compare => '>= 10'}};
-$e = &validate({foo => 10}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 9}, $v);
-&print_ok($e);
+$e = validate({foo => 10}, $v);
+ok(! $e);
+$e = validate({foo => 9}, $v);
+ok($e);
$v = {foo => {compare => '!= 10'}};
-$e = &validate({foo => 10}, $v);
-&print_ok($e);
-$e = &validate({foo => 9}, $v);
-&print_ok(! $e);
+$e = validate({foo => 10}, $v);
+ok($e);
+$e = validate({foo => 9}, $v);
+ok(! $e);
$v = {foo => {compare => '<= 10'}};
-$e = &validate({foo => 11}, $v);
-&print_ok($e);
-$e = &validate({foo => 10}, $v);
-&print_ok(! $e);
+$e = validate({foo => 11}, $v);
+ok($e);
+$e = validate({foo => 10}, $v);
+ok(! $e);
$v = {foo => {compare => 'gt ""'}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
$v = {foo => {compare => 'eq ""'}};
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
$v = {foo => {compare => 'lt ""'}};
-$e = &validate({}, $v);
-&print_ok($e); # 68
+$e = validate({}, $v);
+ok($e); # 68
$v = {foo => {compare => 'gt "c"'}};
-$e = &validate({foo => 'd'}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 'c'}, $v);
-&print_ok($e);
+$e = validate({foo => 'd'}, $v);
+ok(! $e);
+$e = validate({foo => 'c'}, $v);
+ok($e);
$v = {foo => {compare => 'eq c'}};
-$e = &validate({foo => 'd'}, $v);
-&print_ok($e);
-$e = &validate({foo => 'c'}, $v);
-&print_ok(! $e);
+$e = validate({foo => 'd'}, $v);
+ok($e);
+$e = validate({foo => 'c'}, $v);
+ok(! $e);
$v = {foo => {compare => 'lt c'}};
-$e = &validate({foo => 'b'}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 'c'}, $v);
-&print_ok($e);
+$e = validate({foo => 'b'}, $v);
+ok(! $e);
+$e = validate({foo => 'c'}, $v);
+ok($e);
$v = {foo => {compare => 'ge c'}};
-$e = &validate({foo => 'c'}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 'b'}, $v);
-&print_ok($e);
+$e = validate({foo => 'c'}, $v);
+ok(! $e);
+$e = validate({foo => 'b'}, $v);
+ok($e);
$v = {foo => {compare => 'ne c'}};
-$e = &validate({foo => 'c'}, $v);
-&print_ok($e);
-$e = &validate({foo => 'b'}, $v);
-&print_ok(! $e);
+$e = validate({foo => 'c'}, $v);
+ok($e);
+$e = validate({foo => 'b'}, $v);
+ok(! $e);
$v = {foo => {compare => 'le c'}};
-$e = &validate({foo => 'd'}, $v);
-&print_ok($e);
-$e = &validate({foo => 'c'}, $v);
-&print_ok(! $e); # 80
+$e = validate({foo => 'd'}, $v);
+ok($e);
+$e = validate({foo => 'c'}, $v);
+ok(! $e); # 80
### sql
### can't really do anything here without prompting for a db connection
### custom
my $n = 1;
$v = {foo => {custom => $n}};
-$e = &validate({}, $v);
-&print_ok(! $e);
-$e = &validate({foo => "str"}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
+$e = validate({foo => "str"}, $v);
+ok(! $e);
$n = 0;
$v = {foo => {custom => $n}};
-$e = &validate({}, $v);
-&print_ok($e);
-$e = &validate({foo => "str"}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
+$e = validate({foo => "str"}, $v);
+ok($e);
$n = sub { my ($key, $val) = @_; return defined($val) ? 1 : 0};
$v = {foo => {custom => $n}};
-$e = &validate({}, $v);
-&print_ok($e);
-$e = &validate({foo => "str"}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok($e);
+$e = validate({foo => "str"}, $v);
+ok(! $e);
### type checks
$v = {foo => {type => 'ip'}};
-$e = &validate({foo => '209.108.25'}, $v);
-&print_ok($e);
-$e = &validate({foo => '209.108.25.111'}, $v);
-&print_ok(! $e);
+$e = validate({foo => '209.108.25'}, $v);
+ok($e);
+$e = validate({foo => '209.108.25.111'}, $v);
+ok(! $e);
### min_in_set checks
$v = {foo => {min_in_set => '2 of foo bar baz', max_values => 5}};
-$e = &validate({foo => 1}, $v);
-&print_ok($e);
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 1, bar => ''}, $v); # empty string doesn't count as value
-&print_ok($e);
-$e = &validate({foo => 1, bar => 0}, $v);
-&print_ok(! $e);
-$e = &validate({foo => [1, 2]}, $v);
-&print_ok(! $e);
-$e = &validate({foo => [1]}, $v);
-&print_ok($e);
+$e = validate({foo => 1}, $v);
+ok($e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok(! $e);
+$e = validate({foo => 1, bar => ''}, $v); # empty string doesn't count as value
+ok($e);
+$e = validate({foo => 1, bar => 0}, $v);
+ok(! $e);
+$e = validate({foo => [1, 2]}, $v);
+ok(! $e);
+$e = validate({foo => [1]}, $v);
+ok($e);
$v = {foo => {min_in_set => '2 foo bar baz', max_values => 5}};
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok(! $e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok(! $e);
### max_in_set checks
$v = {foo => {max_in_set => '2 of foo bar baz', max_values => 5}};
-$e = &validate({foo => 1}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 1, bar => 1}, $v);
-&print_ok(! $e);
-$e = &validate({foo => 1, bar => 1, baz => 1}, $v);
-&print_ok($e);
-$e = &validate({foo => [1, 2]}, $v);
-&print_ok(! $e);
-$e = &validate({foo => [1, 2, 3]}, $v);
-&print_ok($e);
+$e = validate({foo => 1}, $v);
+ok(! $e);
+$e = validate({foo => 1, bar => 1}, $v);
+ok(! $e);
+$e = validate({foo => 1, bar => 1, baz => 1}, $v);
+ok($e);
+$e = validate({foo => [1, 2]}, $v);
+ok(! $e);
+$e = validate({foo => [1, 2, 3]}, $v);
+ok($e);
### validate_if revisited (but negated - uses max_in_set)
$v = {foo => {required => 1, validate_if => '! bar'}};
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({bar => 1}, $v);
-&print_ok(! $e);
+$e = validate({bar => 1}, $v);
+ok(! $e);
### default value
my $f = {};
$v = {foo => {required => 1, default => 'hmmmm'}};
-$e = &validate($f, $v);
-&print_ok(! $e);
+$e = validate($f, $v);
+ok(! $e);
-&print_ok($f->{foo} && $f->{foo} eq 'hmmmm');
+ok($f->{foo} && $f->{foo} eq 'hmmmm');
-__DATA__
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+1_validate_06_groups.t - Test CGI::Ex::Validate's ability to use groups of validation
-$^W = 1;
+=cut
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+use strict;
+use Test::More tests => 7;
-require CGI::Ex::Validate;
+use_ok('CGI::Ex::Validate');
-my ($N, $v, $e, $ok) = (0);
+my ($v, $e);
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
+sub validate { scalar CGI::Ex::Validate::validate(@_) }
###----------------------------------------------------------------###
raspberry => {required => 1},
}];
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({
+$e = validate({
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
haw => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-__DATA__
# -*- Mode: Perl; -*-
+=head1 NAME
+
+1_validate_07_yaml.t - Check for CGI::Ex::Validate's ability to use YAML.
+
+=cut
+
use strict;
+use Test::More tests => 15;
-$^W = 1;
+SKIP: {
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+skip("Missing YAML.pm", 15) if ! eval { require 'YAML' };
-require CGI::Ex::Validate;
+use_ok('CGI::Ex::Validate');
-my ($N, $v, $e, $ok) = (0);
+my $N = 0;
+my $v;
+my $e;
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
+sub validate { scalar CGI::Ex::Validate::validate(@_) }
###----------------------------------------------------------------###
required_if: bar
';
-$e = &validate({}, $v);
-&print_ok($e);
-$e = &validate({user => 1}, $v);
-&print_ok(! $e);
-$e = &validate({user => 1, bar => 1}, $v);
-&print_ok($e);
-$e = &validate({user => 1, bar => 1, foo => 1}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok($e);
+$e = validate({user => 1}, $v);
+ok(! $e);
+$e = validate({user => 1, bar => 1}, $v);
+ok($e);
+$e = validate({user => 1, bar => 1, foo => 1}, $v);
+ok(! $e);
### three groups, some with validate_if's - using arrayref
required: 1
';
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({
+$e = validate({
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
haw => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
### three groups, some with validate_if's - using documents
required: 1
';
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({
+$e = validate({
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
haw => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-__DATA__
+} # end of SKIP
# -*- Mode: Perl; -*-
+=head1 NAME
+
+1_validate_08_yaml_file.t - Check for CGI::Ex::Validate's ability to load YAML conf files.
+
+=cut
+
use strict;
+use Test::More tests => 22;
-$^W = 1;
+SKIP: {
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+skip("Missing YAML.pm", 22) if ! eval { require 'YAML' };
-require CGI::Ex::Validate;
+use_ok('CGI::Ex::Validate');
-my ($N, $v, $e, $ok) = (0);
+my ($v, $e);
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
+sub validate { scalar CGI::Ex::Validate::validate(@_) }
###----------------------------------------------------------------###
### where are my samples
my $dir = __FILE__;
$dir =~ tr|\\|/|; # should probably use File::Spec
-$dir =~ s|[^/]+$|samples| || die "Couldn't determine dir";
+$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir";
$dir =~ s|^t/|./t/|; # to satisfy conf
### single group
$v = "$dir/yaml1.val";
-$e = &validate({}, $v);
-&print_ok($e);
-$e = &validate({user => 1}, $v);
-&print_ok(! $e);
-$e = &validate({user => 1, bar => 1}, $v);
-&print_ok($e);
-$e = &validate({user => 1, bar => 1, foo => 1}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok($e, 'nothing passed');
+$e = validate({user => 1}, $v);
+ok(! $e, 'user passed');
+$e = validate({user => 1, bar => 1}, $v);
+ok($e, 'user and bar passed');
+$e = validate({user => 1, bar => 1, foo => 1}, $v);
+ok(! $e, 'user and bar and foo passed');
### single group - default extension
$v = "$dir/yaml1";
-$e = &validate({}, $v);
-&print_ok($e);
-$e = &validate({user => 1}, $v);
-&print_ok(! $e);
-$e = &validate({user => 1, bar => 1}, $v);
-&print_ok($e);
-$e = &validate({user => 1, bar => 1, foo => 1}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok($e);
+$e = validate({user => 1}, $v);
+ok(! $e);
+$e = validate({user => 1, bar => 1}, $v);
+ok($e);
+$e = validate({user => 1, bar => 1, foo => 1}, $v);
+ok(! $e);
### three groups, some with validate_if's - using arrayref
$v = "$dir/yaml2.val";
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({
+$e = validate({
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
haw => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
### three groups, some with validate_if's - using documents
$v = "$dir/yaml3.val";
-$e = &validate({}, $v);
-&print_ok($e);
+$e = validate({}, $v);
+ok($e);
-$e = &validate({
+$e = validate({
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
raspberry => 'tart',
}, $v);
-&print_ok($e);
+ok($e);
-$e = &validate({
+$e = validate({
foo => 1,
bar => 1,
hem => 1,
haw => 1,
raspberry => 'tart',
}, $v);
-&print_ok(! $e);
+ok(! $e);
-__DATA__
+} # end of SKIP
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+1_validate_11_no_extra.t - Test CGI::Ex::Validate's ability to not allow extra form fields
-$^W = 1;
+=cut
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+use strict;
+use Test::More tests => 21;
-require CGI::Ex::Validate;
+use_ok('CGI::Ex::Validate');
-my ($N, $v, $e, $ok) = (0);
+my ($v, $e);
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
+sub validate { CGI::Ex::Validate::validate(@_) }
###----------------------------------------------------------------###
},
];
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({foo => "foo"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "foo"}, $v);
+ok(! $e);
-$e = &validate({foo => "foo", bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({foo => "foo", bar => "bar"}, $v);
+ok($e);
-$e = &validate({bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({bar => "bar"}, $v);
+ok($e);
### test on failed validate if
},
];
-$e = &validate({}, $v);
-&print_ok(! $e);
+$e = validate({}, $v);
+ok(! $e);
-$e = &validate({foo => "foo"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "foo"}, $v);
+ok(! $e);
-$e = &validate({foo => "foo", bar => "bar"}, $v);
-&print_ok(! $e);
+$e = validate({foo => "foo", bar => "bar"}, $v);
+ok(! $e);
-$e = &validate({bar => "bar"}, $v);
-&print_ok(! $e);
+$e = validate({bar => "bar"}, $v);
+ok(! $e);
### test on successful validate if
$v = [
},
];
-$e = &validate({baz => 1}, $v);
-&print_ok(! $e);
+$e = validate({baz => 1}, $v);
+ok(! $e);
-$e = &validate({baz => 1, foo => "foo"}, $v);
-&print_ok(! $e);
+$e = validate({baz => 1, foo => "foo"}, $v);
+ok(! $e);
-$e = &validate({baz => 1, foo => "foo", bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({baz => 1, foo => "foo", bar => "bar"}, $v);
+ok($e);
-$e = &validate({baz => 1, bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({baz => 1, bar => "bar"}, $v);
+ok($e);
### test on multiple groups, some with validate if
$v = [
},
];
-$e = &validate({haw => 1, baz => 1}, $v);
-&print_ok(! $e);
+$e = validate({haw => 1, baz => 1}, $v);
+ok(! $e);
-$e = &validate({haw => 1, baz => 1, foo => "foo"}, $v);
-&print_ok(! $e);
+$e = validate({haw => 1, baz => 1, foo => "foo"}, $v);
+ok(! $e);
-$e = &validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
+ok($e);
-$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({haw => 1, baz => 1, bar => "bar"}, $v);
+ok($e);
### test on multiple groups, some with validate if
},
];
-$e = &validate({haw => 1, baz => 1}, $v);
-&print_ok($e);
-
-$e = &validate({haw => 1, baz => 1, foo => "foo"}, $v);
-&print_ok($e);
+$e = validate({haw => 1, baz => 1}, $v);
+ok($e);
-$e = &validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({haw => 1, baz => 1, foo => "foo"}, $v);
+ok($e);
-$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v);
-&print_ok($e);
+$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
+ok($e);
-__DATA__
+$e = validate({haw => 1, baz => 1, bar => "bar"}, $v);
+ok($e);
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+1_validate_12_change.t - Test CGI::Ex::Validate's ability to modify form fields
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /&print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+=cut
-require CGI::Ex::Validate;
+use strict;
+use Test::More tests => 5;
+use strict;
-my ($N, $v, $e, $ok) = (0);
+use_ok('CGI::Ex::Validate');
+my $e;
+my $v;
+sub validate { scalar CGI::Ex::Validate::validate(@_) }
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
###----------------------------------------------------------------###
},
];
-$e = &validate({
+$e = validate({
foo => '123-456-7890',
}, $v);
-&print_ok(! $e);
+ok(! $e);
my $form = {
},
};
-$e = &validate($form, $v);
-&print_ok(! $e && $form->{key1} eq 'Bunch of characters');
+$e = validate($form, $v);
+ok(! $e && $form->{key1} eq 'Bunch of characters');
$v = {
key2 => {
},
};
-$e = &validate($form, $v);
-&print_ok(! $e && $form->{key2} eq '(123) 456-7890');
+$e = validate($form, $v);
+ok(! $e && $form->{key2} eq '(123) 456-7890');
$v = {
},
};
-$e = &validate($form, $v);
-&print_ok($e && $form->{key2} eq '');
+$e = validate($form, $v);
+ok($e && $form->{key2} eq '');
-__DATA__
#!perl -T
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+1_validate_14_untaint.t - Test CGI::Ex::Validate's ability to untaint tested fields
-$^W = 1;
+=cut
+
+use strict;
+use Test::More tests => 14;
+use FindBin qw($Bin);
+use lib ($Bin =~ /(.+)/ ? "$1/../lib" : ''); # add bin - but untaint it
### Set up taint checking
-sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 } }
+sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1; 0 } }
+
+SKIP: {
my $taint = join(",", $0, %ENV, @ARGV);
if (! is_tainted($taint) && open(my $fh, "/dev/urandom")) {
}
$taint = substr($taint, 0, 0);
if (! is_tainted($taint)) {
- print "1..1\nok 1 # skip Couldn't get any tainted data or we aren't in taint mode\n";
- exit;
+ skip("is_tainted doesn't appear to work", 14);
}
### make sure tainted hash values don't bleed into other values
$form->{'foo'} = "123$taint";
$form->{'bar'} = "456$taint";
$form->{'baz'} = "789";
-if (! is_tainted($form->{'foo'})
- || is_tainted($form->{'baz'})) {
- # untaint checking doesn't really work
- print "1..1\nok 1 # skip Hashes with mixed taint don't work right (older perls ?)\n";
- exit;
+if (! is_tainted($form->{'foo'})) {
+ skip("Tainted hash key didn't work right", 14);
+} elsif (is_tainted($form->{'baz'})) {
+ # untaint checking doesn't really work
+ skip("Hashes with mixed taint don't work right", 14);
}
###----------------------------------------------------------------###
### Looks good - here we go
-### determine number of tests
-seek(DATA,0,0);
-my $prog = join "", <DATA>;
-my @tests = ($prog =~ /print_ok\(/g);
-my $tests = @tests;
-print "1..$tests\n";
+use_ok('CGI::Ex::Validate');
-require CGI::Ex::Validate;
+my $e;
-my ($N, $v, $e, $ok) = (0);
+ok(is_tainted($taint));
+ok(is_tainted($form->{'foo'}));
+ok(! is_tainted($form->{'baz'}));
+ok(! is_tainted($form->{'non_existent_key'}));
+sub validate { scalar CGI::Ex::Validate::validate(@_) }
-print_ok(is_tainted($taint));
-print_ok(is_tainted($form->{'foo'}));
-print_ok(! is_tainted($form->{'baz'}));
-print_ok(! is_tainted($form->{'non_existent_key'}));
-
-sub validate {
- return scalar &CGI::Ex::Validate::validate(@_);
-}
-sub print_ok {
- my $ok = shift;
- $N ++;
- warn "Test failed at line ".(caller)[2]."\n" if ! $ok;
- print "" . ($ok ? "" : "not ") . "ok $N\n";
-}
-&print_ok(1);
###----------------------------------------------------------------###
-$e = &validate($form, {
+$e = validate($form, {
foo => {
match => 'm/^\d+$/',
untaint => 1,
},
});
-print_ok(! $e);
-print_ok(! is_tainted($form->{foo}));
+ok(! $e);
+ok(! is_tainted($form->{foo}));
###----------------------------------------------------------------###
-$e = &validate($form, {
+$e = validate($form, {
bar => {
match => 'm/^\d+$/',
},
});
-print_ok(! $e);
-print_ok(is_tainted($form->{bar}));
+ok(! $e);
+ok(is_tainted($form->{bar}));
###----------------------------------------------------------------###
-$e = &validate($form, {
+$e = validate($form, {
bar => {
untaint => 1,
},
});
-print_ok($e);
+ok($e);
#print $e if $e;
-print_ok(is_tainted($form->{bar}));
+ok(is_tainted($form->{bar}));
###----------------------------------------------------------------###
-print_ok(!is_tainted($form->{foo}));
-print_ok( is_tainted($form->{bar}));
-print_ok(!is_tainted($form->{baz}));
+ok(!is_tainted($form->{foo}));
+ok( is_tainted($form->{bar}));
+ok(!is_tainted($form->{baz}));
+
+}
-__DATA__
+# -*-perl-*-
-BEGIN {
- print "1..1\n";
-}
+=head1 NAME
-use CGI::Ex::Fill;
+2_fill_00_base.t - Test CGI::Ex::Fill's base ability.
-BEGIN { print "ok 1\n"; }
+=cut
+
+use strict;
+use Test::More tests => 6;
+
+use_ok qw(CGI::Ex::Fill);
+
+###----------------------------------------------------------------###
+
+ my $form = {foo => "FOO", bar => "BAR", baz => "BAZ"};
+
+ my $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=bar value="">
+ <input type=text name=baz value="Something else">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw>
+ ';
+
+ CGI::Ex::Fill::form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <input type=text name=foo value="FOO">
+ <input type=text name=foo value="FOO">
+ <input type=text name=bar value="BAR">
+ <input type=text name=baz value="BAZ">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw value="">
+ ', "perldoc example 1 passed");
+
+ #print $html;
+
+###----------------------------------------------------------------###
+
+ $form = {foo => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <input type=text name=foo value="aaaa">
+ <input type=text name=foo value="bbbb">
+ <input type=text name=foo value="cccc">
+ <input type=text name=foo value="">
+ <input type=text name=foo value="">
+ ', "Perldoc example 2 passed");
+
+ #print $html;
+
+###----------------------------------------------------------------###
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc'], baz => 'on'};
+
+ $html = '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO">
+ <input type=checkbox name=bar value="aaaa">
+ <input type=checkbox name=bar value="cccc">
+ <input type=checkbox name=bar value="dddd" checked="checked">
+ <input type=checkbox name=baz>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO" checked="checked">
+ <input type=checkbox name=bar value="aaaa" checked="checked">
+ <input type=checkbox name=bar value="cccc" checked="checked">
+ <input type=checkbox name=bar value="dddd">
+ <input type=checkbox name=baz checked="checked">
+ ', "Perldoc example 3 passed");
+
+ #print $html;
+
+###----------------------------------------------------------------###
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <select name=foo><option>FOO<option>123<br>
+
+ <select name=bar>
+ <option>aaaa</option>
+ <option value="cccc">cccc</option>
+ <option value="dddd" selected="selected">dddd</option>
+ </select>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <select name=foo><option selected="selected">FOO<option>123<br>
+
+ <select name=bar>
+ <option selected="selected">aaaa</option>
+ <option value="cccc" selected="selected">cccc</option>
+ <option value="dddd">dddd</option>
+ </select>
+ ', "Perldoc example 4 passed");
+
+# print $html;
+
+###----------------------------------------------------------------###
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb']};
+
+ $html = '
+ <textarea name=foo></textarea>
+ <textarea name=foo></textarea>
+
+ <textarea name=bar>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>dddd</textarea><br>
+ <textarea name=bar><br><br>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <textarea name=foo>FOO</textarea>
+ <textarea name=foo>FOO</textarea>
+
+ <textarea name=bar>aaaa<textarea name=bar>bbbb</textarea><br>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>', "Perldoc example 5 passed");
+
+# print $html;
+
+###----------------------------------------------------------------###
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_01_form.t - Test CGI::Ex::Fill's ability to fill hidden fields
-print "1..2\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = '
<INPUT TYPE="TEXT" NAME="foo1" value="nada">
foo2 => '"bar2"');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output =~ m/^\s*<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value=""bar2"")){3}\s*\/>\s*$/i){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 2\n";
-}
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^\s*<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value=""bar2"")){3}\s*\/>\s*$/i,
+ "Basic case insensitive match worked ($output)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_02_hidden.t - Test CGI::Ex::Fill's ability to fill hidden fields
-print "1..2\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<input type="hidden" name="foo1">
<input type="hidden" name="foo2" value="ack">};
my %fdat = (foo1a => 'bar1a',
- foo2 => ['bar2','bar3']);
-
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output =~ m/^<input( (type="hidden"|name="foo1"|value="")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/){
- print "ok 2\n";
-} else {
- print "Got unexpected out for hidden form:\n$output\n";
- print "not ok 2\n";
-}
+ foo2 => ['bar2','bar3'],
+ );
+
+
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^<input( (type="hidden"|name="foo1"|value="")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/,
+ "Hidden should've matched ($output)");
+
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_03_checkbox.t - Test CGI::Ex::Fill's ability to fill checkboxes fields
-print "1..2\n";
+=cut
-use CGI::Ex;
+use Test::More tests => 2;
+use strict;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<input type="checkbox" name="foo1" value="bar1">
<input type="checkbox" name="foo1" value="bar2">
foo7 => 'on',
foo8 => '');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
my $is_checked = join(" ",map { m/checked/i ? "yes" : "no" } split ("\n",$output));
-if ($is_checked eq "yes no no yes yes no no no no no yes no yes no yes no"){
- print "ok 2\n";
-} else {
- print "Got unexpected is_checked for checkboxes:\n$is_checked\n";
- print "not ok 2\n";
-}
+ok($is_checked eq "yes no no yes yes no no no no no yes no yes no yes no",
+ "Checkboxes should match ($is_checked)");
+
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_04_select.t - Test CGI::Ex::Fill's ability to fill select fields
-print "1..5\n";
+=cut
-use CGI::Ex;
-use CGI;
+use strict;
+use Test::More tests => 5;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<select multiple name="foo1">
<option value="0">bar1</option>
<option selected value="bar2">bar2</option>
<option value="bar3">bar3</option>
</select>};
-my $q = new CGI( { foo1 => '0',
- foo2 => ['bar1', 'bar2',],
- foo3 => '' }
- );
+my $q = {
+ foo1 => '0',
+ foo2 => ['bar1', 'bar2',],
+ foo3 => '',
+};
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => $q);
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ $q);
my $is_selected = join(" ",map { m/selected/ ? "yes" : "no" } grep /option/, split ("\n",$output));
-if ($is_selected eq "yes no no yes yes no no no no no yes no"){
- print "ok 2\n";
-} else {
- print "Got unexpected is_seleced for select menus:\n$is_selected\n$output\n";
- print "not ok 2\n";
-}
+ok($is_selected eq "yes no no yes yes no no no no no yes no",
+ "Selected should match ($is_selected)");
+
$hidden_form_in = qq{<select multiple name="foo1">
<option>bar1</option>
<option>bar3 </option>
</select>};
-$q = new CGI( { foo1 => 'bar1',
- foo2 => ['bar1', 'bar2',],
- foo3 => '' }
- );
+$q = {
+ foo1 => 'bar1',
+ foo2 => ['bar1', 'bar2',],
+ foo3 => '',
+};
-$fif = new CGI::Ex;
-$output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => $q);
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ $q);
$is_selected = join(" ",map { m/selected/ ? "yes" : "no" } grep /option/, split ("\n",$output));
-if ($is_selected eq "yes no no yes yes no no no no no yes no"){
- print "ok 3\n";
-} else {
- print "Got unexpected is_seleced for select menus:\n$is_selected\n$output\n";
- print "not ok 3\n";
-}
+ok($is_selected eq "yes no no yes yes no no no no no yes no",
+ "Selected should match ($is_selected)");
# test empty option tag
$hidden_form_in = qq{<select name="x"><option></select>};
-$fif = new CGI::Ex;
-$output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => $q);
-if ($output eq qq{<select name="x"><option></select>}){
- print "ok 4\n";
-} else {
- print "Got unexpected output for empty option:\n$output\n";
- print "not ok 4\n";
-}
+
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ $q);
+ok($output eq qq{<select name="x"><option></select>},
+ "Should match ($output)");
$hidden_form_in = qq{<select name="foo1"><option><option value="bar1"></select>};
-$fif = new CGI::Ex;
-$output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => $q);
-if ($output =~ m!^<select name="foo1"><option><option( selected(="selected")?| value="bar1"){2}></select>$!){
- print "ok 5\n";
-} else {
- print "Got unexpected output for empty option:\n$output\n";
- print "not ok 5\n";
-}
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ $q);
+ok($output =~ m!^<select name="foo1"><option><option( selected(="selected")?| value="bar1"){2}></select>$!,
+ "Should match ($output)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_05_textarea.t - Test CGI::Ex::Fill's ability to fill textarea fields
-print "1..3\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 3;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<TEXTAREA NAME="foo">blah</TEXTAREA>};
my %fdat = (foo => 'bar>bar');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output eq '<TEXTAREA NAME="foo">bar>bar</TEXTAREA>'){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 2\n";
-}
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output eq '<TEXTAREA NAME="foo">bar>bar</TEXTAREA>',
+ "Output should match ($output)");
# empty fdat test
%fdat = (foo => '');
-$fif = new CGI::Ex;
-$output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output eq '<TEXTAREA NAME="foo"></TEXTAREA>'){
- print "ok 3\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 3\n";
-}
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output eq '<TEXTAREA NAME="foo"></TEXTAREA>',
+ "Output should match ($output)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_06_radio.t - Test CGI::Ex::Fill's ability to fill radio fields
-print "1..2\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<INPUT TYPE="radio" NAME="foo1" value="bar1">
<input type="radio" name="foo1" value="bar2">
my %fdat = (foo1 => 'bar2');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
my $is_checked = join(" ",map { m/checked/ ? "yes" : "no" } split ("\n",$output));
-if ($is_checked eq 'no yes no no'){
- print "ok 2\n";
-} else {
- print "Got unexpected is_checked:\n$is_checked\n";
- print "not ok 2\n";
-}
+ok($is_checked eq 'no yes no no',
+ "Should match ($is_checked)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_02_hidden.t - Test CGI::Ex::Fill's ability to fill refill used fields
-print "1..2\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<INPUT TYPE="TEXT" NAME="foo1" value="nada">
<input type="hidden" name="foo2">};
my %fdat = (foo1 => ['bar1'],
foo2 => 'bar2');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-my $output2 = $fif->fill(scalarref => \$output,
- fdat => \%fdat);
-if ($output2 =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output2\n";
- print "not ok 2\n";
-}
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+my $output2 = CGI::Ex::Fill::form_fill($output,
+ \%fdat);
+ok($output2 =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i,
+ "Should match ($output2)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+2_fill_08_multiple_objects.t - Test CGI::Ex::Fill's ability to fill using multiple form objects
-$^W = 1;
+=cut
+
+use strict;
+use Test::More tests => 2;
-print "1..2\n";
+use_ok('CGI::Ex::Fill');
-use CGI::Ex;
-use CGI;
+SKIP: {
-print "ok 1\n";
+skip('CGI.pm not found', 1) if ! eval { require CGI };
my $hidden_form_in = qq{<INPUT TYPE="TEXT" NAME="foo1" value="nada">
<input type="hidden" name="foo2">};
my %fdat = (foo1 => 'bar1',
- foo2 => 'bar2');
-
-my $q1 = new CGI( { foo1 => 'bar1' });
-my $q2 = new CGI( { foo2 => 'bar2' });
-
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => [$q1, $q2]);
-if ($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 2\n";
-}
+ foo2 => 'bar2');
+
+my $q1 = CGI->new({ foo1 => 'bar1' });
+my $q2 = CGI->new({ foo2 => 'bar2' });
+
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ [$q1, $q2]);
+ok($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i,
+ "Should match ($output)");
+
+}; #end of SKIP
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+2_fill_09_default_type.t - Test CGI::Ex::Fill's ability to set default falues
-$^W = 1;
+=cut
-print "1..2\n";
+use strict;
+use Test::More tests => 2;
-use CGI::Ex;
+use_ok('CGI::Ex::Fill');
-print "ok 1\n";
my $hidden_form_in = qq{<INPUT NAME="foo1" value="nada">
<input type="hidden" name="foo2">};
my %fdat = (foo1 => 'bar1',
foo2 => 'bar2');
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output =~ m/^<input( (name="foo1"|value="bar1")){2}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 2\n";
-}
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^<input( (name="foo1"|value="bar1")){2}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/i,
+ "Should match ($output)");
# -*- Mode: Perl; -*-
+=head1 NAME
+
+2_fill_10_escape.t - Make sure CGI::Ex::Fill works with escaped values.
+
+=cut
+
use strict;
+use Test::More tests => 2;
+
+use_ok('CGI::Ex::Fill');
-print "1..1\n";
-use CGI::Ex;
-
my $html =<<"__HTML__";
<HTML>
<BODY>
my %fdat = ();
-my $fif = CGI::Ex->new;
-my $output = $fif->fill(scalarref => \$html,
- fdat => \%fdat);
+my $output = CGI::Ex::Fill::form_fill($html,
+ \%fdat);
# FIF changes order of HTML attributes, so split strings and sort
my $strings_output = join("\n", sort split(/[\s><]+/, lc($output)));
my $strings_html = join("\n", sort split(/[\s><]+/, lc($html)));
-unless ($strings_output eq $strings_html){
- print "not ";
-}
-print "ok 1";
+ok($strings_output eq $strings_html,
+ "Strings matched");
# -*- Mode: Perl; -*-
+=head1 NAME
+
+2_fill_11_target.t - Test CGI::Ex::Fill's ability to fill hidden fields
+
+=cut
+
use strict;
-use Test;
-BEGIN { plan tests => 3 }
+use Test::More tests => 4;
-use CGI::Ex;
+use_ok('CGI::Ex::Fill');
my $form = <<EOF;
<FORM name="foo1">
</FORM>
EOF
;
-
+
my %fdat = (
foo1 => 'bar1',
foo2 => 'bar2',
foo3 => 'bar3',
);
-my $fif = new CGI::Ex;
-my $output = $fif->fill(
- scalarref => \$form,
- fdat => \%fdat,
- target => 'foo2',
-);
+my $output = CGI::Ex::Fill::form_fill($form, \%fdat, 'foo2');
my @v = $output =~ m/<input .*?value="(.*?)"/ig;
-ok($v[0], 'nada');
-ok($v[1], 'bar2');
-ok($v[2], 'nada');
+ok($v[0] eq 'nada');
+ok($v[1] eq 'bar2');
+ok($v[2] eq 'nada');
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_12_mult.t - Test CGI::Ex::Fill's ability to fill multiple instances of the same field name
-print "1..3\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 4;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<INPUT TYPE="TEXT" NAME="foo1" value="cat1">
<input type="text" name="foo1" value="cat2"/>};
my %fdat = (foo1 => ['bar1','bar2']);
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="text"|name="foo1"|value="bar2")){3}\s*\/>$/i){
- print "ok 2\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 2\n";
-}
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="text"|name="foo1"|value="bar2")){3}\s*\/>$/i,
+ "Should match ($output)");
+
%fdat = (foo1 => ['bar1']);
-$output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => \%fdat);
-if ($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="text"|name="foo1"|value="")){3}\s*\/>$/i){
- print "ok 3\n";
-} else {
- print "Got unexpected out for $hidden_form_in:\n$output\n";
- print "not ok 3\n";
-}
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="text"|name="foo1"|value="")){3}\s*\/>$/i,
+ "Should match ($output)");
+
+%fdat = (foo1 => 'bar1');
+
+$output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ \%fdat);
+ok($output =~ m/^<input( (type="TEXT"|name="foo1"|value="bar1")){3}>\s*<input( (type="text"|name="foo1"|value="bar1")){3}\s*\/>$/i,
+ "Should match ($output)");
# -*- Mode: Perl; -*-
-#!/usr/bin/perl -w
+=head1 NAME
+
+2_fill_13_warning.t - Check for no warning on a special case - I can't remember what it was though
+
+=cut
+
+use strict;
+use Test::More tests => 2;
# emits warnings for HTML::FIF <= 0.22
-use CGI qw(:no_debug);
-use CGI::Ex;
-use Test;
-
-BEGIN { plan tests => 1 }
-
-local $/;
-my $html = qq{<input type="submit" value="Commit">};
-
-my $q = new CGI;
-
-$q->param( "name", "John Smith" );
-my $fif = new CGI::Ex;
-my $output = $fif->fill(
- scalarref => \$html,
- fobject => $q
-);
-
-ok($html =~ m!<input( type="submit"| value="Commit"){2}>!);
+use_ok('CGI::Ex::Fill');
+
+SKIP: {
+ skip("CGI.pm not found", 1) if ! eval { require CGI };
+ CGI->import(':no_debug');
+
+ local $/;
+ my $html = qq{<input type="submit" value="Commit">};
+
+ my $q = CGI->new;
+
+ $q->param( "name", "John Smith" );
+ my $output = CGI::Ex::Fill::form_fill($html, $q);
+
+ ok($html =~ m!<input( type="submit"| value="Commit"){2}>!);
+};
# -*- Mode: Perl; -*-
-#!/usr/bin/perl -w
+=head1 NAME
-use CGI qw(:no_debug);
-use CGI::Ex;
-use Test;
+2_fill_13_password.t - Test CGI::Ex::Fill's ability to not fill passwords
-BEGIN { plan tests => 2 }
+=cut
+
+use strict;
+use Test::More tests => 3;
+
+use_ok('CGI::Ex::Fill');
local $/;
my $html = qq{<input type="password" name="foo">};
-my $q = new CGI;
-$q->param( foo => 'bar' );
-
-{
- my $fif = new CGI::Ex;
- my $output = $fif->fill(
- scalarref => \$html,
- fobject => $q,
- fill_password => 0,
- );
-
- ok($output !~ /value="bar"/);
-}
-
-
-{
- my $fif = new CGI::Ex;
- my $output = $fif->fill(
- scalarref => \$html,
- fobject => $q,
-# fill_password => 1,
- );
-
- ok($output =~ /value="bar"/);
-}
+my $q = {foo => 'bar'};
+
+my $output = CGI::Ex::Fill::form_fill($html, $q, undef, 0);
+ok($output !~ /value="bar"/);
+
+$output = CGI::Ex::Fill::form_fill($html, $q, undef);
+ok($output =~ /value="bar"/);
+
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_16_ignore_fields.t - Test CGI::Ex::Fill's ability to fill ignore some fields
-print "1..2\n";
+=cut
-use CGI::Ex;
-use CGI;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $hidden_form_in = qq{<select multiple name="foo1">
<option value="0">bar1</option>
<option selected value="bar2">bar2</option>
<option value="bar3">bar3</option>
</select>};
-my $q = new CGI( { foo1 => '0',
- foo2 => ['bar1', 'bar2',],
- foo3 => '' }
- );
+my $q = {
+ foo1 => '0',
+ foo2 => ['bar1', 'bar2',],
+ foo3 => '',
+};
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fobject => $q,
- ignore_fields => ['asdf','foo1','asdf']);
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in, $q, undef, undef, ['asdf','foo1','asdf']);
my $is_selected = join(" ",map { m/selected/ ? "yes" : "no" } grep /option/, split ("\n",$output));
-if ($is_selected eq "no no no yes yes no no no no no yes no"){
- print "ok 2\n";
-} else {
- print "Got unexpected is_seleced for select menus:\n$is_selected\n$output\n";
- print "not ok 2\n";
-}
-
+ok($is_selected eq "no no no yes yes no no no no no yes no",
+ "Should match ($is_selected)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
+
+2_fill_17_xhtml.t - Test CGI::Ex::Fill's ability to play nice with XHTML
-$^W = 1;
+=cut
-print "1..1\n";
+use strict;
+use Test::More tests => 2;
-use CGI::Ex;
-use CGI;
+use_ok('CGI::Ex::Fill');
my $html = <<EOF;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
</html>
EOF
-my $q = CGI->new;
-$q->param('status', 1 );
+my $q = {
+ status => 1,
+};
-my $fif = CGI::Ex->new;
-
-my $output = $fif->fill(
- scalarref => \$html,
- fobject => $q
-);
+my $output = CGI::Ex::Fill::form_fill($html, $q);
my $matches;
while ($output =~ m!( />)!g) {
$matches++;
}
-if ($matches == 6) {
- print "ok 1\n";
-} else {
- print "not ok 1\n";
-}
-
-print $output;
+ok($matches == 6,
+ "Had correct matches ($output)");
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_18_coderef.t - Test CGI::Ex::Fill's ability to use coderef callbacks
-print "1..4\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 4;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $ok2 = 0;
my $ok3 = 0;
return ($key eq 'foo2') ? 'bar2' : '';
};
-my $fif = new CGI::Ex;
-my $output = $fif->fill(scalarref => \$hidden_form_in,
- fdat => [\%fdat, $cdat]);
+my $output = CGI::Ex::Fill::form_fill($hidden_form_in,
+ [\%fdat, $cdat]);
+
+ok($ok2);
+ok($ok3);
-print "" . ($ok2 ? "" : "not ") . "ok 2\n";
-print "" . ($ok3 ? "" : "not ") . "ok 3\n";
+ok($output =~ m/^<input( (type="hidden"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/,
+ "Should match ($output)");
-if ($output =~ m/^<input( (type="hidden"|name="foo1"|value="bar1")){3}>\s*<input( (type="hidden"|name="foo2"|value="bar2")){3}>$/){
- print "ok 4\n";
-} else {
- print "Got unexpected out for hidden form:\n$output\n";
- print "not ok 4\n";
-}
# -*- Mode: Perl; -*-
-use strict;
+=head1 NAME
-$^W = 1;
+2_fill_19_complex.t - Test CGI::Ex::Fill's regex against difficult tags (with embeded html)
-print "1..2\n";
+=cut
-use CGI::Ex;
+use strict;
+use Test::More tests => 2;
-print "ok 1\n";
+use_ok('CGI::Ex::Fill');
my $string = qq{
<input attr="<br value='waw'>
my %fdat = (foo1 => 'bar1');
-my $cgix = new CGI::Ex;
-$cgix->fill(text => \$string,
- form => \%fdat,
- );
+CGI::Ex::Fill::form_fill(\$string,
+ \%fdat,
+ );
-if ($string =~ m/ value="bar1"/) {
- print "ok 2\n";
-} else {
- print "not ok 2\n";
-}
+ok($string =~ m/ value="bar1"/,
+ "Should match ($string)");
# -*- Mode: Perl; -*-
+=head1 NAME
+
+2_fill_20_switcharoo.t - Test CGI::Ex::Fill's ability to handle many different types of broken html tags
+
+=cut
+
use strict;
-$^W = 1;
-print "1..27\n";
-use CGI::Ex;
-print "ok 1\n";
+use Test::More tests => 27;
+
+use_ok('CGI::Ex::Fill');
my $string;
my %fdat = (foo1 => 'bar1');
-my $cgix = new CGI::Ex;
-my $n = 1;
-my $dook = sub {
- $n ++;
- print "$n - ($string)\n";
+my $do_ok = sub {
my @a;
- if ($string =~ m/ value=([\"\'])bar1\1/i
- && 1 == scalar(@a=$string =~ m/(value)/gi)) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- }
+ ok($string =~ m/ value=([\"\'])bar1\1/i
+ && 1 == scalar(@a=$string =~ m/(value)/gi), "Should match ($string)");
};
###----------------------------------------------------------------###
$string = qq{<input name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input name=foo1>};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input name=foo1 />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value value name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value value="" name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input grrr name="foo1" value="">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value= name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input type=hidden value= name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value= type="hidden" name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value="" name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value='' name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input value='one' name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input Value="one" name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input VALUE="one" name="foo1">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<input name="foo1" value="one">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="one">};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="one" >};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="" >};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE= >};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE >};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE= />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="" />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="one" />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
$string = qq{<INPUT NAME="foo1" VALUE="one" />};
-$cgix->fill(text => \$string, form => \%fdat);
-&$dook();
+CGI::Ex::Fill::form_fill(\$string, \%fdat);
+$do_ok->();
# -*- Mode: Perl; -*-
-use Test;
+=head1 NAME
-BEGIN {plan tests => 24};
+3_conf_00_base.t - Test for the basic functionality of CGI::Ex::Conf
-use CGI::Ex::Conf;
-ok(1);
+=cut
-my $dir = $0;
+use strict;
+use Test::More tests => 24;
+
+use_ok('CGI::Ex::Conf');
+
+my $dir = __FILE__;
$dir =~ tr|\\|/|; # should probably use File::Spec
-$dir =~ s|/[^/]+$||;
-$dir = '.' if ! length $dir;
-$dir .= '/samples';
+$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir";
+$dir =~ s|^t/|./t/|; # to satisfy conf
+
my $obj = CGI::Ex::Conf->new({
paths => ["$dir/conf_path_1", "$dir/conf_path_3"],
});
# -*- Mode: Perl; -*-
-use Test;
+=head1 NAME
-BEGIN {plan tests => 12};
+3_conf_01_write.t - Test CGI::Ex::Conf's ability to write and read the various file types.
-use CGI::Ex::Conf;
-ok(1);
+=cut
-my $dir = $0;
+use strict;
+use Test::More tests => 18;
+
+use_ok('CGI::Ex::Conf');
+
+my $dir = __FILE__;
$dir =~ tr|\\|/|; # should probably use File::Spec
-$dir =~ s|/[^/]+$||;
-$dir = '.' if ! length $dir;
-$dir .= '/samples';
+$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir";
+$dir =~ s|^t/|./t/|; # to satisfy conf
+
my $obj = CGI::Ex::Conf->new({
paths => ["$dir/conf_path_1", "$dir/conf_path_3"],
});
bar => 'Bar',
},
};
-
-my $file = $tmpfile .'.yaml';
-ok( eval { $obj->write_ref($file, $hash) } );
-my $in = $obj->read_ref($file);
-ok($in->{'three'}->{'foo'} eq 'Foo');
-unlink $file;
-
-$file = $tmpfile .'.sto';
-ok( eval { $obj->write_ref($file, $hash) } );
-$in = $obj->read_ref($file);
-ok($in->{'three'}->{'foo'} eq 'Foo');
-unlink $file;
+my $file;
+my $in;
$file = $tmpfile .'.pl';
ok( eval { $obj->write_ref($file, $hash) } );
ok($in->{'three'}->{'foo'} eq 'Foo');
unlink $file;
-#$file = $tmpfile .'.xml';
-#ok( eval { $obj->write_ref($file, $hash) } );
-#$in = $obj->read_ref($file);
-#ok($in->{'three'}->{'foo'} eq 'Foo');
-#unlink $file;
-#
-#### ini likes hash O' hashes
-#$hash->{'one'} = {};
-#$hash->{'two'} = {};
-#$file = $tmpfile .'.ini';
-#ok( eval { $obj->write_ref($file, $hash) } );
-#$in = $obj->read_ref($file);
-#ok($in->{'three'}->{'foo'} eq 'Foo');
-#unlink $file;
-
-ok (eval { $obj->write('FooSpace', $hash) });
-ok (unlink $obj->{'paths'}->[1] . '/FooSpace.conf');
-
-ok (eval { $obj->write('FooSpace', $hash, {directive => 'FIRST'}) });
-ok (unlink $obj->{'paths'}->[0] . '/FooSpace.conf');
+SKIP: {
+ skip("YAML.pm not found", 2) if ! eval { require YAML };
+ my $file = $tmpfile .'.yaml';
+ ok( eval { $obj->write_ref($file, $hash) } );
+ my $in = $obj->read_ref($file);
+ ok($in->{'three'}->{'foo'} eq 'Foo');
+ unlink $file;
+};
+
+SKIP: {
+ skip("JSON.pm not found", 2) if ! eval { require JSON };
+ my $file = $tmpfile .'.json';
+ ok( eval { $obj->write_ref($file, $hash) } );
+ my $in = $obj->read_ref($file);
+ ok($in->{'three'}->{'foo'} eq 'Foo');
+ unlink $file;
+};
+
+SKIP: {
+ skip("Storable.pm not found", 2) if ! eval { require Storable };
+ $file = $tmpfile .'.sto';
+ ok( eval { $obj->write_ref($file, $hash) } );
+ $in = $obj->read_ref($file);
+ ok($in->{'three'}->{'foo'} eq 'Foo');
+ unlink $file;
+};
+
+SKIP: {
+ skip("XML::Simple not found", 2) if ! eval { require XML::Simple };
+ $file = $tmpfile .'.xml';
+ ok( eval { $obj->write_ref($file, $hash) } );
+ $in = $obj->read_ref($file);
+ ok($in->{'three'}->{'foo'} eq 'Foo');
+ unlink $file;
+};
+
+SKIP: {
+ skip("Config::IniHash not found", 2) if ! eval { require Conifg::IniHash };
+ ### ini likes hash O' hashes
+ $hash->{'one'} = {};
+ $hash->{'two'} = {};
+ $file = $tmpfile .'.ini';
+ ok( eval { $obj->write_ref($file, $hash) } );
+ $in = $obj->read_ref($file);
+ ok($in->{'three'}->{'foo'} eq 'Foo');
+ unlink $file;
+};
+
+SKIP: {
+ skip('YAML.pm still not found', 4) if ! eval { require YAML };
+ ok (eval { $obj->write('FooSpace', $hash) });
+ ok (unlink $obj->{'paths'}->[1] . '/FooSpace.conf');
+
+ ok (eval { $obj->write('FooSpace', $hash, {directive => 'FIRST'}) });
+ ok (unlink $obj->{'paths'}->[0] . '/FooSpace.conf');
+};
# -*- Mode: Perl; -*-
-use Test;
+=head1 NAME
-BEGIN {plan tests => 2};
+4_app_00_base.t - Check for the basic functionality of CGI::Ex::App.
-use CGI::Ex::App;
-ok(1);
+=cut
-my $obj = CGI::Ex::App->new({
-});
-ok($obj);
+use Test::More tests => 3;
+use strict;
+
+{
+ package Foo;
+
+ use base qw(CGI::Ex::App);
+ use vars qw($test_stdout);
+
+ sub ready_validate { 1 }
+
+ sub print_out {
+ my $self = shift;
+ my $step = shift;
+ $test_stdout = shift;
+ }
+
+ sub swap_template {
+ my ($self, $step, $file, $swap) = @_;
+ my $out = ref($file) ? $$file : "No filenames allowed during test mode";
+ $self->cgix->swap_template(\$out, $swap);
+ return $out;
+ }
+
+ ###----------------------------------------------------------------###
+
+ sub main_info_complete { 0 }
+
+ sub main_file_print { return \ "Main Content" }
+
+ sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} }
+
+ sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) <input type=text name=wow>[% wow_error %]" }
+
+ sub step2_hash_swap { return {foo => 'bar', one => 'two'} }
+
+ sub step2_hash_fill { return {wow => 'wee'} }
+
+ sub step2_finalize { shift->append_path('step3') }
+
+ sub step3_info_complete { 0 }
+
+ sub step3_file_print { return \ "All good" }
+
+}
+
+###----------------------------------------------------------------###
+
+#$ENV{'REQUEST_METHOD'} = 'GET';
+#$ENV{'QUERY_STRING'} = '';
+
+Foo->new({
+ form => {},
+})->navigate;
+ok($Foo::test_stdout eq "Main Content");
+
+###----------------------------------------------------------------###
+
+#$ENV{'REQUEST_METHOD'} = 'GET';
+#$ENV{'QUERY_STRING'} = 'step=step2';
+
+Foo->new({
+ form => {step => 'step2'},
+})->navigate;
+ok($Foo::test_stdout eq "Some step2 content (bar, two) <input type=text name=wow value=\"wee\">wow is required");
+
+###----------------------------------------------------------------###
+
+#$ENV{'REQUEST_METHOD'} = 'GET';
+#$ENV{'QUERY_STRING'} = 'step=step2&wow=something';
+
+Foo->new({
+ form=> {step => 'step2', wow => 'something'},
+})->navigate;
+ok($Foo::test_stdout eq "All good");
# -*- Mode: Perl; -*-
-use Test;
+=head1 NAME
-BEGIN {plan tests => 1};
+5_dump_00_base.t - Very basic testing of CGI::Ex::Dump.
-use CGI::Ex::Dump ();
-ok(1);
+=cut
+
+use Test::More tests => 1;
+
+use_ok('CGI::Ex::Dump');
# -*- Mode: Perl; -*-
-use Test;
+=head1 NAME
-BEGIN {plan tests => 2};
+6_die_00_base.t - Very basic testing of the Die module.
-use CGI::Ex::Die;
-ok(1);
+=cut
+
+use Test::More tests => 2;
+
+use_ok('CGI::Ex::Die');
ok(eval {
import CGI::Ex::Die register => 1;
--- /dev/null
+# -*- Mode: Perl; -*-
+
+=head1 NAME
+
+7_template_00_base.t - Test the basic language functionality of CGI::Ex::Template - including many edge cases
+
+=cut
+
+use vars qw($module $is_tt);
+BEGIN {
+ $module = 'CGI::Ex::Template'; #real 0m1.243s #user 0m0.695s #sys 0m0.018s
+ #$module = 'Template'; #real 0m2.329s #user 0m1.466s #sys 0m0.021s
+ $is_tt = $module eq 'Template';
+};
+
+use strict;
+use Test::More tests => 460 - ($is_tt ? 54 : 0);
+use Data::Dumper qw(Dumper);
+use constant test_taint => 0 && eval { require Taint::Runtime };
+
+use_ok($module);
+
+Taint::Runtime::taint_start() if test_taint;
+
+###----------------------------------------------------------------###
+
+sub process_ok { # process the value and say if it was ok
+ my $str = shift;
+ my $test = shift;
+ my $vars = shift;
+ my $obj = shift || $module->new(@{ $vars->{tt_config} || [] }); # new object each time
+ my $out = '';
+
+ Taint::Runtime::taint(\$str) if test_taint;
+
+ $obj->process(\$str, $vars, \$out);
+ my $ok = ref($test) ? $out =~ $test : $out eq $test;
+ ok($ok, "\"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\""));
+ my $line = (caller)[2];
+ warn "# process_ok called at line $line.\n" if ! $ok;
+ print $obj->error if ! $ok && $obj->can('error');
+ print Dumper $obj->parse_tree(\$str) if ! $ok && $obj->can('parse_tree');
+ exit if ! $ok;
+}
+
+###----------------------------------------------------------------###
+
+### set up some dummy packages for various tests
+{
+ package MyTestPlugin::Foo;
+ $INC{'MyTestPlugin/Foo.pm'} = $0;
+ sub load { $_[0] }
+ sub new {
+ my $class = shift;
+ my $context = shift; # note the plugin style object that needs to shift off context
+ my $args = shift || {};
+ return bless $args, $class;
+ }
+ sub bar { my $self = shift; return join('', map {"$_$self->{$_}"} sort keys %$self) }
+ sub seven { 7 }
+ sub many { return 1, 2, 3 }
+ sub echo { my $self = shift; $_[0] }
+}
+{
+ package Foo2;
+ $INC{'Foo2.pm'} = $0;
+ use base qw(MyTestPlugin::Foo);
+ use vars qw($AUTOLOAD);
+ sub new {
+ my $class = shift;
+ my $args = shift || {}; # note - no plugin context
+ return bless $args, $class;
+ }
+ sub leave {} # hacks to allow tt to do the plugins passed via PLUGINS
+ sub delocalise {} # hacks to allow tt to do the plugins passed via PLUGINS
+}
+
+my $obj = Foo2->new;
+
+
+###----------------------------------------------------------------###
+### variable GETting
+
+process_ok("[% foo %]" => "");
+process_ok("[% foo %]" => "7", {foo => 7});
+process_ok("[% foo %]" => "7", {tt_config => [VARIABLES => {foo => 7}]});
+process_ok("[% foo %]" => "7", {tt_config => [PRE_DEFINE => {foo => 7}]});
+process_ok("[% foo %][% foo %][% foo %]" => "777", {foo => 7});
+process_ok("[% foo() %]" => "7", {foo => 7});
+process_ok("[% foo.bar %]" => "");
+process_ok("[% foo.bar %]" => "", {foo => {}});
+process_ok("[% foo.bar %]" => "7", {foo => {bar => 7}});
+process_ok("[% foo().bar %]" => "7", {foo => {bar => 7}});
+process_ok("[% foo.0 %]" => "7", {foo => [7, 2, 3]});
+process_ok("[% foo.10 %]" => "", {foo => [7, 2, 3]});
+process_ok("[% foo %]" => 7, {foo => sub { 7 }});
+process_ok("[% foo(7) %]" => 7, {foo => sub { $_[0] }});
+process_ok("[% foo.length %]" => 1, {foo => sub { 7 }});
+process_ok("[% foo.0 %]" => 7, {foo => sub { return 7, 2, 3 }});
+process_ok("[% foo(bar) %]" => 7, {foo => sub { $_[0] }, bar => 7});
+process_ok("[% foo.seven %]" => 7, {foo => $obj});
+process_ok("[% foo.seven() %]" => 7, {foo => $obj});
+process_ok("[% foo.seven.length %]" => 1, {foo => $obj});
+process_ok("[% foo.echo(7) %]" => 7, {foo => $obj});
+process_ok("[% foo.many.0 %]" => 1, {foo => $obj});
+process_ok("[% foo.many.10 %]" => '',{foo => $obj});
+process_ok("[% foo.nomethod %]" => '',{foo => $obj});
+process_ok("[% foo.nomethod.0 %]" => '',{foo => $obj});
+
+process_ok("[% GET foo %]" => "");
+process_ok("[% GET foo %]" => "7", {foo => 7});
+process_ok("[% GET foo.bar %]" => "");
+process_ok("[% GET foo.bar %]" => "", {foo => {}});
+process_ok("[% GET foo.bar %]" => "7", {foo => {bar => 7}});
+process_ok("[% GET foo.0 %]" => "7", {foo => [7, 2, 3]});
+process_ok("[% GET foo %]" => 7, {foo => sub { 7 }});
+process_ok("[% GET foo(7) %]" => 7, {foo => sub { $_[0] }});
+
+process_ok("[% \$name %]" => "", {name => 'foo'});
+process_ok("[% \$name %]" => "7", {name => 'foo', foo => 7});
+process_ok("[% \$name.bar %]" => "", {name => 'foo'});
+process_ok("[% \$name.bar %]" => "", {name => 'foo', foo => {}});
+process_ok("[% \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% \$name().bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]});
+process_ok("[% \$name %]" => 7, {name => 'foo', foo => sub { 7 }});
+process_ok("[% \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }});
+
+process_ok("[% GET \$name %]" => "", {name => 'foo'});
+process_ok("[% GET \$name %]" => "7", {name => 'foo', foo => 7});
+process_ok("[% GET \$name.bar %]" => "", {name => 'foo'});
+process_ok("[% GET \$name.bar %]" => "", {name => 'foo', foo => {}});
+process_ok("[% GET \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% GET \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]});
+process_ok("[% GET \$name %]" => 7, {name => 'foo', foo => sub { 7 }});
+process_ok("[% GET \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }});
+
+process_ok("[% \$name %]" => "", {name => 'foo foo', foo => 7});
+process_ok("[% GET \$name %]" => "", {name => 'foo foo', foo => 7});
+
+process_ok("[% \${name} %]" => "", {name => 'foo'});
+process_ok("[% \${name} %]" => "7", {name => 'foo', foo => 7});
+process_ok("[% \${name}.bar %]" => "", {name => 'foo'});
+process_ok("[% \${name}.bar %]" => "", {name => 'foo', foo => {}});
+process_ok("[% \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% \${name}().bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]});
+process_ok("[% \${name} %]" => 7, {name => 'foo', foo => sub { 7 }});
+process_ok("[% \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }});
+
+process_ok("[% GET \${name} %]" => "", {name => 'foo'});
+process_ok("[% GET \${name} %]" => "7", {name => 'foo', foo => 7});
+process_ok("[% GET \${name}.bar %]" => "", {name => 'foo'});
+process_ok("[% GET \${name}.bar %]" => "", {name => 'foo', foo => {}});
+process_ok("[% GET \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}});
+process_ok("[% GET \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]});
+process_ok("[% GET \${name} %]" => 7, {name => 'foo', foo => sub { 7 }});
+process_ok("[% GET \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }});
+
+process_ok("[% \${name} %]" => "", {name => 'foo foo', foo => 7});
+process_ok("[% GET \${name} %]" => "", {name => 'foo foo', foo => 7});
+process_ok("[% GET \${'foo'} %]" => 'bar', {foo => 'bar'});
+
+process_ok("[% foo.\$name %]" => '', {name => 'bar'});
+process_ok("[% foo.\$name %]" => 7, {name => 'bar', foo => {bar => 7}});
+process_ok("[% foo.\$name.baz %]" => '', {name => 'bar', bar => {baz => 7}});
+
+process_ok("[% \"hi\" %]" => 'hi');
+process_ok("[% 'hi' %]" => 'hi');
+process_ok("[% \"\$foo\" %]" => '7', {foo => 7});
+process_ok("[% \"hi \$foo\" %]" => 'hi 7', {foo => 7});
+process_ok("[% \"hi \${foo}\" %]" => 'hi 7', {foo => 7});
+process_ok("[% 'hi \$foo' %]" => 'hi $foo', {foo => 7});
+process_ok("[% 'hi \${foo}' %]" => 'hi ${foo}', {foo => 7});
+
+process_ok("[% \"hi \${foo.seven}\" %]" => 'hi 7', {foo => $obj});
+process_ok("[% \"hi \${foo.echo(7)}\" %]" => 'hi 7', {foo => $obj});
+
+process_ok("[% _foo %]2" => '2', {_foo => 1});
+process_ok("[% \$bar %]2" => '2', {_foo => 1, bar => '_foo'});
+process_ok("[% __foo %]2" => '2', {__foo => 1});
+process_ok("[% _foo = 1 %][% _foo %]2" => '2');
+process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}});
+
+###----------------------------------------------------------------###
+### variable SETting
+
+process_ok("[% SET foo bar %][% foo %]" => '');
+process_ok("[% SET foo = 1 %][% foo %]" => '1');
+process_ok("[% SET foo = 1 bar = 2 %][% foo %][% bar %]" => '12');
+process_ok("[% SET foo bar = 1 %][% foo %]" => '');
+process_ok("[% SET foo = 1 ; bar = 1 %][% foo %]" => '1');
+process_ok("[% SET foo = 1 %][% SET foo %][% foo %]" => '');
+
+process_ok("[% SET foo = [] %][% foo.0 %]" => "");
+process_ok("[% SET foo = [1, 2, 3] %][% foo.1 %]" => 2);
+process_ok("[% SET foo = {} %][% foo.0 %]" => "");
+process_ok("[% SET foo = {1 => 2} %][% foo.1 %]" => "2") if ! $is_tt;
+process_ok("[% SET foo = {'1' => 2} %][% foo.1 %]" => "2");
+
+process_ok("[% SET name = 1 %][% SET foo = name %][% foo %]" => "1");
+process_ok("[% SET name = 1 %][% SET foo = \$name %][% foo %]" => "");
+process_ok("[% SET name = 1 %][% SET foo = \${name} %][% foo %]" => "");
+process_ok("[% SET name = 1 %][% SET foo = \"\$name\" %][% foo %]" => "1");
+process_ok("[% SET name = 1 foo = name %][% foo %]" => '1');
+process_ok("[% SET name = 1 %][% SET foo = {\$name => 2} %][% foo.1 %]" => "2");
+process_ok("[% SET name = 1 %][% SET foo = {\"\$name\" => 2} %][% foo.1 %]" => "2") if ! $is_tt;
+process_ok("[% SET name = 1 %][% SET foo = {\${name} => 2} %][% foo.1 %]" => "2");
+
+process_ok("[% SET name = 7 %][% SET foo = {'2' => name} %][% foo.2 %]" => "7");
+process_ok("[% SET name = 7 %][% SET foo = {'2' => \"\$name\"} %][% foo.2 %]" => "7");
+
+process_ok("[% SET name = 7 %][% SET foo = [1, name, 3] %][% foo.1 %]" => "7");
+process_ok("[% SET name = 7 %][% SET foo = [1, \"\$name\", 3] %][% foo.1 %]" => "7");
+
+process_ok("[% SET foo = { bar => { baz => [0, 7, 2] } } %][% foo.bar.baz.1 %]" => "7");
+
+process_ok("[% SET foo.bar = 1 %][% foo.bar %]" => '1');
+process_ok("[% SET foo.bar.baz.bing = 1 %][% foo.bar.baz.bing %]" => '1');
+process_ok("[% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 1');
+process_ok("[% SET foo.bar = [] %][% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 3');
+
+process_ok("[% SET name = 'two' %][% SET \$name = 3 %][% two %]" => 3);
+process_ok("[% SET name = 'two' %][% SET \${name} = 3 %][% two %]" => 3);
+process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.2 %]" => 3);
+process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.\$name %]" => 3);
+process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3);
+process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3);
+process_ok("[% SET name = 'two' %][% SET \$name.foo = 3 %][% two.foo %]" => 3);
+process_ok("[% SET name = 'two' %][% SET \${name}.foo = 3 %][% two.foo %]" => 3);
+process_ok("[% SET name = 'two' %][% SET foo.\$name.foo = 3 %][% foo.two.foo %]" => 3);
+process_ok("[% SET name = 'two' %][% SET foo.\${name}.foo = 3 %][% foo.two.foo %]" => 3);
+
+process_ok("[% SET foo = [1..10] %][% foo.6 %]" => 7);
+process_ok("[% SET foo = [10..1] %][% foo.6 %]" => '');
+process_ok("[% SET foo = [-10..-1] %][% foo.6 %]" => -4);
+process_ok("[% SET foo = [1..10, 21..30] %][% foo.12 %]" => 23) if ! $is_tt;
+process_ok("[% SET foo = [..100] bar = 7 %][% bar %][% foo.0 %]" => '');
+process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => 7) if ! $is_tt;
+process_ok("[% SET foo = ['a'..'z'] %][% foo.6 %]" => 'g');
+process_ok("[% SET foo = ['z'..'a'] %][% foo.6 %]" => '');
+process_ok("[% SET foo = ['a'..'z'].reverse %][% foo.6 %]" => 't') if ! $is_tt;
+
+process_ok("[% foo = 1 %][% foo %]" => '1');
+process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12');
+process_ok("[% foo = 1 ; bar = 2 %][% foo %][% bar %]" => '12');
+process_ok("[% foo.bar = 2 %][% foo.bar %]" => '2');
+
+process_ok('[% a = "a" %][% (b = a) %][% a %][% b %]' => 'aaa');
+process_ok('[% a = "a" %][% (c = (b = a)) %][% a %][% b %][% c %]' => 'aaaa');
+
+###----------------------------------------------------------------###
+### Reserved words
+
+my $vars = {
+ GET => 'named_get',
+ get => 'lower_named_get',
+ named_get => 'value of named_get',
+ hold_get => 'GET',
+};
+process_ok("[% GET %]" => '', $vars);
+process_ok("[% GET GET %]" => 'named_get', $vars) if ! $is_tt;
+process_ok("[% GET get %]" => 'lower_named_get', $vars);
+process_ok("[% GET \${'GET'} %]" => 'bar', {GET => 'bar'});
+
+process_ok("[% GET = 1 %][% GET GET %]" => '', $vars);
+process_ok("[% SET GET = 1 %][% GET GET %]" => '1', $vars) if ! $is_tt;
+
+process_ok("[% GET \$hold_get %]" => 'named_get', $vars);
+process_ok("[% GET \$GET %]" => 'value of named_get', $vars) if ! $is_tt;
+process_ok("[% BLOCK GET %]hi[% END %][% PROCESS GET %]" => 'hi') if ! $is_tt;
+process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo a = GET %]" => 'hi', $vars) if ! $is_tt;
+process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo GET = 1 %]" => '');
+process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo IF GET %]" => 'hi', $vars) if ! $is_tt;
+
+###----------------------------------------------------------------###
+### CALL and DEFAULT
+
+process_ok("[% DEFAULT foo = 7 %][% foo %]" => 7);
+process_ok("[% SET foo = 5 %][% DEFAULT foo = 7 %][% foo %]" => 5);
+process_ok("[% DEFAULT foo.bar.baz.bing = 6 %][% foo.bar.baz.bing %]" => 6);
+
+my $t = 0;
+process_ok("[% foo %]" => 'hi', {foo => sub {$t++; 'hi'}});
+process_ok("[% GET foo %]" => 'hi', {foo => sub {$t++; 'hi'}});
+process_ok("[% CALL foo %]" => '', {foo => sub {$t++; 'hi'}});
+ok($t == 3, "CALL method actually called var");
+
+###----------------------------------------------------------------###
+### virtual methods / filters
+
+process_ok("[% [0 .. 10].reverse.1 %]" => 9) if ! $is_tt;
+process_ok("[% {a => 'A'}.a %]" => 'A') if ! $is_tt;
+process_ok("[% 'This is a string'.length %]" => 16) if ! $is_tt;
+process_ok("[% 123.length %]" => 3) if ! $is_tt;
+process_ok("[% 123.2.length %]" => 5) if ! $is_tt;
+process_ok("[% -123.2.length %]" => -5) if ! $is_tt; # the - doesn't bind as tight as the dot methods
+process_ok("[% (-123.2).length %]" => 6) if ! $is_tt;
+
+process_ok("[% n.repeat %]" => '1', {n => 1}) if ! $is_tt; # tt2 virtual method defaults to 0
+process_ok("[% n.repeat(0) %]" => '', {n => 1});
+process_ok("[% n.repeat(1) %]" => '1', {n => 1});
+process_ok("[% n.repeat(2) %]" => '11', {n => 1});
+process_ok("[% n.repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt;
+
+process_ok("[% n.size %]", => 'SIZE', {n => {size => 'SIZE', a => 'A'}});
+process_ok("[% n|size %]", => '2', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 | is alias for FILTER
+
+process_ok('[% foo | eval %]' => 'baz', {foo => '[% bar %]', bar => 'baz'});
+process_ok('[% "1" | indent(2) %]' => ' 1');
+
+process_ok("[% n.replace('foo', 'bar') %]" => 'barbar', {n => 'foofoo'});
+process_ok("[% n.replace('(foo)', 'bar\$1') %]" => 'barfoobarfoo', {n => 'foofoo'}) if ! $is_tt;
+process_ok("[% n.replace('foo', 'bar', 0) %]" => 'barfoo', {n => 'foofoo'}) if ! $is_tt;
+
+process_ok("[% n FILTER size %]", => '1', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 doesn't have size
+
+process_ok("[% n FILTER repeat %]" => '1', {n => 1});
+process_ok("[% n FILTER repeat(0) %]" => '', {n => 1});
+process_ok("[% n FILTER repeat(1) %]" => '1', {n => 1});
+process_ok("[% n FILTER repeat(2) %]" => '11', {n => 1});
+process_ok("[% n FILTER repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt;
+
+process_ok("[% n FILTER echo = repeat(2) %][% n FILTER echo %]" => '1111', {n => 1});
+process_ok("[% n FILTER echo = repeat(2) %][% n | echo %]" => '1111', {n => 1});
+process_ok("[% n FILTER echo = repeat(2) %][% n|echo.length %]" => '112', {n => 1}) if ! $is_tt;
+process_ok("[% n FILTER echo = repeat(2) %][% n FILTER \$foo %]" => '1111', {n => 1, foo => 'echo'});
+process_ok("[% n FILTER echo = repeat(2) %][% n | \$foo %]" => '1111', {n => 1, foo => 'echo'});
+process_ok("[% n FILTER echo = repeat(2) %][% n|\$foo.length %]" => '112', {n => 1, foo => 'echo'}) if ! $is_tt;
+
+process_ok('[% "hi" FILTER $foo %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var
+process_ok('[% FILTER $foo %]hi[% END %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var
+process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => sub {$_[0]x2}}]});
+process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {$_[0]x2},0]}]});
+process_ok('[% "hi" FILTER foo(2) %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {my$a=$_[1];sub{$_[0]x$a}},1]}]});
+
+### this does work - but requires that Template::Filters is installed
+#process_ok("[% ' ' | uri %]" => '%20');
+
+###----------------------------------------------------------------###
+### chomping
+
+process_ok(" [% foo %]" => ' ');
+process_ok(" [%- foo %]" => '');
+process_ok("\n[%- foo %]" => '');
+process_ok("\n [%- foo %]" => '');
+process_ok("\n\n[%- foo %]" => "\n");
+process_ok(" \n\n[%- foo %]" => " \n");
+process_ok(" \n[%- foo %]" => " ") if ! $is_tt;
+process_ok(" \n \n[%- foo %]" => " \n ") if ! $is_tt;
+
+process_ok("[% foo %] " => ' ');
+process_ok("[% foo -%] " => ' ');
+process_ok("[% foo -%]\n" => '');
+process_ok("[% foo -%] \n" => '');
+process_ok("[% foo -%]\n " => ' ');
+process_ok("[% foo -%]\n\n\n" => "\n\n");
+process_ok("[% foo -%] \n " => ' ');
+
+###----------------------------------------------------------------###
+### math operations
+
+process_ok("[% 1 + 2 %]" => 3);
+process_ok("[% 1 + 2 + 3 %]" => 6);
+process_ok("[% (1 + 2) %]" => 3);
+process_ok("[% 2 - 1 %]" => 1);
+process_ok("[% -1 + 2 %]" => 1);
+process_ok("[% -1+2 %]" => 1);
+process_ok("[% 2 - 1 %]" => 1);
+process_ok("[% 2-1 %]" => 1) if ! $is_tt;
+process_ok("[% 2 - -1 %]" => 3);
+process_ok("[% 4 * 2 %]" => 8);
+process_ok("[% 4 / 2 %]" => 2);
+process_ok("[% 10 / 3 %]" => qr/^3.333/);
+process_ok("[% 10 div 3 %]" => '3');
+process_ok("[% 2 ** 3 %]" => 8) if ! $is_tt;
+process_ok("[% 1 + 2 * 3 %]" => 7);
+process_ok("[% 3 * 2 + 1 %]" => 7);
+process_ok("[% (1 + 2) * 3 %]" => 9);
+process_ok("[% 3 * (1 + 2) %]" => 9);
+process_ok("[% 1 + 2 ** 3 %]" => 9) if ! $is_tt;
+process_ok("[% 2 * 2 ** 3 %]" => 16) if ! $is_tt;
+process_ok("[% SET foo = 1 %][% foo + 2 %]" => 3);
+process_ok("[% SET foo = 1 %][% (foo + 2) %]" => 3);
+
+###----------------------------------------------------------------###
+### boolean operations
+
+process_ok("[% 5 && 6 %]" => 6);
+process_ok("[% 5 || 6 %]" => 5);
+process_ok("[% 0 || 6 %]" => 6);
+process_ok("[% 0 && 6 %]" => 0);
+process_ok("[% 0 && 0 %]" => 0);
+process_ok("[% 5 && 6 && 7%]" => 7);
+process_ok("[% 0 || 1 || 2 %]" => 1);
+
+process_ok("[% 5 + (0 || 5) %]" => 10);
+
+
+process_ok("[% 1 ? 2 : 3 %]" => '2');
+process_ok("[% 0 ? 2 : 3 %]" => '3');
+process_ok("[% 0 ? (1 ? 2 : 3) : 4 %]" => '4');
+process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4');
+
+process_ok("[% t = 1 || 0 ? 3 : 4 %][% t %]" => 3);
+process_ok("[% t = 0 or 1 ? 3 : 4 %][% t %]" => 3);
+process_ok("[% t = 1 or 0 ? 3 : 4 %][% t %]" => 1) if ! $is_tt;
+
+process_ok("[% 0 ? 2 : 3 %]" => '3');
+process_ok("[% 1 ? 2 : 3 %]" => '2');
+process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4');
+process_ok("[% t = 0 ? 1 ? [1..4] : [2..4] : [3..4] %][% t.0 %]" => '3');
+process_ok("[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]" => '0');
+process_ok("[% t = 0 or 0 ? 0 : 1 or 2 ? 2 : 3 %][% t %]" => '1') if ! $is_tt;
+process_ok("[% t = 0 or 0 ? 0 : 0 or 2 ? 2 : 3 %][% t %]" => '2');
+
+process_ok("[% 0 ? 1 ? 1 + 2 * 3 : 1 + 2 * 4 : 1 + 2 * 5 %]" => '11');
+
+###----------------------------------------------------------------###
+### blocks
+
+process_ok("[% PROCESS foo %]" => '');
+process_ok("[% BLOCK foo %]" => '');
+process_ok("[% BLOCK foo %][% END %]" => '');
+process_ok("[% BLOCK %][% END %]one" => 'one');
+process_ok("[% BLOCK foo %]hi there[% END %]" => '');
+process_ok("[% BLOCK foo %][% BLOCK foo %][% END %][% END %]" => '');
+process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo %]" => 'hi there');
+process_ok("[% PROCESS foo %][% BLOCK foo %]hi there[% END %]" => 'hi there');
+process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo %]" => 'hi ONE there', {one => 'ONE'});
+process_ok("[% BLOCK foo %]hi [% IF 1 %]Yes[% END %] there[% END %]<<[% PROCESS foo %]>>" => '<<hi Yes there>>');
+process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %]" => 'hi two there');
+process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo one.two = 'two' %]" => 'hi two there');
+process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo + foo one.two = 'two' %]" => 'hi two there'x2);
+
+process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %][% one %]" => 'hi two theretwo');
+process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% INCLUDE foo one = 'two' %][% one %]" => 'hi two there');
+
+###----------------------------------------------------------------###
+### if/unless/elsif/else
+
+process_ok("[% IF 1 %]Yes[% END %]" => 'Yes');
+process_ok("[% IF 0 %]Yes[% END %]" => '');
+process_ok("[% IF 0 %]Yes[% ELSE %]No[% END %]" => 'No');
+process_ok("[% IF 0 %]Yes[% ELSIF 1 %]No[% END %]" => 'No');
+process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% END %]" => '');
+process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm');
+
+process_ok("[% UNLESS 1 %]Yes[% END %]" => '');
+process_ok("[% UNLESS 0 %]Yes[% END %]" => 'Yes');
+process_ok("[% UNLESS 0 %]Yes[% ELSE %]No[% END %]" => 'Yes');
+process_ok("[% UNLESS 1 %]Yes[% ELSIF 1 %]No[% END %]" => 'No');
+process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% END %]" => '');
+process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm');
+
+###----------------------------------------------------------------###
+### comments
+
+process_ok("[%# one %]" => '', {one => 'ONE'});
+process_ok("[%#\n one %]" => '', {one => 'ONE'});
+process_ok("[%-#\n one %]" => '', {one => 'ONE'}) if ! $is_tt;
+process_ok("[% #\n one %]" => 'ONE', {one => 'ONE'});
+process_ok("[%# BLOCK one %]" => '');
+process_ok("[%# BLOCK one %]two" => 'two');
+process_ok("[%# BLOCK one %]two[% END %]" => '');
+process_ok("[%# BLOCK one %]two[% END %]three" => '');
+
+###----------------------------------------------------------------###
+### foreach, next, last
+
+process_ok("[% FOREACH foo %]" => '');
+process_ok("[% FOREACH foo %][% END %]" => '');
+process_ok("[% FOREACH foo %]bar[% END %]" => '');
+process_ok("[% FOREACH foo %]bar[% END %]" => 'bar', {foo => 1});
+process_ok("[% FOREACH f IN foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]});
+process_ok("[% FOREACH f = foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]});
+process_ok("[% FOREACH f = [1,2] %]bar[% f %][% END %]" => 'bar1bar2');
+process_ok("[% FOREACH f = [1..3] %]bar[% f %][% END %]" => 'bar1bar2bar3');
+process_ok("[% FOREACH f = [{a=>'A'},{a=>'B'}] %]bar[% f.a %][% END %]" => 'barAbarB');
+process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %]" => 'barAbarB');
+process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB');
+process_ok("[% FOREACH f = [1..3] %][% loop.count %]/[% loop.size %] [% END %]" => '1/3 2/3 3/3 ');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% f %][% END %][% END %]" => '1');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% f %][% END %][% END %]" => '3');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% NEXT %][% END %][% f %][% END %]" => '23');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% LAST %][% END %][% f %][% END %]" => '');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% NEXT %][% END %][% END %]" => '123');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% LAST %][% END %][% END %]" => '1');
+
+### TT is not consistent in what is localized - well it is documented
+### if you set a variable in the FOREACH tag, then nothing in the loop gets localized
+### if you don't set a variable - everything gets localized
+process_ok("[% foo = 1 %][% FOREACH [1..10] %][% foo %][% foo = 2 %][% END %]" => '1222222222');
+process_ok("[% f = 1 %][% FOREACH i = [1..10] %][% i %][% f = 2 %][% END %][% f %]" => '123456789102');
+process_ok("[% f = 1 %][% FOREACH [1..10] %][% f = 2 %][% END %][% f %]" => '1');
+process_ok("[% f = 1 %][% FOREACH f = [1..10] %][% f %][% END %][% f %]" => '1234567891010');
+process_ok("[% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '');
+process_ok("[% a %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '');
+process_ok("[% a = 2 %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '2');
+process_ok("[% a = 2 %][% FOREACH [1] %][% a = 1 %][% END %][% a %]" => '2');
+process_ok("[% a = 2 %][% FOREACH i = [1] %][% a = 1 %][% END %][% a %]" => '1');
+process_ok("[% FOREACH i = [1] %][% SET a = 1 %][% END %][% a %]" => '1');
+process_ok("[% f.b = 1 %][% FOREACH f.b = [1..10] %][% f.b %][% END %][% f.b %]" => '1234567891010') if ! $is_tt;
+process_ok("[% a = 1 %][% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB1');
+process_ok("[% FOREACH [1..3] %][% loop.size %][% END %][% loop.size %]" => '333');
+process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '333') if ! $is_tt;
+process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '3331') if $is_tt;
+
+###----------------------------------------------------------------###
+### while
+
+process_ok("[% WHILE foo %]" => '');
+process_ok("[% WHILE foo %][% END %]" => '');
+process_ok("[% WHILE (foo = foo - 1) %][% END %]" => '');
+process_ok("[% WHILE (foo = foo - 1) %][% foo %][% END %]" => '21', {foo => 3});
+process_ok("[% WHILE foo %][% foo %][% foo = foo - 1 %][% END %]" => '321', {foo => 3});
+
+process_ok("[% WHILE 1 %][% foo %][% foo = foo - 1 %][% LAST IF foo == 1 %][% END %]" => '32', {foo => 3});
+process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END %]" => '9876543210');
+process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END ; f %]" => '98765432100');
+process_ok("[% f = 10 a = 2; WHILE f; f = f - 1 ; f ; a=3; END ; a%]" => '98765432103');
+
+process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END %]" => '9876543210');
+process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END ; f %]" => '98765432100');
+process_ok("[% f = 10 a = 2; WHILE (g=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432103');
+process_ok("[% f = 10 a = 2; WHILE (a=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432100');
+
+###----------------------------------------------------------------###
+### stop, return, clear
+
+process_ok("[% STOP %]" => '');
+process_ok("One[% STOP %]Two" => 'One');
+process_ok("[% BLOCK foo %]One[% STOP %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOne');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% STOP %][% END %][% END %]" => '1');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% STOP %][% END %][% f %][% END %]" => '');
+
+process_ok("[% RETURN %]" => '');
+process_ok("One[% RETURN %]Two" => 'One');
+process_ok("[% BLOCK foo %]One[% RETURN %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOneLast');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% RETURN %][% END %][% END %]" => '1');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% RETURN %][% END %][% f %][% END %]" => '');
+
+process_ok("[% CLEAR %]" => '');
+process_ok("One[% CLEAR %]Two" => 'Two');
+process_ok("[% BLOCK foo %]One[% CLEAR %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstTwoLast');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% CLEAR %][% END %][% END %]" => '23');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% CLEAR %][% END %][% f %][% END %]" => '123');
+process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.last %][% CLEAR %][% END %][% END %]" => '');
+process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% CLEAR %][% END %][% f %][% END %]" => '3');
+
+###----------------------------------------------------------------###
+### multiple-directives
+
+process_ok("[% GET foo; GET foo %]" => '11', {foo => 1});
+process_ok('[% FOREACH f = [1..3]; 1; END %]' => '111');
+process_ok('[% FOREACH f = [1..3]; f; END %]' => '123');
+process_ok('[% FOREACH f = [1..3]; "$f"; END %]' => '123');
+process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234');
+
+###----------------------------------------------------------------###
+### post opererator
+
+process_ok("[% GET foo IF 1 %]" => '1', {foo => 1});
+process_ok("[% f FOREACH f = [1..3] %]" => '123');
+
+process_ok("2[% GET foo IF 1 IF 2 %]" => '21', {foo => 1}) if ! $is_tt;
+process_ok("2[% GET foo IF 1 IF 0 %]" => '2', {foo => 1}) if ! $is_tt;
+process_ok("[% f FOREACH f = [1..3] IF 1 %]" => '123') if ! $is_tt;
+process_ok("[% f FOREACH f = [1..3] IF 0 %]" => '') if ! $is_tt;
+process_ok("[% f FOREACH f = g FOREACH g = [1..3] %]" => '123') if ! $is_tt;
+process_ok("[% f FOREACH f = g.a FOREACH g = [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt;
+process_ok("[% f FOREACH f = a FOREACH [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt;
+
+process_ok("[% FOREACH f = [1..3] IF 1 %]([% f %])[% END %]" => '(1)(2)(3)') if ! $is_tt;
+process_ok("[% FOREACH f = [1..3] IF 0 %]([% f %])[% END %]" => '') if ! $is_tt;
+
+process_ok("[% BLOCK bar %][% foo %][% foo = foo - 1 %][% END %][% PROCESS bar WHILE foo %]" => '321', {foo => 3});
+
+###----------------------------------------------------------------###
+### capturing
+
+process_ok("[% foo = BLOCK %]Hi[% END %][% foo %][% foo %]" => 'HiHi');
+process_ok("[% BLOCK foo %]Hi[% END %][% bar = PROCESS foo %]-[% bar %]" => '-Hi');
+process_ok("[% foo = IF 1 %]Hi[% END %][% foo %]" => 'Hi');
+
+###----------------------------------------------------------------###
+### tags
+
+process_ok("[% TAGS html %]<!-- 1 + 2 -->" => '3');
+process_ok("[% TAGS <!-- --> %]<!-- 1 + 2 -->" => '3');
+process_ok("[% TAGS html %] <!--- 1 + 2 -->" => '3');
+process_ok("[% TAGS html %]<!-- 1 + 2 --->" => '3') if ! $is_tt;
+process_ok("[% TAGS html %]<!-- 1 + 2 --->\n" => '3');
+process_ok("[% BLOCK foo %][% TAGS html %]<!-- 1 + 2 -->[% END %][% PROCESS foo %] [% 1 + 2 %]" => '');
+
+###----------------------------------------------------------------###
+### switch
+
+process_ok("[% SWITCH 1 %][% END %]hi" => 'hi');
+process_ok("[% SWITCH 1 %][% CASE %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 1 %]Pre[% CASE %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 1 %][% CASE DEFAULT %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 1 %][% CASE 0 %]bar[% END %]hi" => 'hi');
+process_ok("[% SWITCH 1 %][% CASE 1 %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 1 %][% CASE foo %][% CASE 1 %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 1 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH 11 %][% CASE [1..10] %]bar[% END %]hi" => 'hi');
+
+process_ok("[% SWITCH 1.0 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi');
+process_ok("[% SWITCH '1.0' %][% CASE [1..10] %]bar[% END %]hi" => 'barhi') if ! $is_tt;
+
+###----------------------------------------------------------------###
+### try/throw/catch/final
+
+process_ok("[% TRY %][% END %]hi" => 'hi');
+process_ok("[% TRY %]Foo[% END %]hi" => 'Foohi');
+process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% END %]hi" => '');
+process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %][% END %]hi" => 'Foohi') if ! $is_tt;
+process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %]there[% END %]hi" => 'Footherehi');
+process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH foo %]there[% END %]hi" => 'Footherehi');
+process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH %]two[% END %]hi" => 'FooFootwohi');
+process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH s %]two[% END %]hi" => '');
+process_ok("[% TRY %]Foo[% THROW foo.bar 'for fun' %][% CATCH foo %]one[% CATCH foo.bar %]two[% END %]hi" => 'Footwohi');
+
+process_ok("[% TRY %]Foo[% FINAL %]Bar[% END %]hi" => 'FooBarhi');
+process_ok("[% TRY %]Foo[% THROW foo %][% FINAL %]Bar[% CATCH %]one[% END %]hi" => '');
+process_ok("[% TRY %]Foo[% THROW foo %][% CATCH %]one[% FINAL %]Bar[% END %]hi" => 'FoooneBarhi');
+process_ok("[% TRY %]Foo[% THROW foo %][% CATCH bar %]one[% FINAL %]Bar[% END %]hi" => '');
+
+process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error %][% END %]" => 'foo error - bar');
+process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.type %][% END %]" => 'foo');
+process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.info %][% END %]" => 'bar');
+process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.type %][% END %]" => 'undef');
+process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.info %][% END %]" => 'foo');
+
+###----------------------------------------------------------------###
+### named args
+
+process_ok("[% foo(bar = 'one', baz = 'two') %]" => "baronebaztwo",
+ {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}});
+process_ok("[%bar='ONE'%][% foo(\$bar = 'one') %]" => "ONEone",
+ {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}});
+
+###----------------------------------------------------------------###
+### use
+
+my @config_p = (PLUGIN_BASE => 'MyTestPlugin', LOAD_PERL => 1);
+process_ok("[% USE son_of_gun_that_does_not_exist %]one" => '', {tt_config => \@config_p});
+process_ok("[% USE Foo %]one" => 'one', {tt_config => \@config_p});
+process_ok("[% USE Foo2 %]one" => 'one', {tt_config => \@config_p});
+process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p});
+process_ok("[% USE Foo2(bar = 'baz') %]one[% Foo2.bar %]" => 'onebarbaz', {tt_config => \@config_p});
+process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p});
+process_ok("[% USE d = Foo(bar = 'baz') %]one[% d.bar %]" => 'onebarbaz', {tt_config => \@config_p});
+process_ok("[% USE d.d = Foo(bar = 'baz') %]one[% d.d.bar %]" => '', {tt_config => \@config_p});
+
+process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => '', {tt_config => [@config_p, PLUGINS => {a=>'Foo'}, ]});
+process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => 'one7', {tt_config => [@config_p, PLUGINS => {a=>'Foo2'},]});
+
+###----------------------------------------------------------------###
+### macro
+
+process_ok("[% MACRO foo PROCESS bar %][% BLOCK bar %]Hi[% END %][% foo %]" => 'Hi');
+process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi');
+process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi');
+process_ok("[% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %]" => 'Hi2');
+process_ok("[%n=1%][% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %][%n%]" => 'Hi21');
+process_ok("[%n=1%][% MACRO foo BLOCK %]Hi[% n = 2%][% END %][% foo %][%n%]" => 'Hi1');
+process_ok("[% MACRO foo(n) FOREACH i=[1..n] %][% i %][% END %][% foo(3) %]" => '123');
+
+###----------------------------------------------------------------###
+### debug;
+
+process_ok("\n\n[% one %]" => "\n\n\n## input text line 3 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]});
+process_ok("[% one %]" => "\n## input text line 1 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]});
+process_ok("[% one %]\n\n" => "(1)ONE\n\n", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']});
+process_ok("1\n2\n3[% one %]" => "1\n2\n3(3)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']});
+process_ok("[% one;\n one %]" => "(1)ONE(2)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8,
+ 'DEBUG_FORMAT' => '($line)']}) if ! $is_tt;
+process_ok("[% DEBUG format '(\$line)' %][% one %]" => qr/\(1\)/, {one=>'ONE', tt_config => ['DEBUG' => 8]});
+
+process_ok("[% TRY %][% abc %][% CATCH %][% error %][% END %]" => "undef error - abc is undefined\n", {tt_config => ['DEBUG' => 2]});
+process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]});
+
+###----------------------------------------------------------------###
+### constants
+
+my @config_c = (
+ CONSTANTS => {
+ harry => sub {'do_this_once'},
+ foo => {
+ bar => {baz => 42},
+ bim => 57,
+ },
+ bing => 'baz',
+ bang => 'bim',
+ },
+ VARIABLES => {
+ bam => 'bar',
+ },
+);
+process_ok("[% constants.harry %]" => 'do_this_once', {tt_config => \@config_c});
+process_ok("[% constants.harry.length %]" => '12', {tt_config => \@config_c});
+process_ok("[% SET constants.something = 1 %][% constants.something %]one" => '1one', {tt_config => \@config_c});
+process_ok("[% SET constants.harry = 1 %][% constants.harry %]one" => 'do_this_onceone', {tt_config => \@config_c});
+process_ok("[% constants.foo.\${constants.bang} %]" => '57', {tt_config => [@config_c]});
+process_ok("[% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt;
+process_ok("[% bam = 'somethingelse' %][% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt;
+
+###----------------------------------------------------------------###
+### interpolate / anycase / trim
+
+process_ok("Foo \$one Bar" => 'Foo ONE Bar', {one => 'ONE', tt_config => ['INTERPOLATE' => 1]});
+process_ok("[% PERL %] my \$n=7; print \$n [% END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]});
+process_ok("[% TRY ; PERL %] my \$n=7; print \$n [% END ; END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]});
+
+process_ok("[% GET %]" => '', {GET => 'ONE'});
+process_ok("[% GET GET %]" => 'ONE', {GET => 'ONE'}) if ! $is_tt;
+
+process_ok("[% BLOCK foo %]\nhi\n[% END %][% PROCESS foo %]" => "\nhi\n");
+process_ok("[% BLOCK foo %]\nhi[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]});
+process_ok("[% BLOCK foo %]hi\n[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]});
+process_ok("[% BLOCK foo %]hi[% nl %][% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]});
+process_ok("[% BLOCK foo %][% nl %]hi[% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]});
+process_ok("A[% TRY %]\nhi\n[% END %]" => "A\nhi", {tt_config => [TRIM => 1]});
+
+###----------------------------------------------------------------###
+### perl
+
+process_ok("[% TRY %][% PERL %][% END %][% CATCH ; error; END %]" => 'perl error - EVAL_PERL not set');
+process_ok("[% PERL %] print \"[% one %]\" [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]});
+process_ok("[% PERL %] print \$stash->get('one') [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]});
+process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => '77', {tt_config => ['EVAL_PERL' => 1]});
+
+###----------------------------------------------------------------###
+### recursion prevention
+
+process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt;
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+=head1 NAME
+
+7_template_01_includes.t - Test the file include functionality of CGI::Ex::Template - including some edge cases
+
+=cut
+
+use vars qw($module $is_tt);
+BEGIN {
+ $module = 'CGI::Ex::Template';
+ #$module = 'Template';
+ $is_tt = $module eq 'Template';
+};
+
+use strict;
+use Test::More tests => 25 - ($is_tt ? 6 : 0);
+use Data::Dumper qw(Dumper);
+use constant test_taint => 0 && eval { require Taint::Runtime };
+
+use_ok($module);
+
+Taint::Runtime::taint_start() if test_taint;
+
+### find a place to allow for testing
+my $test_dir = $0 .'.test_dir';
+END { rmdir $test_dir }
+mkdir $test_dir, 0755;
+ok(-d $test_dir, "Got a test dir up and running");
+
+
+sub process_ok { # process the value
+ my $str = shift;
+ my $test = shift;
+ my $args = shift;
+ my $out = '';
+
+ Taint::Runtime::taint(\$str) if test_taint;
+
+ my $obj = $module->new(ABSOLUTE => 1, INCLUDE_PATH => $test_dir);
+ $obj->process(\$str, $args, \$out);
+ my $ok = $out eq $test;
+ ok($ok, "\"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\""));
+ my $line = (caller)[2];
+ warn "# process_ok called at line $line.\n" if ! $ok;
+}
+
+### create some files to include
+my $foo_template = "$test_dir/foo.tt";
+END { unlink $foo_template };
+open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!";
+print $fh "([% INCLUDE bar.tt %])";
+close $fh;
+
+###
+my $bar_template = "$test_dir/bar.tt";
+END { unlink $bar_template };
+open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!";
+print $fh "BAR";
+close $fh;
+
+my $baz_template = "$test_dir/baz.tt";
+END { unlink $baz_template };
+open($fh, ">$baz_template") || die "Couldn't open $baz_template: $!";
+print $fh "[% SET baz = 42 %][% baz %][% bing %]";
+close $fh;
+
+###
+my $wrap_template = "$test_dir/wrap.tt";
+END { unlink $wrap_template };
+open($fh, ">$wrap_template") || die "Couldn't open $wrap_template: $!";
+print $fh "Hi[% content %]there";
+close $fh;
+
+###----------------------------------------------------------------###
+### INSERT
+
+process_ok("([% INSERT bar.tt %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% INSERT \$file %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% INSERT \${file} %])" => '(BAR)') if ! $is_tt;
+process_ok("([% SET file = 'bar.tt' %][% INSERT \"\$file\" %])" => '(BAR)');
+process_ok("([% SET file = 'bar' %][% INSERT \"\$file.tt\" %])" => '(BAR)') if ! $is_tt;
+
+###----------------------------------------------------------------###
+### INCLUDE
+
+process_ok("([% INCLUDE bar.tt %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% INCLUDE \$file %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% INCLUDE \${file} %])" => '(BAR)') if ! $is_tt;
+process_ok("([% SET file = 'bar.tt' %][% INCLUDE \"\$file\" %])" => '(BAR)');
+process_ok("([% SET file = 'bar' %][% INCLUDE \"\$file.tt\" %])" => '(BAR)') if ! $is_tt;
+
+process_ok("([% INCLUDE baz.tt %])" => '(42)');
+process_ok("([% INCLUDE baz.tt %])[% baz %]" => '(42)');
+process_ok("[% SET baz = 21 %]([% INCLUDE baz.tt %])[% baz %]" => '(42)21');
+
+###----------------------------------------------------------------###
+### PROCESS
+
+process_ok("([% PROCESS bar.tt %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% PROCESS \$file %])" => '(BAR)');
+process_ok("([% SET file = 'bar.tt' %][% PROCESS \${file} %])" => '(BAR)') if ! $is_tt;
+process_ok("([% SET file = 'bar.tt' %][% PROCESS \"\$file\" %])" => '(BAR)');
+process_ok("([% SET file = 'bar' %][% PROCESS \"\$file.tt\" %])" => '(BAR)') if ! $is_tt;
+
+process_ok("([% PROCESS baz.tt %])" => '(42)');
+process_ok("([% PROCESS baz.tt %])[% baz %]" => '(42)42');
+process_ok("[% SET baz = 21 %]([% PROCESS baz.tt %])[% baz %]" => '(42)42');
+
+###----------------------------------------------------------------###
+### WRAPPER
+
+process_ok("([% WRAPPER wrap.tt %])" => '');
+process_ok("([% WRAPPER wrap.tt %] one [% END %])" => '(Hi one there)');
--- /dev/null
+# -*- Mode: Perl; -*-
+
+=head1 NAME
+
+8_auth_00_base.t - Testing of the CGI::Ex::Auth module.
+
+=cut
+
+use strict;
+use Test::More tests => 33;
+
+use_ok('CGI::Ex::Auth');
+
+{
+ package Auth;
+ use base qw(CGI::Ex::Auth);
+ use strict;
+ use vars qw($printed $set_cookie $deleted_cookie);
+
+ sub login_print { $printed = 1 }
+ sub set_cookie { $set_cookie = 1 }
+ sub delete_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'] }
+}
+
+{
+ package Aut2;
+ use base qw(Auth);
+ use vars qw($crypt);
+ BEGIN { $crypt = crypt('123qwe', 'SS') };
+ sub use_crypt { 1 }
+ sub get_pass_by_user { $crypt }
+}
+
+my $token = Auth->new->generate_token({user => 'test', real_pass => '123qwe', use_base64 => 1});
+
+my $form_bad = { cea_user => 'test', cea_pass => '123qw' };
+my $form_good = { cea_user => 'test', cea_pass => '123qwe' };
+my $form_good2 = { cea_user => $token };
+my $form_good3 = { cea_user => 'test/123qwe' };
+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;
+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;
+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;
+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;
+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");
+
+$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0;
+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;
+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;
+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");
+
+
+SKIP: {
+ skip("Crypt::Blowfish not found", 4) if ! eval { require Crypt::Blowfish };
+
+ {
+ package Aut3;
+ use base qw(Auth);
+ sub use_blowfish { "This_is_my_key" }
+ sub use_base64 { 0 }
+ sub use_plaintext { 1 }
+ }
+
+ my $token2 = Aut3->new->generate_token({user => 'test', real_pass => '123qwe'});
+ my $form_good4 = { cea_user => $token2 };
+
+ sub form_good4 { Aut3->get_valid_auth({form => {%$form_good4}, cookies => {} }) }
+
+ $Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0;
+ ok(form_good4(), "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");
+};
projects / chaz / p5-CGI-Ex / commitdiff
