--- /dev/null
+%define name CGI-Ex
+%define version 1.14
+
+%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 )
+
+Summary: @SUMMARY@
+Name: %{name}
+Version: %{version}
+Release: 1
+Source0: http://seamons.com/cgi_ex/%{name}-%{version}.tar.gz
+Group: Development/Perl
+License: Perl Artistic
+Vendor: Paul Seamons
+Packager: Paul Seamons
+BuildRequires: perl
+BuildArch: noarch
+BuildRoot: %{_tmppath}/%{name}-%{version}-buildroot
+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.
+
+%prep
+%setup -q -n %{name}-%{version}
+
+%build
+%{__perl} Makefile.PL
+%{__make} OPTIMIZE="$RPM_OPT_FLAGS"
+
+%install
+rm -rf $RPM_BUILD_ROOT
+
+# do the build
+%{makeinstall} PREFIX=$RPM_BUILD_ROOT%{_prefix}
+#if [ -x /usr/lib/rpm/brp-mandrake ] ; then
+# /usr/lib/rpm/brp-mandrake
+#elif [ -x /usr/lib/brp-compress ] ; then
+# /usr/lib/rpm/brp-compress
+#fi
+
+# Clean up some files we don't want/need
+find $RPM_BUILD_ROOT%{_prefix} -type d | tac | xargs rmdir --ign
+find $RPM_BUILD_ROOT%{_prefix} | grep i386 | tac | xargs rm -rf
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+HERE=`pwd`
+cd ..
+rm -rf $HERE
+
+%files
+%defattr(-,root,root)
+#%doc README Changes
+%{_prefix}
+
+%changelog
+* Sat Nov 11 2003 Paul Seamons <>
+- first try
--- /dev/null
+2005-02-28 Paul Seamons <cgi_ex@seamons.com>
+
+ * Version 1.14 is done
+ * Bug fix in validate (OR's were not working)
+ * Allow for checking for package existence without require in App
+ * Add hash_swap
+ * Add hash_base
+ * Add add_to_ methods for swap, fill, form, common, and errors
+ * Swap the run_hook order of step and hookname
+ * 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
+ * Fix required => 0 in javascript
+
+2004-12-02 Paul Seamons <cgi_ex@seamons.com>
+
+ * Version 1.13 is done
+ * 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
+ * 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
+ * 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
+ * Make CGI::Ex::App->print really work with Template
+ * Fix very large javascript variable swapping bug
+ * Numerous upgrades to App
+ * Fix module access in CGI::Ex
+ * 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
+ * Added set_path method
+ * Added Auth module
+ * Fix validate.js for select-multiple
+ * Fix validate.js for max_values
+ * 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
+ * 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)
+ * A few fixes on App
+ * Added set_form
+ * Updated tests
+
+2004-03-19 Paul Seamons <cgi_ex@seamons.com>
+
+ * Version 0.98 is done
+ * 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>
+
+ * 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
+ * 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
+ * Javascript functionality is in.
+
+2003-11-01 Paul Seamons <cgi_ex@seamons.com>
+
+ * Version 0.0 checked in
--- /dev/null
+CGI-Ex.spec
+Changes
+lib/CGI/Ex.pm
+lib/CGI/Ex/App.pm
+lib/CGI/Ex/Auth.pm
+lib/CGI/Ex/Conf.pm
+lib/CGI/Ex/Die.pm
+lib/CGI/Ex/Dump.pm
+lib/CGI/Ex/Fill.pm
+lib/CGI/Ex/md5.js
+lib/CGI/Ex/sha1.js
+lib/CGI/Ex/Template.pm
+lib/CGI/Ex/validate.js
+lib/CGI/Ex/Validate.pm
+lib/CGI/Ex/yaml_load.js
+Makefile.PL
+MANIFEST This list of files
+MANIFEST.SKIP
+META.yml Module meta-data (added by MakeMaker)
+README
+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_02_hidden.t
+t/2_fill_03_checkbox.t
+t/2_fill_04_select.t
+t/2_fill_05_textarea.t
+t/2_fill_06_radio.t
+t/2_fill_07_reuse.t
+t/2_fill_08_multiple_objects.t
+t/2_fill_09_default_type.t
+t/2_fill_10_escape.t
+t/2_fill_11_target.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/2_fill_19_complex.t
+t/2_fill_20_switcharoo.t
+t/3_conf_00_base.t
+t/3_conf_01_write.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
--- /dev/null
+CVS/
+^tgz/
+\.~$
+\.#
+\w#$
+\.bak$
+Makefile$
+Makefile\.old$
+blib
+\.gz$
+.cvsignore
+tmon\.out
+t/samples/template
+wrap
\ No newline at end of file
--- /dev/null
+# 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_from: lib/CGI/Ex.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
--- /dev/null
+use ExtUtils::MakeMaker;
+
+###----------------------------------------------------------------###
+# Copyright 2003 - Paul Seamons #
+# Distributed under the GNU General Public License without warranty #
+###----------------------------------------------------------------###
+
+WriteMakefile(
+ NAME => "CGI::Ex",
+ AUTHOR => "Paul Seamons",
+ ABSTRACT_FROM => "lib/CGI/Ex.pm",
+ VERSION_FROM => "lib/CGI/Ex.pm",
+ INSTALLDIRS => 'site',
+
+ dist => {
+ DIST_DEFAULT => 'all tardist',
+ COMPRESS => 'gzip -vf',
+ SUFFIX => '.gz',
+ },
+
+ clean => {
+ FILES => '*~',
+ },
+
+ realclean => {
+ FILES => '*~',
+ },
+ );
+
+package MY;
+
+sub postamble {
+ return qq^
+
+pm_to_blib: README
+
+README: \$(VERSION_FROM)
+ pod2text \$(VERSION_FROM) > README
+^;
+}
+
+1;
--- /dev/null
+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');
+
+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.
+
+ The main functionality is provided by several other modules that may be
+ used separately, or together through the CGI::Ex interface.
+
+ "CGI::Ex::Fill"
+ A regular expression based form filler inner (accessed through
+ ->fill or directly via its own functions). Can be a drop in
+ replacement for HTML::FillInForm. See CGI::Ex::Fill for more
+ information.
+
+ "CGI::Ex::Validate"
+ A form field / cgi parameter / any parameter validator (accessed
+ through ->validate or directly via its own methods). Not quite a
+ drop in for most validators, although it has most of the
+ functionality of most of the validators but with the key additions
+ of conditional validation. Has a tightly integrated JavaScript
+ portion that allows for duplicate client side validation. See
+ CGI::Ex::Validate for more information.
+
+ "CGI::Ex::Conf"
+ A general use configuration, or settings, or key / value file
+ reader. Has ability for providing key fallback as well as immutable
+ key definitions. Has default support for yaml, storable, perl, ini,
+ and xml and open architecture for definition of others. See
+ CGI::Ex::Conf for more information.
+
+METHODS
+ "->fill"
+ fill is used for filling hash or cgi object values into an existing
+ html document (it doesn't deal at all with how you got the
+ document). Arguments may be given as a hash, or a hashref or
+ positional. Some of the following arguments will only work using
+ CGI::Ex::Fill - most will work with either CGI::Ex::Fill or
+ HTML::FillInForm (assume they are available unless specified
+ otherwise). (See CGI::Ex::Fill for a full explanation of
+ functionality). The arguments to fill are as follows (and in order
+ of position):
+
+ "text"
+ Text should be a reference to a scalar string containing the
+ html to be modified (actually it could be any reference or
+ object reference that can be modfied as a string). It will be
+ modified in place. Another named argument scalarref is available
+ if you would like to copy rather than modify.
+
+ "form"
+ Form may be a hashref, a cgi style object, a coderef, or an
+ array of multiple hashrefs, cgi objects, and coderefs. Hashes
+ should be key value pairs. CGI objects should be able to call
+ the method param (This can be overrided). Coderefs should expect
+ 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 tie the hash. Coderefs are not available in
+ HTML::FillInForm. Also HTML::FillInForm only allows CGI objects
+ if an arrayref is used.
+
+ NOTE: Only one of the form, fdat, and fobject arguments are
+ allowed at a time.
+
+ "target"
+ The name of the form that the fields should be filled to. The
+ default value of undef, means to fill in all forms in the html.
+
+ "fill_passwords"
+ Boolean value defaults to 1. If set to zero - password fields
+ will not be filled.
+
+ "ignore_fields"
+ Specify which fields to not fill in. It takes either array ref
+ of names, or a hashref with the names as keys. The hashref
+ option is not available in CGI::Ex::Fill.
+
+ Other named arguments are available for compatiblity with
+ HTML::FillInForm. They may only be used as named arguments.
+
+ "scalarref"
+ Almost the same as the argument text. If scalarref is used, the
+ filled html will be returned. If text is used the html passed is
+ filled in place.
+
+ "arrayref"
+ An array ref of lines of the document. Forces a returned filled
+ html document.
+
+ "file"
+ An filename that will be opened, filled, and returned.
+
+ "fdat"
+ A hashref of key value pairs.
+
+ "fobject"
+ A cgi style object or arrayref of cgi style objects used for
+ getting the key value pairs. Should be capable of the ->param
+ method and ->cookie method as document in CGI.
+
+ See CGI::Ex::Fill for more information about the filling process.
+
+ "->object"
+ Returns the CGI object that is currently being used by CGI::Ex. If
+ none has been set it will automatically generate an object of type
+ $PREFERRED_CGI_MODULE which defaults to CGI.
+
+ "->validate"
+ Validate has a wide range of options available. (See
+ CGI::Ex::Validate for a full explanation of functionality). Validate
+ has two arguments:
+
+ "form"
+ Can be either a hashref to be validated, or a CGI style object
+ (which has the param method).
+
+ "val_hash"
+ The val_hash can be one of three items. First, it can be a
+ straight perl hashref containing the validation to be done.
+ Second, it can be a YAML document string. Third, it can be the
+ path to a file containing the validation. The validation in a
+ validation file will be read in depending upon file extension.
+
+ "->get_form"
+ Very similar to CGI->new->Vars except that arrays are returned as
+ arrays. Not sure why CGI::Val didn't do this anyway (well - yes -
+ legacy Perl 4 - but at some point things need to be updated).
+
+ "->set_form"
+ Allow for setting a custom form hash. Useful for testing, or other
+ purposes.
+
+ "->get_cookies"
+ Returns a hash of all cookies.
+
+ "->make_form"
+ Takes a hash and returns a query_string. A second optional argument
+ may contain an arrayref of keys to use from the hash in building the
+ query_string. First argument is undef, it will use the form stored
+ in itself as the hash.
+
+ "->content_type"
+ Can be called multiple times during the same session. Will only
+ print content-type once. (Useful if you don't know if something else
+ already printed content-type). Calling this sends the Content-type
+ header. Trying to print ->content_type is an error. For clarity, the
+ method ->print_content_type is available.
+
+ "->set_cookie"
+ Arguments are the same as those to CGI->new->cookie({}). Uses CGI's
+ cookie method to create a cookie, but then, depending on if content
+ has already been sent to the browser will either print a Set-cookie
+ header, or will add a <meta http-equiv='set-cookie'> tag (this is
+ supported on most major browsers). This is useful if you don't know
+ if something else already printed content-type.
+
+ "->location_bounce"
+ Depending on if content has already been sent to the browser will
+ either print a Location header, or will add a <meta
+ http-equiv='refresh'> tag (this is supported on all major browsers).
+ This is useful if you don't know if something else already printed
+ content-type. Takes single argument of a url.
+
+ "->last_modified"
+ Depending on if content has already been sent to the browser will
+ either print a Last-Modified header, or will add a <meta
+ http-equiv='Last-Modified'> tag (this is supported on most major
+ browsers). This is useful if you don't know if something else
+ already printed content-type. Takes an argument of either a time
+ (may be a CGI -expires style time) or a filename.
+
+ "->expires"
+ Depending on if content has already been sent to the browser will
+ either print a Expires header, or will add a <meta
+ http-equiv='Expires'> tag (this is supported on most major
+ browsers). This is useful if you don't know if something else
+ already printed content-type. Takes an argument of a time (may be a
+ CGI -expires style time).
+
+ "->send_status"
+ Send a custom status. Works in both CGI and mod_perl. Arguments are
+ a status code and the content (optional).
+
+ "->send_header"
+ Send a http header. Works in both CGI and mod_perl. Arguments are a
+ header name and the value for that header.
+
+ "->print_js"
+ Prints out a javascript file. Does everything it can to make sure
+ that the javascript will cache. Takes either a full filename, or a
+ shortened name which will be looked for in @INC. (ie
+ /full/path/to/my.js or CGI/Ex/validate.js or CGI::Ex::validate)
+
+ "->swap_template"
+ This is intended as a simple yet strong subroutine to swap in tags
+ to a document. It is intended to be very basic for those who may not
+ want the full features of a Templating system such as
+ Template::Toolkit (even though they should investigate them because
+ they are pretty nice). The default allows for basic template toolkit
+ variable swapping. There are two arguments. First is a string or a
+ reference to a string. If a string is passed, a copy of that string
+ is swapped and returned. If a reference to a string is passed, it is
+ modified in place. The second argument is a form, or a CGI object,
+ or a cgiex object, or a coderef (if the second argument is missing,
+ the cgiex object which called the method will be used). If it is a
+ coderef, it should accept key as its only argument and return the
+ proper value.
+
+ my $cgix = CGI::Ex->new;
+ my $form = {foo => 'bar',
+ this => {is => {nested => ['wow', 'wee']}}
+ };
+
+ my $str = $cgix->swap_template("<html>[% foo %]<br>[% foo %]</html>", $form));
+ # $str eq '<html>bar<br>bar</html>'
+
+ $str = $cgix->swap_template("[% this.is.nested.1 %]", $form));
+ # $str eq 'wee'
+
+ $str = "[% this.is.nested.0 %]";
+ $cgix->swap_template(\$str, $form);
+ # $str eq 'wow'
+
+ # may also be called with only one argument as follows:
+ # assuming $cgix had a query string of ?foo=bar&baz=wow&this=wee
+ $str = "<html>([% foo %]) <br>
+ ([% baz %]) <br>
+ ([% this %]) </html>";
+ $cgix->swap_template(\$str);
+ #$str eq "<html>(bar) <br>
+ # (wow) <br>
+ # (wee) </html>";
+
+ For further examples, please see the code contained in
+ t/samples/cgi_ex_* of this distribution.
+
+ If at a later date, the developer upgrades to Template::Toolkit, the
+ templates that were being swapped by CGI::Ex::swap_template should
+ be compatible with Template::Toolkit.
+
+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.
+
+ Add an integrated debug module.
+
+MODULES
+ See also CGI::Ex::Fill.
+
+ See also CGI::Ex::Validate.
+
+ See also CGI::Ex::Conf.
+
+ See also CGI::Ex::Die.
+
+ See also CGI::Ex::App.
+
+ See also CGI::Ex::Dump.
+
+AUTHOR
+ Paul Seamons
+
+LICENSE
+ This module may be distributed under the same terms as Perl itself.
+
--- /dev/null
+package CGI::Ex;
+
+### CGI Extended
+
+###----------------------------------------------------------------###
+# Copyright 2003 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
+### See perldoc at bottom
+
+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
+ );
+
+###----------------------------------------------------------------###
+
+# my $cgix = CGI::Ex->new;
+sub new {
+ 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
+ };
+}
+
+### allow for calling their 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(@_);
+}
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+### Form getter that will act like CGI->new->Vars only it will return arrayrefs
+### for values that are arrays
+# my $hash = $cgix->get_form;
+# my $hash = $cgix->get_form(CGI->new);
+# 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;
+}
+
+### 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 || {};
+}
+
+### 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;
+}
+
+### 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
+ }
+ }
+ chop $str;
+ return $str;
+}
+
+###----------------------------------------------------------------###
+
+### like get_form - but a hashref of cookies
+### cookies are parsed depending upon the functionality of ->cookie
+# my $hash = $cgix->get_cookies;
+# my $hash = $cgix->get_cookies(CGI->new);
+# 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;
+}
+
+### 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 || {};
+}
+
+### 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;
+}
+
+###----------------------------------------------------------------###
+
+### Allow for shared apache request object
+# 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'};
+}
+
+### 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'};
+}
+
+sub is_mod_perl_1 { shift->mod_perl_version < 1.98 }
+sub is_mod_perl_2 { shift->mod_perl_version >= 1.98 }
+
+### Allow for a setter
+# $cgix->set_apache_request($r)
+sub set_apache_request { shift->apache_request(shift) }
+
+###----------------------------------------------------------------###
+
+### same signature as print_content_type
+sub content_type {
+ &print_content_type;
+}
+
+### will send the Content-type header
+# $cgix->print_content_type;
+# $cgix->print_content_type('text/plain');
+# 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'} = '';
+ }
+ $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;
+ }
+}
+
+###----------------------------------------------------------------###
+
+### location bounce nicely - even if we have already sent content
+### may be called as function or a method
+# $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;
+
+ 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";
+ }
+ }
+}
+
+### set a cookie nicely - even if we have already sent content
+### may be called as function or a method - fancy algo to allow for first argument of args hash
+# $cgix->set_cookie({name => $name, ...});
+# $cgix->set_cookie( name => $name, ... );
+# 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);
+ }
+ } else {
+ print "Set-Cookie: $cookie\r\n"
+ }
+ }
+}
+
+### print the last modified time
+### takes a time or filename and an optional keyname
+# $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);
+ }
+ } else {
+ 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');
+}
+
+### 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];
+ }
+}
+
+
+### 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);
+ } else {
+ # not sure of best way to send the message in MP2
+ }
+ } 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);
+ } else {
+ my $t = $r->headers_out;
+ $t->add($key, $value);
+ $r->headers_out($t);
+ }
+ } 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;
+ }
+ } 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;
+ }
+
+ ### 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) {
+ local $/ = undef;
+ print <IN>;
+ close IN;
+ } else {
+ die "Couldn't open file $js_file: $!";
+ }
+}
+
+###----------------------------------------------------------------###
+
+### form filler that will use either HTML::FillInForm, CGI::Ex::Fill
+### 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;
+ } 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);
+
+ require CGI::Ex::Validate;
+
+ 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(@_);
+ };
+}
+
+sub conf_read {
+ my $self = shift || die "Sub \"conf_read\" must be called as a method";
+ 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);
+ } 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
+ }
+ }xeg;
+
+ return ref($str) ? 1 : $$ref;
+}
+
+###----------------------------------------------------------------###
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Ex - CGI utility suite (form getter/filler/validator/app builder)
+
+=head1 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');
+
+=head1 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 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.
+
+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::Fill>
+
+A regular expression based form filler inner (accessed through B<-E<gt>fill>
+or directly via its own functions). Can be a drop in replacement for
+HTML::FillInForm. See L<CGI::Ex::Fill> for more information.
+
+=item C<CGI::Ex::Validate>
+
+A form field / cgi parameter / any parameter validator (accessed through
+B<-E<gt>validate> or directly via its own methods). Not quite a drop in
+for most validators, although it has most of the functionality of most
+of the validators but with the key additions of conditional validation.
+Has a tightly integrated JavaScript portion that allows for duplicate client
+side validation. See L<CGI::Ex::Validate> for more information.
+
+=item C<CGI::Ex::Conf>
+
+A general use configuration, or settings, or key / value file reader. Has
+ability for providing key fallback as well as immutable key definitions. Has
+default support for yaml, storable, perl, ini, and xml and open architecture
+for definition of others. See L<CGI::Ex::Conf> for more information.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item C<-E<gt>fill>
+
+fill is used for filling hash or cgi object values into an existing
+html document (it doesn't deal at all with how you got the document).
+Arguments may be given as a hash, or a hashref or positional. Some
+of the following arguments will only work using CGI::Ex::Fill - most
+will work with either CGI::Ex::Fill or HTML::FillInForm (assume they
+are available unless specified otherwise). (See L<CGI::Ex::Fill> for
+a full explanation of functionality). The arguments to fill are as
+follows (and in order of position):
+
+=over 4
+
+=item C<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 modified in place.
+Another named argument B<scalarref> is available if you would like to
+copy rather than modify.
+
+=item C<form>
+
+Form may be a hashref, a cgi style object, a coderef, or an array of
+multiple hashrefs, cgi objects, and coderefs. Hashes should be key
+value pairs. CGI objects should be able
+to call the method 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
+(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
+tie the hash. Coderefs are not available in HTML::FillInForm. Also
+HTML::FillInForm only allows CGI objects if an arrayref is used.
+
+NOTE: Only one of the form, fdat, and fobject arguments are allowed at
+a time.
+
+=item C<target>
+
+The name of the form that the fields should be filled to. The default
+value of undef, means to fill in all forms in the html.
+
+=item C<fill_passwords>
+
+Boolean value defaults to 1. If set to zero - password fields will
+not be filled.
+
+=item C<ignore_fields>
+
+Specify which fields to not fill in. It takes either array ref of
+names, or a hashref with the names as keys. The hashref option is
+not available in CGI::Ex::Fill.
+
+=back
+
+Other named arguments are available for compatiblity with HTML::FillInForm.
+They may only be used as named arguments.
+
+=over 4
+
+=item C<scalarref>
+
+Almost the same as the argument text. If scalarref is used, the filled
+html will be returned. If text is used the html passed is filled in place.
+
+=item C<arrayref>
+
+An array ref of lines of the document. Forces a returned filled html
+document.
+
+=item C<file>
+
+An filename that will be opened, filled, and returned.
+
+=item C<fdat>
+
+A hashref of key value pairs.
+
+=item C<fobject>
+
+A cgi style object or arrayref of cgi style objects used for getting
+the key value pairs. Should be capable of the ->param method and
+->cookie method as document in L<CGI>.
+
+=back
+
+See L<CGI::Ex::Fill> for more information about the filling process.
+
+=item C<-E<gt>object>
+
+Returns the CGI object that is currently being used by CGI::Ex. If none
+has been set it will automatically generate an object of type
+$PREFERRED_CGI_MODULE which defaults to B<CGI>.
+
+=item C<-E<gt>validate>
+
+Validate has a wide range of options available. (See L<CGI::Ex::Validate>
+for a full explanation of functionality). Validate has two arguments:
+
+=over 4
+
+=item C<form>
+
+Can be either a hashref to be validated, or a CGI style object (which
+has the param method).
+
+=item C<val_hash>
+
+The val_hash can be one of three items. First, it can be a straight
+perl hashref containing the validation to be done. Second, it can
+be a YAML document string. Third, it can be the path to a file
+containing the validation. The validation in a validation file will
+be read in depending upon file extension.
+
+=back
+
+=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 -
+legacy Perl 4 - but at some point things need to be updated).
+
+=item C<-E<gt>set_form>
+
+Allow for setting a custom form hash. Useful for testing, or other
+purposes.
+
+=item C<-E<gt>get_cookies>
+
+Returns a hash of all cookies.
+
+=item C<-E<gt>make_form>
+
+Takes a hash and returns a query_string. A second optional argument
+may contain an arrayref of keys to use from the hash in building the
+query_string. First argument is undef, it will use the form stored
+in itself as the hash.
+
+=item C<-E<gt>content_type>
+
+Can be called multiple times during the same session. Will only
+print content-type once. (Useful if you don't know if something
+else already printed content-type). Calling this sends the Content-type
+header. Trying to print -E<gt>content_type is an error. For clarity,
+the method -E<gt>print_content_type is available.
+
+=item C<-E<gt>set_cookie>
+
+Arguments are the same as those to CGI->new->cookie({}).
+Uses CGI's cookie method to create a cookie, but then, depending on
+if content has already been sent to the browser will either print
+a Set-cookie header, or will add a <meta http-equiv='set-cookie'>
+tag (this is supported on most major browsers). This is useful if
+you don't know if something else already printed content-type.
+
+=item C<-E<gt>location_bounce>
+
+Depending on if content has already been sent to the browser will either print
+a Location header, or will add a <meta http-equiv='refresh'>
+tag (this is supported on all major browsers). This is useful if
+you don't know if something else already printed content-type. Takes
+single argument of a url.
+
+=item C<-E<gt>last_modified>
+
+Depending on if content has already been sent to the browser will either print
+a Last-Modified header, or will add a <meta http-equiv='Last-Modified'>
+tag (this is supported on most major browsers). This is useful if
+you don't know if something else already printed content-type. Takes an
+argument of either a time (may be a CGI -expires style time) or a filename.
+
+=item C<-E<gt>expires>
+
+Depending on if content has already been sent to the browser will either print
+a Expires header, or will add a <meta http-equiv='Expires'>
+tag (this is supported on most major browsers). This is useful if
+you don't know if something else already printed content-type. Takes an
+argument of a time (may be a CGI -expires style time).
+
+=item C<-E<gt>send_status>
+
+Send a custom status. Works in both CGI and mod_perl. Arguments are
+a status code and the content (optional).
+
+=item C<-E<gt>send_header>
+
+Send a http header. Works in both CGI and mod_perl. Arguments are
+a header name and the value for that header.
+
+=item C<-E<gt>print_js>
+
+Prints out a javascript file. Does everything it can to make sure
+that the javascript will cache. Takes either a full filename,
+or a shortened name which will be looked for in @INC. (ie /full/path/to/my.js
+or CGI/Ex/validate.js or CGI::Ex::validate)
+
+=item C<-E<gt>swap_template>
+
+This is intended as a simple yet strong subroutine to swap
+in tags to a document. It is intended to be very basic
+for those who may not want the full features of a Templating
+system such as Template::Toolkit (even though they should
+investigate them because they are pretty nice). The default allows
+for basic template toolkit variable swapping. There are two arguments.
+First is a string or a reference to a string. If a string is passed,
+a copy of that string is swapped and returned. If a reference to a
+string is passed, it is modified in place. The second argument is
+a form, or a CGI object, or a cgiex object, or a coderef (if the second
+argument is missing, the cgiex object which called the method will be
+used). If it is a coderef, it should accept key as its only argument and
+return the proper value.
+
+ my $cgix = CGI::Ex->new;
+ my $form = {foo => 'bar',
+ this => {is => {nested => ['wow', 'wee']}}
+ };
+
+ my $str = $cgix->swap_template("<html>[% foo %]<br>[% foo %]</html>", $form));
+ # $str eq '<html>bar<br>bar</html>'
+
+ $str = $cgix->swap_template("[% this.is.nested.1 %]", $form));
+ # $str eq 'wee'
+
+ $str = "[% this.is.nested.0 %]";
+ $cgix->swap_template(\$str, $form);
+ # $str eq 'wow'
+
+ # may also be called with only one argument as follows:
+ # assuming $cgix had a query string of ?foo=bar&baz=wow&this=wee
+ $str = "<html>([% foo %]) <br>
+ ([% baz %]) <br>
+ ([% this %]) </html>";
+ $cgix->swap_template(\$str);
+ #$str eq "<html>(bar) <br>
+ # (wow) <br>
+ # (wee) </html>";
+
+For further examples, please see the code contained in t/samples/cgi_ex_*
+of this distribution.
+
+If at a later date, the developer upgrades to Template::Toolkit, the
+templates that were being swapped by CGI::Ex::swap_template should
+be compatible with Template::Toolkit.
+
+=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::Validate>.
+
+See also L<CGI::Ex::Conf>.
+
+See also L<CGI::Ex::Die>.
+
+See also L<CGI::Ex::App>.
+
+See also L<CGI::Ex::Dump>.
+
+=head1 AUTHOR
+
+Paul Seamons
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package CGI::Ex::App;
+
+### CGI Extended Application
+
+###----------------------------------------------------------------###
+# Copyright 2004 - 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);
+
+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
+
+ ### 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;
+}
+
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $self = ref($_[0]) ? 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;
+
+ eval {
+
+ ### 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";
+ }
+
+ ### one chance to do things at the very end
+ $self->post_navigate;
+
+ };
+
+ ### catch errors - if any
+ if ($@) {
+ $self->handle_error($@);
+ }
+
+ return $self;
+}
+
+sub nav_loop {
+ my $self = shift;
+
+ ### keep from an infinate nesting
+ local $self->{recurse} = $self->{recurse} || 0;
+ if ($self->{recurse} ++ >= $self->recurse_limit) {
+ my $err = "recurse_limit 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;
+ }
+ }
+
+ ### 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);
+
+ $self->unmorph($step);
+
+ ### Allow for the run_step to intercept.
+ ### A true status means the run_step took over navigation.
+ return if $status;
+ }
+
+ ### 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
+
+ return;
+}
+
+sub pre_navigate {}
+
+sub post_navigate {}
+
+sub recurse_limit { shift->{'recurse_limit'} || $RECURSE_LIMIT || 15 }
+
+sub run_step {
+ my $self = shift;
+ my $step = shift;
+
+ ### if the pre_step exists and returns true, exit the nav_loop
+ return 1 if $self->run_hook('pre_step', $step);
+
+ ### allow for skipping this step (but stay in the nav_loop)
+ return 0 if $self->run_hook('skip', $step);
+
+ ### 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)) {
+
+ ### show the page requesting the information
+ $self->run_hook('prepared_print', $step);
+
+ ### a hook after the printing process
+ $self->run_hook('post_print', $step);
+
+ return 2;
+ }
+
+ ### 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;
+}
+
+### standard functions for printing - gather information
+sub prepared_print {
+ 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);
+
+ ### run the print hook - passing it the form and fill info
+ $self->run_hook('print', $step, undef,
+ $swap, $fill);
+}
+
+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 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 step_key {
+ my $self = shift;
+ return $self->{'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);
+ }
+
+ \@path; # return of the do
+ };
+}
+
+### 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
+}
+
+### legacy - same as append_path
+sub add_to_path {
+ my $self = shift;
+ push @{ $self->path }, @_;
+}
+
+### append entries onto the end
+sub append_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
+ }
+}
+
+### 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
+ }
+}
+
+### a hash of paths that are allowed, default undef is all
+sub valid_steps {}
+
+###----------------------------------------------------------------###
+### allow for checking where we are in the path
+
+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];
+}
+
+sub previous_step {
+ my $self = shift;
+ die "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) );
+}
+
+sub next_step {
+ my $self = shift;
+ die "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 } );
+}
+
+sub first_step {
+ my $self = shift;
+ die "first_step is readonly" if $#_ != -1;
+ return $self->step_by_path_index( 0 );
+}
+
+###----------------------------------------------------------------###
+
+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, @_);
+}
+
+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;
+}
+
+###----------------------------------------------------------------###
+### utility modules for jeckyl/hyde on self
+
+sub allow_morph {
+ my $self = shift;
+ return $self->{'allow_morph'} ? 1 : 0;
+}
+
+sub allow_nested_morph {
+ my $self = shift;
+ return $self->{'allow_nested_morph'} ? 1 : 0;
+}
+
+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";
+ } else {
+ $$sref .= " - failed from $cur to $new: $@";
+ my $err = "Trouble while morphing to $file: $@";
+ debug $err;
+ 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);
+ }
+ bless $self, $prev;
+ push @$hist, "$step - unmorph - unmorph - changed from $cur to $prev";
+ } else {
+ push @$hist, "$step - unmorph - unmorph - already isa $cur";
+ }
+
+ return $self;
+}
+
+###----------------------------------------------------------------###
+### allow for cleanup including deep nested objects
+
+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;
+ }
+ }
+ }
+}
+
+###----------------------------------------------------------------###
+### 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;
+}
+
+sub cookies {
+ my $self = shift;
+ if ($#_ != -1) {
+ $self->{cookies} = shift || die "Invalid cookies";
+ }
+ 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;
+}
+
+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
+ };
+}
+
+sub set_auth {
+ my $self = shift;
+ $self->{auth} = shift;
+}
+
+### 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;
+}
+
+###----------------------------------------------------------------###
+### js_validation items
+
+### 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
+
+ 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;
+
+ return $self->vob->generate_js($hash_val, $form_name, $js_uri);
+}
+
+### 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
+}
+
+### name to attach js validation to
+sub form_name { 'theform' }
+
+### provide some rudimentary javascript support
+### if valid_steps is defined - it should include "js"
+sub js_run_step {
+ my $self = shift;
+
+ ### 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 : '';
+
+ $self->cgix->print_js($file);
+ return 1; # intercepted
+}
+
+###----------------------------------------------------------------###
+### implementation specific subs
+
+sub template_args {
+ my $self = shift;
+ my $step = shift;
+ return {
+ INCLUDE_PATH => $self->base_dir_abs,
+ };
+}
+
+sub print {
+ my $self = shift;
+ my $step = shift;
+ my $swap = shift;
+ my $fill = shift;
+
+ ### get a filename relative to base_dir_abs
+ my $file = $self->run_hook('file_print', $step);
+
+ require Template;
+ my $t = Template->new($self->template_args($step));
+
+ ### process the document
+ my $out = '';
+ my $status = $t->process($file, $swap, \$out) || die $Template::ERROR;
+
+ ### fill in any forms
+ $self->cgix->fill(\$out, $fill) if $fill && ! $self->{no_fill};
+
+ ### now print
+ $self->cgix->print_content_type();
+ print $out;
+}
+
+sub base_dir_rel {
+ my $self = shift;
+ $self->{base_dir_rel} = shift if $#_ != -1;
+ return $self->{base_dir_rel} ||= $BASE_DIR_REL;
+}
+
+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";
+}
+
+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 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";
+}
+
+sub has_errors {
+ my $self = shift;
+ return 1 if scalar keys %{ $self->hash_errors };
+}
+
+sub format_error {
+ my $self = shift;
+ my $error = shift;
+# return $error if $error =~ /<span/i;
+# return "<span class=\"error\">$error</span>";
+}
+
+###----------------------------------------------------------------###
+### default stub subs
+
+### 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 base_name_module {
+ my $self = shift;
+ $self->{base_name_module} = shift if $#_ != -1;
+ return $self->{base_name_module} ||= $BASE_NAME_MODULE;
+}
+
+### 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)";
+ }
+}
+
+### which file is used for templating
+sub file_print {
+ 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;
+
+ return "$base_dir_rel/$module/$_step.$ext";
+}
+
+### which file is used for validation
+sub file_val {
+ 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;
+
+ ### get absolute if necessary
+ if ($base_dir !~ m|^/|) {
+ $base_dir = $self->base_dir_abs . "/$base_dir";
+ }
+
+ return "$base_dir/$module/$_step.$ext";
+}
+
+
+sub info_complete {
+ my $self = shift;
+ my $step = shift;
+
+ return 0 if ! $self->run_hook('ready_validate', $step);
+
+ return $self->run_hook('validate', $step);
+}
+
+sub ready_validate {
+ 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;
+}
+
+sub set_ready_validate {
+ my $self = shift;
+ my $ready = shift;
+ $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;
+ }
+ }
+
+ return 1;
+}
+
+### allow for using ConfUtil instead of yaml
+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);
+
+ ### 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;
+
+ ### read the file - it it fails - errors should shown in the error logs
+ } elsif ($file) {
+ $hash = eval { $self->vob->get_validation($file) } || {};
+
+ } else {
+ $hash = {};
+ }
+
+ $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) },
+ };
+}
+
+sub hash_common { shift->{'hash_common'} ||= {} }
+sub hash_form { shift->form }
+sub hash_fill { shift->{'hash_fill'} ||= {} }
+sub hash_swap { shift->{'hash_swap'} ||= {} }
+sub hash_errors { shift->{'hash_errors'} ||= {} }
+
+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};
+ }
+ }
+ $hash->{'has_errors'} = 1;
+}
+
+sub add_to_errors { shift->add_errors(@_) }
+sub add_to_swap { my $self = shift; $self->add_to_hash($self->hash_swap, @_) }
+sub add_to_fill { my $self = shift; $self->add_to_hash($self->hash_fill, @_) }
+sub add_to_form { my $self = shift; $self->add_to_hash($self->hash_form, @_) }
+sub add_to_common { my $self = shift; $self->add_to_hash($self->hash_common, @_) }
+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;
+}
+
+###----------------------------------------------------------------###
+
+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;
+}
+
+###----------------------------------------------------------------###
+
+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 {
+ my $self = shift;
+
+ 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 {
+ 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;
+ # 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'} }
+
+=item Method C<-E<gt>set_ready_validate>
+
+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 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.
+
+=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>
+
+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.
+
+=item Hook C<-E<gt>prepared_print>
+
+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 Hook C<-E<gt>post_print>
+
+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>
+
+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
--- /dev/null
+package CGI::Ex::Auth;
+
+### CGI Extended Application
+
+###----------------------------------------------------------------###
+# Copyright 2004 - 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 MIME::Base64 qw(encode_base64 decode_base64);
+
+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;
+ #}
+}
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $self = ref($_[0]) ? shift : {@_};
+ bless $self, $class;
+ $self->init();
+ return $self;
+}
+
+sub init {}
+
+###----------------------------------------------------------------###
+
+sub require_auth {
+ my $self = shift;
+ $self = __PACKAGE__->new($self) if ! UNIVERSAL::isa($self, __PACKAGE__);
+
+ ### 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 $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" : "");
+ }
+ $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;
+ }
+ }
+
+ ### 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;
+}
+
+###----------------------------------------------------------------###
+
+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;
+ }
+
+ ### 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\"";
+ }
+
+ $self->cgix->print_content_type();
+ print $content;
+ return 0;
+}
+
+###----------------------------------------------------------------###
+
+sub success {
+ my $self = shift;
+ my $user = shift;
+ $self->{user} = $ENV{REMOTE_USER} = $user;
+ $self->hook_success($user);
+ return 1;
+}
+
+sub user {
+ my $self = shift;
+ return $self->{user};
+}
+
+sub hook_success {
+ my $self = shift;
+ my $user = shift;
+ my $meth;
+ if ($meth = $self->{hook_success}) {
+ $self->$meth($user);
+ }
+}
+
+###----------------------------------------------------------------###
+
+sub delete_cookie {
+ my $self = shift;
+ my $key_c = $self->key_cookie;
+ $self->cgix->set_cookie({
+ -name => $key_c,
+ -value => '',
+ -expires => '-10y',
+ -path => '/',
+ });
+}
+
+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 => '/',
+ });
+}
+
+sub location_bounce {
+ 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_cookie {
+ my $self = shift;
+ $self->{key_cookie} = shift if $#_ != -1;
+ return $self->{key_cookie} ||= 'ce_auth';
+}
+
+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 key_pass {
+ my $self = shift;
+ $self->{key_pass} = shift if $#_ != -1;
+ return $self->{key_pass} ||= 'ce_pass';
+}
+
+sub key_save {
+ my $self = shift;
+ $self->{key_save} = shift if $#_ != -1;
+ return $self->{key_save} ||= 'ce_save';
+}
+
+sub key_redirect {
+ my $self = shift;
+ $self->{key_redirect} = shift if $#_ != -1;
+ return $self->{key_redirect} ||= 'redirect';
+}
+
+sub form_name {
+ my $self = shift;
+ $self->{form_name} = shift if $#_ != -1;
+ return $self->{form_name} ||= 'ce_form';
+}
+
+sub allow_htauth {
+ my $self = shift;
+ $self->{allow_htauth} = shift if $#_ != -1;
+ return $self->{allow_htauth} ||= 0;
+}
+
+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 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 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;
+ }
+ 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;
+ }
+
+ ### 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;
+ }
+
+ ### no payload - compare directly
+ if ($hash_test !~ m|^(.+)/([^/]+)$|) {
+ return lc($pass_test) eq lc($pass_real);
+
+ ### and finally - check the payload (allows for expiring login)
+ } 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;
+
+ return 0 if $self->enc_func($type_test, "$payload/$hash_real") ne $compare;
+
+ ### 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;
+ }
+ }
+ 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);
+ }
+}
+
+sub set_hook_get_pass_by_user {
+ my $self = shift;
+ $self->{hook_get_pass_by_user} = shift;
+}
+
+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 cgix {
+ my $self = shift;
+ $self->{cgix} = shift if $#_ != -1;
+ return $self->{cgix} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new(); # return of the do
+ };
+}
+
+sub form {
+ my $self = shift;
+ if ($#_ != -1) {
+ $self->{form} = shift || die "Invalid form";
+ }
+ 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;
+}
+
+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 basic_login_page {
+ my $self = shift;
+ my $form = shift;
+
+ my $text = $self->basic_login_template();
+ $self->cgix->swap_template(\$text, $form);
+ $self->cgix->fill(\$text, $form);
+
+ return $text;
+}
+
+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>
+ <td>Username:</td>
+ <td><input name="[% key_user %]" type="text" size="30" value=""></td>
+ </tr>
+ <tr>
+ <td>Password:</td>
+ <td><input name="[% key_pass %]" type="password" size="30" value=""></td>
+ </tr>
+ <tr>
+ <td colspan="2">
+ <input type="checkbox" name="[% key_save %]" value="1"> Save Password ?
+ </td>
+ </tr>
+ <tr>
+ <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>
+ <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;
+ return false;
+ }
+ if (document.${type}_hex) document.$form->{form_name}.onsubmit = function () { return send_it() }
+ </script>
+ };
+}
+
+###----------------------------------------------------------------###
+
+### 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");
+
+ return $self->cgix->make_form({
+ $self->key_user => $user,
+ $self->key_pass => "sha1($payload/$save/$pass)",
+ $self->key_save => $save,
+ });
+}
+
+###----------------------------------------------------------------###
+
+1;
+
+__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',
+ });
+ ### 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;
+ }
+
+=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:
+
+ my $pass = "plaintextpassword";
+ my $save = ($save_the_password) ? 1 : 0;
+ my $time = time;
+ my $store = sha1_hex("$time/$save/" . sha1_hex($pass));
+
+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.
+
+=head1 METHODS
+
+=over 4
+
+=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>
+
+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<key_logout>
+
+If a key is passed the form hash that matches this key, the current user will
+be logged out. Default is "logout".
+
+=item C<key_cookie>
+
+The name of the auth cookie. Default is "ce_auth".
+
+=item C<key_cookie_check>
+
+A field name used during a bounce to see if cookies exist. Default is "ccheck".
+
+=item C<key_user>
+
+The form field name used to pass the username. Default is "ce_user".
+
+=item C<key_pass>
+
+The form field name used to pass the password. Default is "ce_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).
+
+=item C<form_name>
+
+The name of the html login form to attach the javascript to. Default is "ce_form".
+
+=item C<payload>
+
+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.
+
+=item C<verify_userpass>
+
+Called to verify the passed form information or the stored cookie. Calls hook_verify_userpass.
+
+=item C<hook_verify_userpass>
+
+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.
+
+=item C<hook_get_pass_by_user>
+
+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.
+
+=item C<set_hook_get_pass_by_user>
+
+Allows for setting the subref used by hook_get_pass_by_user.x
+
+=item C<cgix>
+
+Returns a CGI::Ex object.
+
+=item C<form>
+
+A hash of passed form info. Defaults to CGI::Ex::get_form.
+
+=item C<cookies>
+
+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<basic_login_page>
+
+Calls the basic_login_template, swaps in the form variables (including
+form name, login_script, etc). Then prints content_type, the content, and
+returns.
+
+=item C<basic_login_template>
+
+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.
+
+=item C<login_type>
+
+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.
+
+SHA1 comparison will work with passwords stored as plaintext password,
+or stored as the string "sha1(".sha1_hex($password).")".
+
+MD5 comparison will work with passwords stored as plaintext password,
+or stored as the string "md5(".md5_hex($password).")".
+
+Plaintext comparison will work with passwords stored as sha1(string),
+md5(string), plaintext password string, or crypted password.
+
+=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>
+
+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.
+
+ my $login = $self->auth->auth_string_sha1($user, $pass, 1);
+ my $url = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?$login";
+
+=head1 TODO
+
+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.
+
+=head1 AUTHORS
+
+Paul Seamons <perlspam at seamons dot com>
+
+=cut
--- /dev/null
+package CGI::Ex::Conf;
+
+### CGI Extended Conf Reader
+
+###----------------------------------------------------------------###
+# Copyright 2004 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
+### See perldoc at bottom
+
+use strict;
+use vars qw($VERSION
+ @DEFAULT_PATHS
+ $DEFAULT_EXT
+ %EXT_READERS
+ %EXT_WRITERS
+ $DIRECTIVE
+ $IMMUTABLE_QR
+ $IMMUTABLE_KEY
+ %CACHE
+ $HTML_KEY
+ $DEBUG_ON_FAIL
+ );
+use CGI::Ex::Dump qw(debug dex_warn);
+
+$VERSION = '0.03';
+
+$DEFAULT_EXT = 'conf';
+
+%EXT_READERS = ('' => \&read_handler_yaml,
+ 'conf' => \&read_handler_yaml,
+ 'ini' => \&read_handler_ini,
+ 'pl' => \&read_handler_pl,
+ 'sto' => \&read_handler_storable,
+ 'storable' => \&read_handler_storable,
+ 'val' => \&read_handler_yaml,
+ 'xml' => \&read_handler_xml,
+ 'yaml' => \&read_handler_yaml,
+ 'yml' => \&read_handler_yaml,
+ 'html' => \&read_handler_html,
+ 'htm' => \&read_handler_html,
+ );
+
+%EXT_WRITERS = ('' => \&write_handler_yaml,
+ 'conf' => \&write_handler_yaml,
+ 'ini' => \&write_handler_ini,
+ 'pl' => \&write_handler_pl,
+ 'sto' => \&write_handler_storable,
+ 'storable' => \&write_handler_storable,
+ 'val' => \&write_handler_yaml,
+ 'xml' => \&write_handler_xml,
+ 'yaml' => \&write_handler_yaml,
+ 'yml' => \&write_handler_yaml,
+ 'html' => \&write_handler_html,
+ 'htm' => \&write_handler_html,
+ );
+
+### $DIRECTIVE controls how files are looked for when namespaces are not absolute.
+### If directories 1, 2 and 3 are passed and each has a config file
+### LAST would return 3, FIRST would return 1, and MERGE will
+### try to put them all together. Merge behavior of hashes
+### is determined by $IMMUTABLE_\w+ variables.
+$DIRECTIVE = 'LAST'; # LAST, MERGE, FIRST
+
+$IMMUTABLE_QR = qr/_immu(?:table)?$/i;
+
+$IMMUTABLE_KEY = 'immutable';
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $self = (@_ && ref($_[0])) ? shift : {@_};
+
+ return bless $self, $class;
+}
+
+sub paths {
+ my $self = shift;
+ return $self->{paths} ||= \@DEFAULT_PATHS;
+}
+
+###----------------------------------------------------------------###
+
+sub read_ref {
+ my $self = shift;
+ my $file = shift;
+ my $args = shift || {};
+ my $ext;
+
+ ### they passed the right stuff already
+ 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
+ } else {
+ return &yaml_load($$file); # allow for ref to a YAML string
+ }
+ } else {
+ return $file;
+ }
+
+ ### if contains a newline - treat it as a YAML string
+ } elsif (index($file,"\n") != -1) {
+ return &yaml_load($file);
+
+ ### 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}) {
+ 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";
+ }
+
+ 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 undef;
+ };
+}
+
+### allow for different kinds of merging of arguments
+### allow for key fallback on hashes
+### allow for immutable values on hashes
+sub read {
+ my $self = shift;
+ my $namespace = shift;
+ my $args = shift || {};
+ my $REF = $args->{ref} || undef; # can pass in existing set of options
+ my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types
+
+ $self = $self->new() if ! ref $self;
+
+ ### allow for fast short ciruit on path lookup for several cases
+ my $directive;
+ my @paths = ();
+ if (ref($namespace) # already a ref
+ || index($namespace,"\n") != -1 # yaml string to read in
+ || $namespace =~ m|^\.{0,2}/.+$| # absolute or relative file
+ ) {
+ push @paths, $namespace;
+ $directive = 'FIRST';
+
+ ### 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 read on $namespace";
+ $paths = [$paths] if ! ref $paths;
+ if ($directive eq 'LAST') { # LAST shall be FIRST
+ $directive = 'FIRST';
+ $paths = [reverse @$paths] if $#$paths != 0;
+ }
+ foreach my $path (@$paths) {
+ next if exists $CACHE{$path} && ! $CACHE{$path};
+ push @paths, "$path/$namespace";
+ }
+ }
+
+ ### 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";
+ }
+
+ ### now loop looking for a ref
+ foreach my $path (@paths) {
+ my $ref = $self->read_ref($path, $args) || next;
+ if (! $REF) {
+ if (UNIVERSAL::isa($ref, 'ARRAY')) {
+ $REF = [];
+ } elsif (UNIVERSAL::isa($ref, 'HASH')) {
+ $REF = {};
+ } else {
+ die "Unknown config type of \"".ref($ref)."\" for namespace $namespace";
+ }
+ } elsif (! UNIVERSAL::isa($ref, ref($REF))) {
+ die "Found different reference types for namespace $namespace"
+ . " - wanted a type ".ref($REF);
+ }
+ if (ref($REF) eq 'ARRAY') {
+ if ($directive eq 'MERGE') {
+ push @$REF, @$ref;
+ next;
+ }
+ splice @$REF, 0, $#$REF + 1, @$ref;
+ last;
+ } else {
+ my $immutable = delete $ref->{$IMMUTABLE_KEY};
+ my ($key,$val);
+ if ($directive eq 'MERGE') {
+ while (($key,$val) = each %$ref) {
+ next if $IMMUTABLE->{$key};
+ my $immute = $key =~ s/$IMMUTABLE_QR//o;
+ $IMMUTABLE->{$key} = 1 if $immute || $immutable;
+ $REF->{$key} = $val;
+ }
+ next;
+ }
+ delete $REF->{$key} while $key = each %$REF;
+ while (($key,$val) = each %$ref) {
+ my $immute = $key =~ s/$IMMUTABLE_QR//o;
+ $IMMUTABLE->{$key} = 1 if $immute || $immutable;
+ $REF->{$key} = $val;
+ }
+ last;
+ }
+ }
+ $REF->{"Immutable Keys"} = $IMMUTABLE if scalar keys %$IMMUTABLE;
+ return $REF;
+}
+
+###----------------------------------------------------------------###
+
+sub read_handler_ini {
+ my $file = shift;
+ require Config::IniHash;
+ return &Config::IniHash::ReadINI($file);
+}
+
+sub read_handler_pl {
+ my $file = shift;
+ ### do has odd behavior in that it turns a simple hashref
+ ### into hash - help it out a little bit
+ my @ref = do $file;
+ return ($#ref != 0) ? {@ref} : $ref[0];
+}
+
+sub read_handler_storable {
+ my $file = shift;
+ require Storable;
+ return &Storable::retrieve($file);
+}
+
+sub read_handler_yaml {
+ my $file = shift;
+ local *IN;
+ open (IN, $file) || die "Couldn't open $file: $!";
+ CORE::read(IN, my $text, -s $file);
+ close IN;
+ return &yaml_load($text);
+}
+
+sub yaml_load {
+ my $text = shift;
+ require YAML;
+ my @ret = eval { &YAML::Load($text) };
+ if ($@) {
+ die "$@";
+ }
+ return ($#ret == 0) ? $ret[0] : \@ret;
+}
+
+sub read_handler_xml {
+ my $file = shift;
+ require XML::Simple;
+ return XML::Simple::XMLin($file);
+}
+
+### this handler will only function if a html_key (such as validation)
+### is specified - actually this somewhat specific to validation - but
+### I left it as a general use for other types
+
+### is specified
+sub read_handler_html {
+ my $file = shift;
+ my $self = shift;
+ my $args = shift;
+ if (! eval {require YAML}) {
+ my $err = $@;
+ my $found = 0;
+ my $i = 0;
+ while (my($pkg, $file, $line, $sub) = caller($i++)) {
+ return undef if $sub =~ /\bpreload_files$/;
+ }
+ die $err;
+ }
+
+ ### get the html
+ local *IN;
+ open (IN, $file) || return undef;
+ CORE::read(IN, my $html, -s $file);
+ close IN;
+
+ return &html_parse_yaml_load($html, $self, $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;
+ return undef if ! $key || $key !~ /^\w+$/;
+
+ my $str = '';
+ my @order = ();
+ while ($html =~ m{
+ (document\. # global javascript
+ | var\s+ # local javascript
+ | <\w+\s+[^>]*?) # input, form, select, textarea tag
+ \Q$key\E # the key
+ \s*=\s* # an equals sign
+ ([\"\']) # open quote
+ (.+?[^\\]) # something in between
+ \2 # close quote
+ }xsg) {
+ my ($line, $quot, $yaml) = ($1, $2, $3);
+ if ($line =~ /^(document\.|var\s)/) { # js variable
+ $yaml =~ s/\\$quot/$quot/g;
+ $yaml =~ s/\\n\\\n?/\n/g;
+ $yaml =~ s/\\\\/\\/g;
+ $yaml =~ s/\s*$/\n/s; # fix trailing newline
+ $str = $yaml; # use last one found
+ } else { # inline attributes
+ $yaml =~ s/\s*$/\n/s; # fix trailing newline
+ if ($line =~ m/<form/i) {
+ $yaml =~ s/^\Q$1\E//m if $yaml =~ m/^( +)/s;
+ $str .= $yaml;
+
+ } elsif ($line =~ m/\bname\s*=\s*('[^\']*'|"[^\"]*"|\S+)/) {
+ my $key = $1;
+ push @order, $key;
+ $yaml =~ s/^/ /mg; # indent entire thing
+ $yaml =~ s/^(\ *[^\s&*\{\[])/\n$1/; # add first newline
+ $str .= "$key:$yaml";
+ }
+ }
+ }
+ $str .= "group order: [".join(", ",@order)."]\n"
+ if $str && $#order != -1 && $key eq 'validation';
+
+ return undef if ! $str;
+ my $ref = eval {&yaml_load($str)};
+ if ($@) {
+ my $err = "$@";
+ if ($err =~ /line:\s+(\d+)/) {
+ my $line = $1;
+ while ($str =~ m/(.+)/gm) {
+ next if -- $line;
+ $err .= "LINE = \"$1\"\n";
+ last;
+ }
+ }
+ debug $err;
+ die $err;
+ }
+ return $ref;
+}
+
+###----------------------------------------------------------------###
+
+### 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 $args = shift || {};
+ my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types
+
+ $self = $self->new() if ! ref $self;
+
+ ### allow for fast short ciruit on path lookup for several cases
+ my $directive;
+ my @paths = ();
+ if (ref($namespace) # already a ref
+ || $namespace =~ m|^\.{0,2}/.+$| # absolute or relative file
+ ) {
+ push @paths, $namespace;
+ $directive = 'FIRST';
+
+ } elsif (index($namespace,"\n") != -1) { # yaml string - can't write that
+ die "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";
+ $paths = [$paths] if ! ref $paths;
+ if ($directive eq 'LAST') { # LAST shall be FIRST
+ $directive = 'FIRST';
+ $paths = [reverse @$paths] if $#$paths != 0;
+ }
+ foreach my $path (@$paths) {
+ next if exists $CACHE{$path} && ! $CACHE{$path};
+ push @paths, "$path/$namespace";
+ }
+ }
+
+ ### 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";
+ }
+
+ my $path;
+ if ($directive eq 'FIRST') {
+ $path = $paths[0];
+ } elsif ($directive eq 'LAST' || $directive eq 'MERGE') {
+ $path = $paths[-1];
+ } else {
+ die "Unknown directive ($directive) during write of $namespace";
+ }
+
+ ### remove immutable items (if any)
+ if (UNIVERSAL::isa($conf, 'HASH') && $conf->{"Immutable Keys"}) {
+ $conf = {%$conf}; # copy the values - only for immutable
+ my $IMMUTABLE = delete $conf->{"Immutable Keys"};
+ foreach my $key (keys %$IMMUTABLE) {
+ delete $conf->{$key};
+ }
+ }
+
+ ### finally write it out
+ $self->write_ref($path, $conf);
+
+ 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);
+}
+
+sub write_handler_pl {
+ my $file = shift;
+ my $ref = shift;
+ ### do has odd behavior in that it turns a simple hashref
+ ### into hash - help it out a little bit
+ require Data::Dumper;
+ local $Data::Dump::Purity = 1;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Pad = ' ';
+ local $Data::Dumper::Varname = 'VunderVar';
+ my $str = Data::Dumper->Dumpperl([$ref]);
+ if ($str =~ s/^(.+?=\s*)//s) {
+ my $l = length($1);
+ $str =~ s/^\s{1,$l}//mg;
+ }
+ if ($str =~ /\$VunderVar/) {
+ 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_storable {
+ my $file = shift;
+ my $ref = shift;
+ require Storable;
+ return &Storable::store($ref, $file);
+}
+
+sub write_handler_yaml {
+ my $file = shift;
+ my $ref = shift;
+ require YAML;
+ &YAML::DumpFile($file, $ref);
+}
+
+sub write_handler_xml {
+ my $file = shift;
+ my $ref = shift;
+ require XML::Simple;
+ local *OUT;
+ open (OUT, ">$file") || die $!;
+ print OUT scalar(XML::Simple->new->XMLout($ref, noattr => 1));
+ close(OUT);
+}
+
+sub write_handler_html {
+ my $file = shift;
+ my $ref = shift;
+ die "Write of conf information to html is not supported";
+}
+
+###----------------------------------------------------------------###
+
+sub preload_files {
+ my $self = shift;
+ my $paths = shift || $self->paths;
+ require File::Find;
+
+ ### what extensions do we look for
+ my %EXT;
+ if ($self->{handler}) {
+ if (UNIVERSAL::isa($self->{handler},'HASH')) {
+ %EXT = %{ $self->{handler} };
+ }
+ } else {
+ %EXT = %EXT_READERS;
+ if (! $self->{html_key} && ! $HTML_KEY) {
+ delete $EXT{$_} foreach qw(html htm);
+ }
+ }
+ return if ! keys %EXT;
+
+ ### look in the paths for the files
+ foreach my $path (ref($paths) ? @$paths : $paths) {
+ $path =~ s|//+|/|g;
+ $path =~ s|/$||;
+ next if exists $CACHE{$path};
+ if (-f $path) {
+ my $ext = ($path =~ /\.(\w+)$/) ? $1 : '';
+ next if ! $EXT{$ext};
+ $CACHE{$path} = $self->read($path);
+ } elsif (-d _) {
+ $CACHE{$path} = 1;
+ &File::Find::find(sub {
+ return if exists $CACHE{$File::Find::name};
+ return if $File::Find::name =~ m|/CVS/|;
+ return if ! -f;
+ my $ext = (/\.(\w+)$/) ? $1 : '';
+ return if ! $EXT{$ext};
+ $CACHE{$File::Find::name} = $self->read($File::Find::name);
+ }, "$path/");
+ } else {
+ $CACHE{$path} = 0;
+ }
+ }
+}
+
+###----------------------------------------------------------------###
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Ex::Conf - CGI Extended Conf Reader
+
+=head1 SYNOPSIS
+
+ my $cob = CGI::Ex::Conf->new;
+
+ my $full_path_to_file = "/tmp/foo.val"; # supports ini, sto, val, pl, xml
+ my $hash = $cob->read($file);
+
+ local $cob->{default_ext} = 'conf'; # default anyway
+
+
+ my @paths = qw(/tmp, /home/pauls);
+ local $cob->{paths} = \@paths;
+ my $hash = $cob->read('My::NameSpace');
+ # will look in /tmp/My/NameSpace.conf and /home/pauls/My/NameSpace.conf
+
+ my $hash = $cob->read('My::NameSpace', {paths => ['/tmp']});
+ # will look in /tmp/My/NameSpace.conf
+
+
+ local $cob->{directive} = 'MERGE';
+ my $hash = $cob->read('FooSpace');
+ # OR #
+ my $hash = $cob->read('FooSpace', {directive => 'MERGE'});
+ # will return merged hashes from /tmp/FooSpace.conf and /home/pauls/FooSpace.conf
+ # immutable keys are preserved from originating files
+
+
+ local $cob->{directive} = 'FIRST';
+ my $hash = $cob->read('FooSpace');
+ # will return values from first found file in the path.
+
+
+ local $cob->{directive} = 'LAST'; # default behavior
+ my $hash = $cob->read('FooSpace');
+ # will return values from last found file in the path.
+
+
+ ### manipulate $hash
+ $cob->write('FooSpace'); # will write it out the changes
+
+=head1 DESCRIPTION
+
+There are half a million Conf readers out there. Why not add one more.
+Actually, this module provides a wrapper around the many file formats
+and the config modules that can handle them. It does not introduce any
+formats of its own.
+
+This module also provides a preload ability which is useful in conjunction
+with mod_perl.
+
+Oh - and it writes too.
+
+=head1 METHODS
+
+=over 4
+
+=item C<-E<gt>read_ref>
+
+Takes a file and optional argument hashref. Figures out the type
+of handler to use to read the file, reads it and returns the ref.
+If you don't need the extended merge functionality, or key fallback,
+or immutable keys, or path lookup ability - then use this method.
+Otherwise - use ->read.
+
+=item C<-E<gt>read>
+
+First argument may be either a perl data structure, yaml string, a
+full filename, or a file "namespace".
+
+The second argument can be a hashref of override values (referred to
+as $args below)..
+
+If the first argument is a perl data structure, it will be
+copied one level deep and returned (nested structures will contain the
+same references). A yaml string will be parsed and returned. A full
+filename will be read using the appropriate handler and returned (a
+file beginning with a / or ./ or ../ is considered to be a full
+filename). A file "namespace" (ie "footer" or "my::config" or
+"what/ever") will be turned into a filename by looking for that
+namespace in the paths found either in $args->{paths} or in
+$self->{paths} or in @DEFAULT_PATHS. @DEFAULT_PATHS is empty by
+default as is $self->{paths} - read makes no attempt to guess what
+directories to look in. If the namespace has no extension the
+extension listed in $args->{default_ext} or $self->{default_ext} or
+$DEFAULT_EXT will be used).
+
+ my $ref = $cob->read('My::NameSpace', {
+ paths => [qw(/tmp /usr/data)],
+ default_ext => 'pl',
+ });
+ # would look first for /tmp/My/NameSpace.pl
+ # and then /usr/data/My/NameSpace.pl
+
+ my $ref = $cob->read('foo.sto', {
+ paths => [qw(/tmp /usr/data)],
+ default_ext => 'pl',
+ });
+ # would look first for /tmp/foo.sto
+ # and then /usr/data/foo.sto
+
+When a namespace is used and there are multiple possible paths, there
+area a few options to control which file to look for. A directive of
+'FIRST', 'MERGE', or 'LAST' may be specified in $args->{directive} or
+$self->{directive} or the default value in $DIRECTIVE will be used
+(default is 'LAST'). When 'FIRST' is specified the first path that
+contains the namespace is returned. If 'LAST' is used, the last
+found path that contains the namespace is returned. If 'MERGE' is
+used, the data structures are joined together. If they are
+arrayrefs, they are joined into one large arrayref. If they are
+hashes, they are layered on top of each other with keys found in later
+paths overwriting those found in earlier paths. This allows for
+setting system defaults in a root file, and then allow users to have
+custom overrides.
+
+It is possible to make keys in a root file be immutable (non
+overwritable) by adding a suffix of _immutable or _immu to the key (ie
+{foo_immutable => 'bar'}). If a value is found in the file that
+matches $IMMUTABLE_KEY, the entire file is considered immutable.
+The immutable defaults may be overriden using $IMMUTABLE_QR and $IMMUTABLE_KEY.
+
+=item C<-E<gt>write_ref>
+
+Takes a file and the reference to be written. Figures out the type
+of handler to use to write the file and writes it. If you used the ->read_ref
+use this method. Otherwise, use ->write.
+
+=item C<-E<gt>write>
+
+Allows for writing back out the information read in by ->read. If multiple
+paths where used - the directive 'FIRST' will write the changes to the first
+file in the path - otherwise the last path will be used. If ->read had found
+immutable keys, then those keys are removed before writing.
+
+=item C<-E<gt>preload_files>
+
+Arguments are file(s) and/or directory(s) to preload. preload_files will
+loop through the arguments, find the files that exist, read them in using
+the handler which matches the files extension, and cache them by filename
+in %CACHE. Directories are spidered for file extensions which match those
+listed in %EXT_READERS. This is useful for a server environment where CPU
+may be more precious than memory.
+
+=head1 FILETYPES
+
+CGI::Ex::Conf supports the files found in %EXT_READERS by default.
+Additional types may be added to %EXT_READERS, or a custom handler may be
+passed via $args->{handler} or $self->{handler}. If the custom handler is
+a code ref, all files will be passed to it. If it is a hashref, it should
+contain keys which are extensions it supports, and values which read those
+extensions.
+
+Some file types have benefits over others. Storable is very fast, but is
+binary and not human readable. YAML is readable but very slow. I would
+suggest using a readable format such as YAML and then using preload_files
+to load in what you need at run time. All preloaded files are faster than
+any of the other types.
+
+The following is the list of handlers that ships with CGI::Ex::Conf (they
+will only work if the supporting module is installed on your system):
+
+=over 4
+
+=item C<pl>
+
+Should be a file containing a perl structure which is the last thing returned.
+
+=item C<sto> and C<storable>
+
+Should be a file containing a structure stored in Storable format.
+See L<Storable>.
+
+=item C<yaml> and C<conf> and C<val>
+
+Should be a file containing a yaml document. Multiple documents are returned
+as a single arrayref. Also - any file without an extension and custom handler
+will be read using YAML. See L<YAML>.
+
+=item C<ini>
+
+Should be a windows style ini file. See L<Config::IniHash>
+
+=item C<xml>
+
+Should be an xml file. It will be read in by XMLin. See L<XML::Simple>.
+
+=item C<html> and C<htm>
+
+This is actually a custom type intended for use with CGI::Ex::Validate.
+The configuration to be read is actually validation that is stored
+inline with the html. The handler will look for any form elements or
+input elements with an attribute with the same name as in $HTML_KEY. It
+will also look for a javascript variable by the same name as in $HTML_KEY.
+All configuration items done this way should be written in YAML.
+For example, if $HTML_KEY contained 'validation' it would find validation in:
+
+ <input type=text name=username validation="{required: 1}">
+ # automatically indented and "username:\n" prepended
+ # AND #
+ <form name=foo validation="
+ general no_confirm: 1
+ ">
+ # AND #
+ <script>
+ document.validation = "\n\
+ username: {required: 1}\n\
+ ";
+ </script>
+ # AND #
+ <script>
+ var validation = "\n\
+ username: {required: 1}\n\
+ ";
+ </script>
+
+If the key $HTML_KEY is not set, the handler will always return undef
+without even opening the file.
+
+=back
+
+=head1 TODO
+
+Make a similar write method that handles immutability.
+
+=head1 AUTHOR
+
+Paul Seamons
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package CGI::Ex::Die;
+
+use strict;
+use vars qw($no_recurse
+ $EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL
+ $ERROR_TEMPLATE
+ $LOG_HANDLER $FINAL_HANDLER
+ );
+
+use CGI::Ex;
+use CGI::Ex::Dump qw(debug ctrace dex_html);
+
+BEGIN {
+ $SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
+ $IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
+ $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
+}
+
+###----------------------------------------------------------------###
+
+sub import {
+ my $class = shift;
+ if ($#_ != -1) {
+ if (($#_ + 1) % 2) {
+ require Carp;
+ &Carp::croak("Usage: use ".__PACKAGE__." register => 1");
+ }
+ my %args = @_;
+ ### may be called as
+ # use CGI::Ex::Die register => 1;
+ # OR
+ # use CGI::Ex::Die register => [qw(die)];
+ if (! ref($args{register}) || grep {/die/} @{ $args{register} }) {
+ $SIG{__DIE__} = \&die_handler;
+ }
+ $SHOW_TRACE = $args{'show_trace'} if exists $args{'show_trace'};
+ $IGNORE_EVAL = $args{'ignore_eval'} if exists $args{'ignore_eval'};
+ $EXTENDED_ERRORS = $args{'extended_errors'} if exists $args{'extended_errors'};
+ $ERROR_TEMPLATE = $args{'error_template'} if exists $args{'error_template'};
+ $LOG_HANDLER = $args{'log_handler'} if exists $args{'log_handler'};
+ $FINAL_HANDLER = $args{'final_handler'} if exists $args{'final_handler'};
+ }
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+sub die_handler {
+ my $err = shift;
+
+ die $err if $no_recurse;
+ local $no_recurse = 1;
+
+ ### test for eval - if eval - propogate it up
+ if (! $IGNORE_EVAL) {
+ if (! $ENV{MOD_PERL}) {
+ my $n = 0;
+ while (my $sub = (caller(++$n))[3]) {
+ next if $sub !~ /eval/;
+ die $err; # die and let the eval catch it
+ }
+
+ ### test for eval in a mod_perl environment
+ } else {
+ my $n = 0;
+ my $found = 0;
+ while (my $sub = (caller(++$n))[3]) {
+ $found = $n if ! $found && $sub =~ /eval/;
+ last if $sub =~ /^(Apache|ModPerl)::(PerlRun|Registry)/;
+ }
+ if ($found && $n - 1 != $found) {
+ die $err;
+ }
+ }
+ }
+
+ ### decode the message
+ if (ref $err) {
+
+ } elsif ($EXTENDED_ERRORS && $err) {
+ my $copy = "$err";
+ if ($copy =~ m|^Execution of ([/\w\.\-]+) aborted due to compilation errors|si) {
+ eval {
+ local $SIG{__WARN__} = sub {};
+ require $1;
+ };
+ my $error = $@ || '';
+ $error =~ s|Compilation failed in require at [/\w/\.\-]+/Die.pm line \d+\.\s*$||is;
+ chomp $error;
+ $err .= "\n($error)\n";
+ } elsif ($copy =~ m|^syntax error at ([/\w.\-]+) line \d+, near|mi) {
+ }
+ }
+
+ ### prepare common args
+ my $msg = &CGI::Ex::Dump::_html_quote("$err");
+ $msg = "<pre style='background:red;color:white;border:2px solid black;font-size:120%;padding:3px'>Error: $msg</pre>\n";
+ my $ctrace = ! $SHOW_TRACE ? ""
+ : "<pre style='background:white;color:black;border:2px solid black;padding:3px'>"
+ . dex_html(ctrace)."</pre>";
+ my $args = {err => "$err", msg => $msg, ctrace => $ctrace};
+
+ &$LOG_HANDLER($args) if $LOG_HANDLER;
+
+ ### web based - give more options
+ if ($ENV{REQUEST_METHOD}) {
+ my $cgix = CGI::Ex->new;
+ $| = 1;
+ ### get the template and swap it in
+ # allow for a sub that returns the template
+ # or a string
+ # or a filename (string starting with /)
+ my $out;
+ if ($ERROR_TEMPLATE) {
+ $out = UNIVERSAL::isa($ERROR_TEMPLATE, 'CODE') ? &$ERROR_TEMPLATE($args) # coderef
+ : (substr($ERROR_TEMPLATE,0,1) ne '/') ? $ERROR_TEMPLATE # html string
+ : do { # filename
+ if (open my $fh, $ERROR_TEMPLATE) {
+ read($fh, my $str, -s $ERROR_TEMPLATE);
+ $str; # return of the do
+ } };
+ }
+ if ($out) {
+ $cgix->swap_template(\$out, $args);
+ } else {
+ $out = $msg.'<p></p>'.$ctrace;
+ }
+
+ ### similar to CGI::Carp
+ if (my $r = $cgix->apache_request) {
+ if ($r->bytes_sent) {
+ $r->print($out);
+ } else {
+ $r->status(500);
+ $r->custom_response(500, $out);
+ }
+ } else {
+ $cgix->print_content_type;
+ print $out;
+ }
+ } else {
+ ### command line execution
+ }
+
+ &$FINAL_HANDLER($args) if $FINAL_HANDLER;
+
+ die $err;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
+
+=head1 SYNOPSIS
+
+ use CGI::Ex::Die;
+ $SIG{__DIE__} = \&CGI::Ex::Die::die_handler;
+
+ # OR #
+
+ use CGI::Ex::Die register => 1;
+
+=head1 DESCRIPTION
+
+This module is intended for showing more useful messages to
+the developer, should errors occur. This is a stub phase module.
+More features (error notification, custom error page, etc) will
+be added later.
+
+=head1 AUTHORS
+
+Paul Seamons <perlspam at seamons dot com>
+
+=cut
--- /dev/null
+package CGI::Ex::Dump;
+
+### CGI Extended Data::Dumper Extension
+
+###----------------------------------------------------------------###
+# Copyright 2004 - 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 strict;
+use Exporter;
+
+@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);
+
+### is on or off
+sub on { $ON = 1 };
+sub off { $ON = 0; }
+&on();
+
+sub set_deparse {
+ $Data::Dumper::Deparse = eval {require B::Deparse};
+}
+
+###----------------------------------------------------------------###
+
+BEGIN {
+ ### setup the Data::Dumper usage
+ $Data::Dumper::Sortkeys = 1 if ! defined $Data::Dumper::Sortkeys; # not avail pre 5.8
+ $Data::Dumper::Useqq = 1 if ! defined $Data::Dumper::Useqq;
+ $Data::Dumper::Quotekeys = 0 if ! defined $Data::Dumper::Quotekeys;
+ $Data::Dumper::Pad = ' ' if ! defined $Data::Dumper::Pad;
+ #$Data::Dumper::Deparse = 1 if ! defined $Data::Dumper::Deparse; # very useful
+ $SUB = sub {
+ require Data::Dumper;
+ return Data::Dumper->Dumpperl(\@_);
+ };
+
+ ### how to display or parse the filename
+ $QR1 = qr{\A(?:/[^/]+){2,}/(?:perl|lib)/(.+)\Z};
+ $QR2 = qr{\A.+?([\w\.\-]+/[\w\.\-]+)\Z};
+}
+
+###----------------------------------------------------------------###
+
+
+### same as dumper but with more descriptive output and auto-formatting
+### for cgi output
+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__;
+ substr($called, 0, length(__PACKAGE__) + 2, '');
+
+ ### get the actual line
+ my $line = '';
+ if (open(IN,$file)) {
+ $line = <IN> for 1 .. $line_n;
+ close IN;
+ }
+
+ ### get rid of extended filename
+ if (! $full_filename) {
+ $file =~ s/$QR1/$1/ || $file =~ s/$QR2/$1/;
+ }
+
+ ### dump it out
+ my @dump = map {&$SUB($_)} @_;
+ my @var = ('$VAR') x ($#dump + 1);
+ if ($line =~ s/^ .*\b \Q$called\E ( \(?\s* | \s+ )//x
+ && $line =~ s/(?:\s+if\s+.+)? ;? \s*$//x) {
+ $line =~ s/ \s*\) $ //x if $1 && $1 =~ /\(/;
+ my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
+ @var = @_var if $#var == $#_var;
+ }
+
+ ### spit it out
+ if ($called eq 'dex_text'
+ || $called eq 'dex_warn'
+ || ! $ENV{REQUEST_METHOD}) {
+ my $txt = "$called: $file line $line_n\n";
+ for (0 .. $#dump) {
+ $dump[$_] =~ s|\$VAR1|$var[$_]|g;
+ $txt .= $dump[$_];
+ }
+ if ($called eq 'dex_text') { return $txt }
+ elsif ($called eq 'dex_warn') { warn $txt }
+ else { print $txt }
+ } else {
+ my $html = "<pre><b>$called: $file line $line_n</b>\n";
+ for (0 .. $#dump) {
+ $dump[$_] =~ s/\\n/\n/g;
+ $dump[$_] = _html_quote($dump[$_]);
+ $dump[$_] =~ s|\$VAR1|<b>$var[$_]</b>|g;
+ $html .= $dump[$_];
+ }
+ $html .= "</pre>\n";
+ return $html if $called eq 'dex_html';
+ require CGI::Ex;
+ &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 _html_quote {
+ my $value = shift;
+ return '' if ! defined $value;
+ $value =~ s/&/&/g;
+ $value =~ s/</</g;
+ $value =~ s/>/>/g;
+# $value =~ s/\"/"/g;
+ return $value;
+}
+
+### ctrace is intended for work with perl 5.8 or higher's Carp
+sub ctrace {
+ require 5.8.0;
+ require Carp::Heavy;
+ local $Carp::MaxArgNums = 3;
+ local $Carp::MaxArgLen = 20;
+ my $i = shift || 0;
+ my @i = ();
+ my $max1 = 0;
+ my $max2 = 0;
+ my $max3 = 0;
+ while (my %i = &Carp::caller_info(++$i)) {
+ $i{sub_name} =~ s/\((.*)\)$//;
+ $i{args} = $i{has_args} ? $1 : "";
+ $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
+ $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
+ $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
+ $max2 = length($i{file}) if length($i{file}) > $max2;
+ $max3 = length($i{line}) if length($i{line}) > $max3;
+ push @i, \%i;
+ }
+ foreach my $ref (@i) {
+ $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
+ . ($ref->{args} ? " ($ref->{args})" : "");
+ }
+ return \@i;
+}
+
+sub dex_trace {
+ &what_is_this(ctrace(1));
+}
+
+###----------------------------------------------------------------###
+
+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
+
+ my $hash = {
+ foo => ['a', 'b', 'Foo','a', 'b', 'Foo','a', 'b', 'Foo','a'],
+ };
+
+ dex $hash; # or dex_warn $hash;
+
+ dex;
+
+ dex "hi";
+
+ dex $hash, "hi", $hash;
+
+ dex \@INC; # print to STDOUT, or format for web if $ENV{REQUEST_METHOD}
+
+ dex_warn \@INC; # same as dex but to STDOUT
+
+ print FOO dex_text \@INC; # same as dex but return dump
+
+ # ALSO #
+
+ use CGI::Ex::Dump qw(debug);
+
+ debug; # same as dex
+
+=head1 DESCRIPTION
+
+Uses the base Data::Dumper of the distribution and gives it nicer formatting - and
+allows for calling just about anytime during execution.
+
+Calling &CGI::Ex::set_deparse() will allow for dumped output of subroutines
+if available.
+
+perl -e 'use CGI::Ex::Dump; dex "foo";'
+
+See also L<Data::Dumper>.
+
+Setting any of the Data::Dumper globals will alter the output.
+
+=head1 SUBROUTINES
+
+=over 4
+
+=item C<dex>, C<debug>
+
+Prints out pretty output to STDOUT. Formatted for the web if on the web.
+
+=item C<dex_warn>
+
+Prints to STDERR.
+
+=item C<dex_text>
+
+Return the text as a scalar.
+
+=item C<ctrace>
+
+Caller trace returned as an arrayref. Suitable for use like "debug ctrace".
+This does require at least perl 5.8.0's Carp.
+
+=item C<on>, C<off>
+
+Turns calls to routines on or off. Default is to be on.
+
+=back
+
+=head1 AUTHORS
+
+Paul Seamons <perlspam at seamons dot com>
+
+=cut
--- /dev/null
+package CGI::Ex::Fill;
+
+### CGI Extended Form Filler
+
+###----------------------------------------------------------------###
+# Copyright 2003 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
+### See perldoc at bottom
+
+use strict;
+use vars qw($VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $REMOVE_SCRIPT
+ $REMOVE_COMMENT
+ $MARKER_SCRIPT
+ $MARKER_COMMENT
+ $OBJECT_METHOD
+ $TEMP_TARGET
+ );
+use 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);
+
+### 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";
+
+###----------------------------------------------------------------###
+
+### Regex based filler - as opposed to HTML::Parser based HTML::FillInForm
+### arguments are positional
+### pos1 - text or textref - if textref it is modified in place
+### pos2 - hash or cgi obj ref, or array ref of hash and cgi obj refs
+### pos3 - target - to be used for choosing a specific form - default undef
+### 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;
+
+ ### 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;
+ }
+
+ 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);
+ }
+ 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}] || '';
+ $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
+ }{
+ ### 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;
+ }
+ }
+ }
+ }
+ }
+ }
+ $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
+ }{
+ 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");
+ }
+ }
+ }
+
+
+ ### 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,());
+ }
+ 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 $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;
+}
+
+
+### 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;
+
+ $$ref =~ s/&/&/g;
+ $$ref =~ s/</</g;
+ $$ref =~ s/>/>/g;
+ $$ref =~ s/\"/"/g;
+
+ 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');
+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;
+}
+
+### 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;
+}
+
+1;
+
+__END__
+
+###----------------------------------------------------------------###
+
+=head1 NAME
+
+CGI::Ex::Fill - Yet another form filler
+
+=head1 SYNOPSIS
+
+ use CGI::Ex::Fill qw(form_fill);
+
+ 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
+
+
+ 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};
+
+ form_fill(\$text, $form, $formname, $fp, $ignore);
+
+ 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).
+
+=head1 HTML COMMENT / JAVASCRIPT
+
+Because there are too many problems that could occur with html
+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
+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).
+
+=head1 AUTHOR
+
+Paul Seamons
+
+=head1 LICENSE
+
+This module may distributed under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package CGI::Ex::Template;
+
+use strict;
+use vars qw(@INCLUDE_PATH $CONTENT_SUBDIR);
+use base qw(Template);
+
+use CGI::Ex;
+use CGI::Ex::Fill;
+
+$CONTENT_SUBDIR ||= 'content';
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift;
+ my $args = ref($_[0]) ? shift : {@_};
+
+ $args->{INCLUDE_PATH} ||= \@INCLUDE_PATH;
+
+ return $class->SUPER::new($args);
+}
+
+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+$/;
+ }
+
+ ### 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;
+ }
+
+ return $self->SUPER::process($in, @_);
+}
+
+###----------------------------------------------------------------###
+
+sub out {
+ my $self = ref($_[0]) ? shift : shift->new;
+# dex $self;
+ my $in = shift;
+ my $form = shift;
+ my $fill = shift;
+ my $out = '';
+
+ ### 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};
+
+ return $out;
+}
+
+sub print {
+ my $self = ref($_[0]) ? shift : shift->new;
+ my $in = shift;
+ my $form = shift;
+ my $fill = shift || $form;
+
+ &CGI::Ex::content_type();
+ print $self->out($in, $form, $fill);
+}
+
+###----------------------------------------------------------------###
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Ex::Template - Beginning interface to Templating systems - for they are many
+
+=head1 SYNOPSIS
+
+ None yet.
+
+=head1 DESCRIPTION
+
+=head1 AUTHORS
+
+Paul Seamons <perlspam at seamons dot com>
+
+=cut
+
--- /dev/null
+package CGI::Ex::Validate;
+
+### CGI Extended Validator
+
+###----------------------------------------------------------------###
+# Copyright 2004 - 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
+ $JS_URI_PATH_YAML
+ $JS_URI_PATH_VALIDATE
+ $QR_EXTRA
+ @UNSUPPORTED_BROWSERS
+ );
+
+$VERSION = '1.14';
+
+$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);
+
+use CGI::Ex::Conf ();
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $self = (@_ && ref($_[0])) ? shift : {@_};
+
+ ### allow for global defaults
+ foreach (keys %DEFAULT_OPTIONS) {
+ $self->{$_} = $DEFAULT_OPTIONS{$_} if ! exists $self->{$_};
+ }
+
+ return bless $self, $class;
+}
+
+###----------------------------------------------------------------###
+
+sub cgix {
+ my $self = shift;
+ return $self->{cgix} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new;
+ };
+}
+
+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
+ : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate
+ : __PACKAGE__->new; # &validate
+ my $form = shift || die "Missing form hash";
+ my $val_hash = shift || die "Missing validation hash";
+ my $what_was_validated = shift; # allow for extra arrayref that stores what was validated
+
+ ### turn the form into a form if it is really a CGI object
+ if (! ref($form)) {
+ die "Invalid form hash or cgi object";
+ } elsif(! UNIVERSAL::isa($form,'HASH')) {
+ local $self->{cgi_object} = $form;
+ $form = $self->cgix->get_form($form);
+ }
+
+ ### get the validation - let get_validation deal with types
+ ### if a ref is not passed - assume it is a filename
+ $val_hash = $self->get_validation($val_hash);
+
+ ### allow for validation passed as single group hash, single group array,
+ ### or array of group hashes or group arrays
+ my @ERRORS = ();
+ my %EXTRA = ();
+ my @USED_GROUPS = ();
+ 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'};
+ my $validate_if = $group_val->{'group validate_if'};
+
+ ### only validate this group if it is supposed to be checked
+ next if $validate_if && ! $self->check_conditional($form, $validate_if);
+ push @USED_GROUPS, $group_val;
+
+ ### If the validation items were not passed as an arrayref.
+ ### 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 $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) {
+ 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
+ }
+ push @fields, $field_val;
+ }
+ }
+ $fields = \@fields;
+ }
+
+ ### 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 $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;
+ }
+
+ ### Finally we have our arrayref of hashrefs that each have their 'field' key
+ ### now lets do the validation
+ my $found = 1;
+ my @errors = ();
+ my $hold_error; # hold the error for a moment - to allow for an "Or" operation
+ foreach (my $i = 0; $i <= $#$fields; $i ++) {
+ my $ref = $fields->[$i];
+ if (! ref($ref) && $ref eq 'OR') {
+ $i ++ if $found; # if found skip the OR altogether
+ $found = 1; # reset
+ next;
+ }
+ $found = 1;
+ die "Missing field key during normal validation" if ! $ref->{'field'};
+ local $ref->{'was_validated'} = 1;
+ my @err = $self->validate_buddy($form, $ref->{'field'}, $ref);
+ if (delete($ref->{'was_validated'}) && $what_was_validated) {
+ push @$what_was_validated, $ref;
+ }
+
+ ### test the error - if errors occur allow for OR - if OR fails use errors from first fail
+ if (scalar @err) {
+ if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
+ $hold_error = \@err;
+ } else {
+ push @errors, $hold_error ? @$hold_error : @err;
+ $hold_error = undef;
+ }
+ } else {
+ $hold_error = undef;
+ }
+ }
+ push(@errors, @$hold_error) if $hold_error; # allow for final OR to work
+
+ ### add on errors as requested
+ if ($#errors != -1) {
+ push @ERRORS, $title if $title;
+ push @ERRORS, @errors;
+ }
+
+ ### 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};
+ }
+ }
+
+ ### store any extra items from self
+ foreach my $key (keys %$self) {
+ next if $key !~ $QR_EXTRA;
+ $EXTRA{$key} = $self->{$key};
+ }
+
+ ### allow for checking for unused keys
+ if ($EXTRA{no_extra_fields}) {
+ my $which = ($EXTRA{no_extra_fields} =~ /used/i) ? 'used' : 'all';
+ my $ref = ($which eq 'all') ? $val_hash : \@USED_GROUPS;
+ 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);
+ }
+ }
+
+ ### return what they want
+ if ($#ERRORS != -1) {
+ my $err_obj = $ERROR_PACKAGE->new(\@ERRORS, \%EXTRA);
+ die $err_obj if $EXTRA{raise_error};
+ return $err_obj;
+ } else {
+ return wantarray ? () : undef;
+ }
+}
+
+
+### allow for optional validation on groups and on individual items
+sub check_conditional {
+ my ($self, $form, $ifs, $N_level, $ifs_match) = @_;
+
+ $N_level ||= 0;
+ $N_level ++; # prevent too many recursive checks
+
+ ### can pass a single hash - or an array ref of hashes
+ if (! $ifs) {
+ die "Need reference passed to check_conditional";
+ } elsif (! ref($ifs)) {
+ $ifs = [$ifs];
+ } elsif (UNIVERSAL::isa($ifs,'HASH')) {
+ $ifs = [$ifs];
+ }
+
+ ### run the if options here
+ ### multiple items can be passed - all are required unless OR is used to separate
+ my $found = 1;
+ foreach (my $i = 0; $i <= $#$ifs; $i ++) {
+ my $ref = $ifs->[$i];
+ if (! ref $ref) {
+ if ($ref eq 'OR') {
+ $i ++ if $found; # if found skip the OR altogether
+ $found = 1; # reset
+ next;
+ } else {
+ if ($ref =~ s/^\s*!\s*//) {
+ $ref = {field => $ref, max_in_set => "0 of $ref"};
+ } else {
+ $ref = {field => $ref, required => 1};
+ }
+ }
+ }
+ last if ! $found;
+
+ ### get the field - allow for custom variables based upon a match
+ my $field = $ref->{'field'} || die "Missing field key during validate_if (possibly used a reference to a main hash *foo -> &foo)";
+ $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+
+ my @err = $self->validate_buddy($form, $field, $ref, $N_level);
+ $found = 0 if scalar @err;
+ }
+ return $found;
+}
+
+
+### this is where the main checking goes on
+sub validate_buddy {
+ my $self = shift;
+ my ($form, $field, $field_val, $N_level, $ifs_match) = @_;
+ $N_level ||= 0;
+ $N_level ++; # prevent too many recursive checks
+ die "Max dependency level reached $N_level" if $N_level > 10;
+
+ my @errors = ();
+ my $types = [sort keys %$field_val];
+
+ ### allow for not running some tests in the cgi
+ if (scalar $self->filter_type('exclude_cgi',$types)) {
+ delete $field_val->{'was_validated'};
+ return wantarray ? @errors : $#errors + 1;
+ }
+
+ ### allow for field names that contain regular expressions
+ if ($field =~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
+ my ($not,$pat,$opt) = ($1,$3,$4);
+ $opt =~ tr/g//d;
+ die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/;
+ foreach my $_field (sort keys %$form) {
+ next if ($not && $_field =~ m/(?$opt:$pat)/) || (! $not && $_field !~ m/(?$opt:$pat)/);
+ my @match = (undef,$1,$2,$3,$4,$5); # limit to the matches
+ push @errors, $self->validate_buddy($form, $_field, $field_val, $N_level, \@match);
+ }
+ return wantarray ? @errors : $#errors + 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};
+ }
+ }
+
+ 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
+ $value =~ s/^\s+//;
+ $value =~ s/\s+$//;
+ $modified = 1;
+ }
+ if (scalar $self->filter_type('to_upper_case',$types)) { # uppercase
+ $value = uc($value);
+ $modified = 1;
+ } elsif (scalar $self->filter_type('to_lower_case',$types)) { # lowercase
+ $value = lc($value);
+ $modified = 1;
+ }
+ }
+ # allow for inline specified modifications (ie s/foo/bar/)
+ foreach my $type ($self->filter_type('replace',$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)";
+ }
+ my ($pat,$swap,$opt) = ($2,$3,$4);
+ die "The e option cannot be used in swap on field $field" if $opt =~ /e/;
+ my $global = $opt =~ s/g//g;
+ $swap =~ s/\\n/\n/g;
+ if ($global) {
+ foreach my $value (@$values) {
+ $value =~ s{(?$opt:$pat)}{
+ my @match = (undef,$1,$2,$3,$4,$5,$6); # limit on the number of matches
+ my $copy = $swap;
+ $copy =~ s/\$(\d+)/defined($match[$1]) ? $match[$1] : ""/ge;
+ $modified = 1;
+ $copy; # return of the swap
+ }eg;
+ }
+ }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 $copy = $swap;
+ $copy =~ s/\$(\d+)/defined($match[$1]) ? $match[$1] : ""/ge;
+ $modified = 1;
+ $copy; # return of the swap
+ }e;
+ }
+ }
+ }
+ }
+ ### put them back into the form if we have modified it
+ if ($modified) {
+ if ($n_values == 1) {
+ $form->{$field} = $values->[0];
+ $self->{cgi_object}->param(-name => $field, -value => $values->[0])
+ if $self->{cgi_object};
+ } else {
+ ### values in @{ $form->{$field} } were modified directly
+ $self->{cgi_object}->param(-name => $field, -value => $values)
+ if $self->{cgi_object};
+ }
+ }
+
+ ### only continue if a validate_if is not present or passes test
+ my $needs_val = 0;
+ my $n_vif = 0;
+ foreach my $type ($self->filter_type('validate_if',$types)) {
+ $n_vif ++;
+ my $ifs = $field_val->{$type};
+ my $ret = $self->check_conditional($form, $ifs, $N_level, $ifs_match);
+ $needs_val ++ if $ret;
+ }
+ if (! $needs_val && $n_vif) {
+ delete $field_val->{'was_validated'};
+ return wantarray ? @errors : $#errors + 1;
+ }
+
+ ### 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;
+ }
+ if (! $is_required) {
+ foreach my $type ($self->filter_type('required_if',$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})))) {
+ return 1 if ! wantarray;
+ $self->add_error(\@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;
+ }
+ }
+
+ ### 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;
+ }
+ }
+
+ ### 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) {
+ $field_val->{$type} =~ m/^\s*(\d+)(?i:\s*of)?\s+(.+)\s*$/
+ || die "Invalid in_set check $field_val->{$type}";
+ my $n = $1;
+ foreach my $_field (split /[\s,]+/, $2) {
+ my $ref = UNIVERSAL::isa($form->{$_field},'ARRAY') ? $form->{$_field} : [$form->{$_field}];
+ foreach my $_value (@$ref) {
+ $n -- if defined($_value) && length($_value);
+ }
+ }
+ 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);
+ return @errors;
+ }
+ }
+ }
+
+ ### at this point @errors should still be empty
+ my $content_checked; # allow later for possible untainting (only happens if content was checked)
+
+ ### loop on values of field
+ foreach my $value (@$values) {
+
+ ### allow for enum types
+ foreach my $type ($self->filter_type('enum',$types)) {
+ my $ref = ref($field_val->{$type}) ? $field_val->{$type} : [split(/\s*\|\|\s*/,$field_val->{$type})];
+ 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);
+ }
+ $content_checked = 1;
+ }
+
+ ### field equality test
+ foreach my $type ($self->filter_type('equals',$types)) {
+ my $field2 = $field_val->{$type};
+ my $not = ($field2 =~ s/^!\s*//) ? 1 : 0;
+ my $success = 0;
+ if ($field2 =~ m/^([\"\'])(.*)\1$/) {
+ my $test = $2;
+ $success = (defined($value) && $value eq $test);
+ } elsif (exists($form->{$field2}) && defined($form->{$field2})) {
+ $success = (defined($value) && $value eq $form->{$field2});
+ } elsif (! defined($value)) {
+ $success = 1; # occurs if they are both undefined
+ }
+ if ($not ? $success : ! $success) {
+ return 1 if ! wantarray;
+ $self->add_error(\@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 (! defined($value) || length($value) < $n) {
+ return 1 if ! wantarray;
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ }
+ }
+
+ ### length max check
+ foreach my $type ($self->filter_type('max_len',$types)) {
+ my $n = $field_val->{$type};
+ if (defined($value) && length($value) > $n) {
+ return 1 if ! wantarray;
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ }
+ }
+
+ ### now do match types
+ foreach my $type ($self->filter_type('match',$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);
+ }
+ } else {
+ if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
+ die "Not sure how to parse that match ($rx)";
+ }
+ my ($not,$pat,$opt) = ($1,$3,$4);
+ $opt =~ tr/g//d;
+ die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/;
+ if ( ( $not && ( defined($value) && $value =~ m/(?$opt:$pat)/))
+ || (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/))
+ ) {
+ return 1 if ! wantarray;
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ }
+ }
+ }
+ $content_checked = 1;
+ }
+
+ ### allow for comparison checks
+ foreach my $type ($self->filter_type('compare',$types)) {
+ my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
+ : [split(/\s*\|\|\s*/,$field_val->{$type})];
+ foreach my $comp (@$ref) {
+ next if ! $comp;
+ my $test = 0;
+ if ($comp =~ /^\s*(>|<|[><!=]=)\s*([\d\.\-]+)\s*$/) {
+ my $val = $value || 0;
+ $val *= 1;
+ if ($1 eq '>' ) { $test = ($val > $2) }
+ elsif ($1 eq '<' ) { $test = ($val < $2) }
+ elsif ($1 eq '>=') { $test = ($val >= $2) }
+ elsif ($1 eq '<=') { $test = ($val <= $2) }
+ elsif ($1 eq '!=') { $test = ($val != $2) }
+ elsif ($1 eq '==') { $test = ($val == $2) }
+
+ } elsif ($comp =~ /^\s*(eq|ne|gt|ge|lt|le)\s+(.+?)\s*$/) {
+ my $val = defined($value) ? $value : '';
+ my ($op, $value2) = ($1, $2);
+ $value2 =~ s/^([\"\'])(.*)\1$/$2/;
+ if ($op eq 'gt') { $test = ($val gt $value2) }
+ elsif ($op eq 'lt') { $test = ($val lt $value2) }
+ elsif ($op eq 'ge') { $test = ($val ge $value2) }
+ elsif ($op eq 'le') { $test = ($val le $value2) }
+ elsif ($op eq 'ne') { $test = ($val ne $value2) }
+ elsif ($op eq 'eq') { $test = ($val eq $value2) }
+
+ } else {
+ die "Not sure how to compare \"$comp\"";
+ }
+ if (! $test) {
+ return 1 if ! wantarray;
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ }
+ }
+ $content_checked = 1;
+ }
+
+ ### server side sql type
+ foreach my $type ($self->filter_type('sql',$types)) {
+ my $db_type = $field_val->{"${type}_db_type"};
+ my $dbh = ($db_type) ? $self->{dbhs}->{$db_type} : $self->{dbh};
+ if (! $dbh) {
+ die "Missing dbh for $type type on field $field" . ($db_type ? " and db_type $db_type" : "");
+ } elsif (UNIVERSAL::isa($dbh,'CODE')) {
+ $dbh = &$dbh($field, $self) || die "SQL Coderef did not return a dbh";
+ }
+ my $sql = $field_val->{$type};
+ my @args = ($value) x $sql =~ tr/?//;
+ my $return = $dbh->selectrow_array($sql, {}, @args); # is this right - copied from O::FORMS
+ $field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"};
+ if ( (! $return && $field_val->{"${type}_error_if"})
+ || ($return && ! $field_val->{"${type}_error_if"}) ) {
+ return 1 if ! wantarray;
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ }
+ $content_checked = 1;
+ }
+
+ ### server side custom type
+ foreach my $type ($self->filter_type('custom',$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);
+ $content_checked = 1;
+ }
+
+ ### do specific type checks
+ foreach my $type ($self->filter_type('type',$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);
+ }
+ $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 (! $content_checked) {
+ $self->add_error(\@errors, $field, $type, $field_val, $ifs_match);
+ } else {
+ ### generic untainter - assuming the other required content_checks did good validation
+ $_ = /(.*)/ ? $1 : die "Couldn't match?" foreach @$values;
+ if ($n_values == 1) {
+ $form->{$field} = $values->[0];
+ $self->{cgi_object}->param(-name => $field, -value => $values->[0])
+ if $self->{cgi_object};
+ } else {
+ ### values in @{ $form->{$field} } were modified directly
+ $self->{cgi_object}->param(-name => $field, -value => $values)
+ if $self->{cgi_object};
+ }
+ }
+ }
+
+ ### all done - time to return
+ 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
+sub check_type {
+ my $self = shift;
+ my $value = shift;
+ my $type = uc(shift);
+
+ ### do valid email address for our system
+ if ($type eq 'EMAIL') {
+ return 0 if ! $value;
+ my($local_p,$dom) = ($value =~ /^(.+)\@(.+?)$/) ? ($1,$2) : return 0;
+
+ return 0 if length($local_p) > 60;
+ return 0 if length($dom) > 100;
+ return 0 if ! $self->check_type($dom,'DOMAIN') && ! $self->check_type($dom,'IP');
+ return 0 if ! $self->check_type($local_p,'LOCAL_PART');
+
+ ### the "username" portion of an email address
+ } elsif ($type eq 'LOCAL_PART') {
+ return 0 if ! defined($value) || ! length($value);
+ return 0 if $value =~ m/[^a-z0-9.\-\!\&]/;
+ return 0 if $value =~ m/^[\.\-]/;
+ return 0 if $value =~ m/[\.\-\&]$/;
+ return 0 if $value =~ m/(\.\-|\-\.|\.\.)/;
+
+ ### standard IP address
+ } elsif ($type eq 'IP') {
+ return 0 if ! $value;
+ return (4 == grep {!/\D/ && $_ < 256} split /\./, $value, 4);
+
+ ### domain name - including tld and subdomains (which are all domains)
+ } elsif ($type eq 'DOMAIN') {
+ return 0 if ! $value;
+ return 0 if $value =~ m/[^a-z0-9.\-]/;
+ return 0 if $value =~ m/^[\.\-]/;
+ return 0 if $value =~ m/(\.\-|\-\.|\.\.)/;
+ return 0 if length($value) > 255;
+ return 0 if $value !~ s/\.([a-z]+)$//;
+
+ my $ext = $1;
+ if ($ext eq 'name') { # .name domains
+ return 0 if $value !~ /^[a-z0-9][a-z0-9\-]{0,62} \. [a-z0-9][a-z0-9\-]{0,62}$/x;
+ } else { # any other domains
+ return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)* [a-z0-9][a-z0-9\-]{0,62}$/x;
+ }
+
+ ### validate a url
+ } elsif ($type eq 'URL') {
+ return 0 if ! $value;
+ $value =~ s|^https?://([^/]+)||i || return 0;
+ my $dom = $1;
+ return 0 if ! $self->check_type($dom,'DOMAIN') && ! $self->check_type($dom,'IP');
+ return 0 if $value && ! $self->check_type($value,'URI');
+
+ ### validate a uri - the path portion of a request
+ } elsif ($type eq 'URI') {
+ return 0 if ! $value;
+ return 0 if $value =~ m/\s+/;
+
+ } elsif ($type eq 'CC') {
+ return 0 if ! $value;
+ ### validate the number
+ return 0 if $value =~ /[^\d\-\ ]/
+ || length($value) > 16
+ || length($value) < 13;
+
+ ### simple mod10 check
+ $value =~ s/\D//g;
+ my $sum = 0;
+ my $switch = 0;
+ foreach my $digit ( reverse split //, $value ){
+ $switch = 1 if ++ $switch > 2;
+ my $y = $digit * $switch;
+ $y -= 9 if $y > 9;
+ $sum += $y;
+ }
+ return 0 if $sum % 10;
+
+ }
+
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+sub get_validation {
+ my $self = shift;
+ my $val = shift;
+ return $self->conf->read($val, {html_key => 'validation'});
+}
+
+### returns all keys from all groups - even if group has validate_if
+sub get_validation_keys {
+ my $self = shift;
+ my $val_hash = shift;
+ my $form = shift; # with optional form - will only return keys in validated groups
+ my %keys = ();
+
+ ### if a form was passed - make sure it is a hashref
+ if ($form) {
+ if (! ref($form)) {
+ die "Invalid form hash or cgi object";
+ } elsif(! UNIVERSAL::isa($form,'HASH')) {
+ require CGI::Ex;
+ $form = CGI::Ex->new->get_form($form);
+ }
+ }
+
+ my $refs = $self->get_validation($val_hash);
+ $refs = [$refs] if ! UNIVERSAL::isa($refs,'ARRAY');
+ foreach my $group_val (@$refs) {
+ die "Group found that was not a hashref" if ! UNIVERSAL::isa($group_val, 'HASH');
+
+ ### if form is passed, check to see if the group passed validation
+ if ($form) {
+ my $validate_if = $group_val->{'group validate_if'};
+ next if $validate_if && ! $self->check_conditional($form, $validate_if);
+ }
+
+ if ($group_val->{"group fields"}) {
+ die "Group fields must be an arrayref" if ! UNIVERSAL::isa($group_val->{"group fields"}, 'ARRAY');
+ foreach my $field_val (@{ $group_val->{"group fields"} }) {
+ next if ! ref($field_val) && $field_val eq 'OR';
+ die "Field_val must be a hashref" if ! UNIVERSAL::isa($field_val, 'HASH');
+ my $key = $field_val->{'field'} || die "Missing field key in field_val hashref";
+ $keys{$key} = $field_val->{'name'} || 1;
+ }
+ } elsif ($group_val->{"group order"}) {
+ die "Group order must be an arrayref" if ! UNIVERSAL::isa($group_val->{"group order"}, 'ARRAY');
+ foreach my $key (@{ $group_val->{"group order"} }) {
+ my $field_val = $group_val->{$key};
+ next if ! $field_val && $key eq 'OR';
+ die "Field_val for $key must be a hashref" if ! UNIVERSAL::isa($field_val, 'HASH');
+ $key = $field_val->{'field'} if $field_val->{'field'};
+ $keys{$key} = $field_val->{'name'} || 1;
+ }
+ }
+
+ ### get all others
+ foreach my $key (keys %$group_val) {
+ next if $key =~ /^(general|group)\s/;
+ my $field_val = $group_val->{$key};
+ next if ! UNIVERSAL::isa($field_val, 'HASH');
+ $keys{$key} = $field_val->{'name'} || 1;
+ }
+ }
+
+ return \%keys;
+}
+
+###----------------------------------------------------------------###
+
+### 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;
+
+ ### store any extra items from self
+ my %EXTRA = ();
+ foreach my $key (keys %$self) {
+ next if $key !~ $QR_EXTRA;
+ $EXTRA{"general $key"} = $self->{$key};
+ }
+
+ 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
+
+ ### 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";
+ };
+
+ ### return the string
+ return qq{<script src="$js_uri_path_yaml"></script>
+<script src="$js_uri_path_validate"></script>
+<script><!--
+document.validation = "$str";
+if (document.check_form) document.check_form("$form_name");
+//--></script>
+};
+
+}
+
+###----------------------------------------------------------------###
+### How to handle errors
+
+package CGI::Ex::Validate::Error;
+
+use strict;
+use overload '""' => \&as_string;
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $errors = shift;
+ my $extra = shift || {};
+ die "Missing or invalid arrayref" if ! UNIVERSAL::isa($errors, 'ARRAY');
+ die "Missing or invalid hashref" if ! UNIVERSAL::isa($extra, 'HASH');
+ return bless {errors => $errors, extra => $extra}, $class;
+}
+
+sub as_string {
+ my $self = shift;
+ my $extra = $self->{extra} || {};
+ my $extra2 = shift || {};
+
+ ### allow for formatting
+ my $join = defined($extra2->{as_string_join}) ? $extra2->{as_string_join}
+ : defined($extra->{as_string_join}) ? $extra->{as_string_join}
+ : "\n";
+ my $header = defined($extra2->{as_string_header}) ? $extra2->{as_string_header}
+ : defined($extra->{as_string_header}) ? $extra->{as_string_header} : "";
+ my $footer = defined($extra2->{as_string_footer}) ? $extra2->{as_string_footer}
+ : defined($extra->{as_string_footer}) ? $extra->{as_string_footer} : "";
+
+ return $header . join($join, @{ $self->as_array($extra2) }) . $footer;
+}
+
+### return an array of applicable errors
+sub as_array {
+ my $self = shift;
+ my $errors = $self->{errors} || die "Missing errors";
+ my $extra = $self->{extra} || {};
+ my $extra2 = shift || {};
+
+ my $title = defined($extra2->{as_array_title}) ? $extra2->{as_array_title}
+ : defined($extra->{as_array_title}) ? $extra->{as_array_title}
+ : "Please correct the following items:";
+
+ ### if there are heading items then we may end up needing a prefix
+ my $has_headings;
+ if ($title) {
+ $has_headings = 1;
+ } else {
+ foreach (@$errors) {
+ next if ref;
+ $has_headings = 1;
+ last;
+ }
+ }
+
+ my $prefix = defined($extra2->{as_array_prefix}) ? $extra2->{as_array_prefix}
+ : defined($extra->{as_array_prefix}) ? $extra->{as_array_prefix}
+ : $has_headings ? ' ' : '';
+
+ ### get the array ready
+ my @array = ();
+ push @array, $title if length $title;
+
+ ### add the errors
+ my %found = ();
+ foreach my $err (@$errors) {
+ if (! ref $err) {
+ push @array, $err;
+ %found = ();
+ } else {
+ my $text = $self->get_error_text($err);
+ next if $found{$text};
+ $found{$text} = 1;
+ push @array, "$prefix$text";
+ }
+ }
+
+ return \@array;
+}
+
+### return a hash of applicable errors
+sub as_hash {
+ my $self = shift;
+ my $errors = $self->{errors} || die "Missing errors";
+ my $extra = $self->{extra} || {};
+ my $extra2 = shift || {};
+
+ my $suffix = defined($extra2->{as_hash_suffix}) ? $extra2->{as_hash_suffix}
+ : defined($extra->{as_hash_suffix}) ? $extra->{as_hash_suffix} : '_error';
+ my $join = defined($extra2->{as_hash_join}) ? $extra2->{as_hash_join}
+ : defined($extra->{as_hash_join}) ? $extra->{as_hash_join} : '<br />';
+
+ ### now add to the hash
+ my %found = ();
+ my %return = ();
+ foreach my $err (@$errors) {
+ next if ! ref $err;
+
+ my ($field, $type, $field_val, $ifs_match) = @$err;
+ die "Missing field name" if ! $field;
+ if ($field_val->{delegate_error}) {
+ $field = $field_val->{delegate_error};
+ $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+ }
+
+ my $text = $self->get_error_text($err);
+ next if $found{$field}->{$text};
+ $found{$field}->{$text} = 1;
+
+ $field .= $suffix;
+ $return{$field} ||= [];
+ $return{$field} = [$return{$field}] if ! ref($return{$field});
+ push @{ $return{$field} }, $text;
+ }
+
+ ### allow for elements returned as
+ if ($join) {
+ my $header = defined($extra2->{as_hash_header}) ? $extra2->{as_hash_header}
+ : defined($extra->{as_hash_header}) ? $extra->{as_hash_header} : "";
+ my $footer = defined($extra2->{as_hash_footer}) ? $extra2->{as_hash_footer}
+ : defined($extra->{as_hash_footer}) ? $extra->{as_hash_footer} : "";
+ foreach my $key (keys %return) {
+ $return{$key} = $header . join($join,@{ $return{$key} }) . $footer;
+ }
+ }
+
+ return \%return;
+}
+
+### return a user friendly error message
+sub get_error_text {
+ my $self = shift;
+ my $err = shift;
+ my $extra = $self->{extra} || {};
+ my ($field, $type, $field_val, $ifs_match) = @$err;
+ my $dig = ($type =~ s/(_?\d+)$//) ? $1 : '';
+ my $type_lc = lc($type);
+
+ ### allow for delegated field names - only used for defaults
+ if ($field_val->{delegate_error}) {
+ $field = $field_val->{delegate_error};
+ $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+ }
+
+ ### the the name of this thing
+ my $name = $field_val->{'name'} || "The field $field";
+ $name =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+
+ ### type can look like "required" or "required2" or "required100023"
+ ### allow for fallback from required100023_error through required_error
+ my @possible_error_keys = ("${type}_error");
+ unshift @possible_error_keys, "${type}${dig}_error" if length($dig);
+
+ ### look in the passed hash or self first
+ my $return;
+ foreach my $key (@possible_error_keys){
+ $return = $field_val->{$key} || $extra->{$key} || next;
+ $return =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+ $return =~ s/\$field/$field/g;
+ $return =~ s/\$name/$name/g;
+ if (my $value = $field_val->{"$type$dig"}) {
+ $return =~ s/\$value/$value/g if ! ref $value;
+ }
+ last;
+ }
+
+ ### set default messages
+ if (! $return) {
+ if ($type eq 'required' || $type eq 'required_if') {
+ $return = "$name is required.";
+
+ } elsif ($type eq 'min_values') {
+ my $n = $field_val->{"min_values${dig}"};
+ my $values = ($n == 1) ? 'value' : 'values';
+ $return = "$name had less than $n $values.";
+
+ } elsif ($type eq 'max_values') {
+ my $n = $field_val->{"max_values${dig}"};
+ my $values = ($n == 1) ? 'value' : 'values';
+ $return = "$name had more than $n $values.";
+
+ } elsif ($type eq 'enum') {
+ $return = "$name is not in the given list.";
+
+ } elsif ($type eq 'equals') {
+ my $field2 = $field_val->{"equals${dig}"};
+ my $name2 = $field_val->{"equals${dig}_name"} || "the field $field2";
+ $name2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
+ $return = "$name did not equal $name2.";
+
+ } elsif ($type eq 'min_len') {
+ my $n = $field_val->{"min_len${dig}"};
+ my $char = ($n == 1) ? 'character' : 'characters';
+ $return = "$name was less than $n $char.";
+
+ } elsif ($type eq 'max_len') {
+ my $n = $field_val->{"max_len${dig}"};
+ my $char = ($n == 1) ? 'character' : 'characters';
+ $return = "$name was more than $n $char.";
+
+ } elsif ($type eq 'max_in_set') {
+ my $set = $field_val->{"max_in_set${dig}"};
+ $return = "Too many fields were chosen from the set ($set)";
+
+ } elsif ($type eq 'min_in_set') {
+ my $set = $field_val->{"min_in_set${dig}"};
+ $return = "Not enough fields were chosen from the set ($set)";
+
+ } elsif ($type eq 'match') {
+ $return = "$name contains invalid characters.";
+
+ } elsif ($type eq 'compare') {
+ $return = "$name did not fit comparison.";
+
+ } elsif ($type eq 'sql') {
+ $return = "$name did not match sql test.";
+
+ } elsif ($type eq 'custom') {
+ $return = "$name did not match custom test.";
+
+ } elsif ($type eq 'type') {
+ my $_type = $field_val->{"type${dig}"};
+ $return = "$name did not match type $_type.";
+
+ } elsif ($type eq 'untaint') {
+ $return = "$name cannot be untainted without one of the following checks: enum, equals, match, compare, sql, type, custom";
+
+ } elsif ($type eq 'no_extra_fields') {
+ $return = "$name should not be passed to validate.";
+ }
+ }
+
+ die "Missing error on field $field for type $type$dig" if ! $return;
+ return $return;
+
+}
+
+###----------------------------------------------------------------###
+
+1;
+
+
+__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);
+ # OR #
+ 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
+ # OR #
+ 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
+ }
+
+ ### 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.
+
+=head1 METHODS
+
+=over 4
+
+=item C<new>
+
+Used to instantiate the object. Arguments are either a hash, or hashref,
+or nothing at all. Keys of the hash become the keys of the object.
+
+=item C<get_validation>
+
+Given a filename or YAML string will return perl hash. If more than one
+group is contained in the file, it will return an arrayref of hashrefs.
+
+ my $ref = $self->get_validation($file);
+
+=item C<get_validation_keys>
+
+Given a filename or YAML string or a validation hashref, will return all
+of the possible keys found in the validation hash. This can be used to
+check to see if extra items have been passed to validate. If a second
+argument contains a form hash is passed, get_validation_keys will only
+return the keys of groups that were validated.
+
+ my $key_hashref = $self->get_validation_keys($val_hash);
+
+The values of the hash are the names of the fields.
+
+=item C<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).
+
+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);
+
+ # 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 = $@;
+ }
+
+=item C<generate_js>
+
+Requires YAML to work properly (see 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
+perform identical validations as the server side. The validation can
+be any validation hash (or arrayref of hashes. The form name must be
+the name of the form that the validation will act upon - the name is
+used to register an onsubmit function. The javascript uri path is
+used to embed the locations two external javascript source files.
+
+
+The javascript uri path is highly dependent upon the server
+implementation and therefore must be configured manually. It may be
+passed to generate_js, or it may be specified in $JS_URI_PATH. There
+are two files included with this module that are needed -
+CGI/Ex/yaml_load.js and CGI/Ex/validate.js. When generating the js
+code, generate_js will look in $JS_URI_PATH_YAML and
+$JS_URI_PATH_VALIDATE. If either of these are not set, generate_js
+will default to "$JS_URI_PATH/CGI/Ex/yaml_load.js" and
+"$JS_URI_PATH/CGI/Ex/validate.js".
+
+ $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')
+ # 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.
+The $JS_URI_PATH of "/cgi-bin/js" could contain the following:
+
+ #!/usr/bin/perl -w
+
+ use strict;
+ use CGI::Ex;
+
+ ### path_info should contain something like /CGI/Ex/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;
+
+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).
+
+=item C<-E<gt>cgix>
+
+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 also be an arrayref of hashrefs. In this
+case, each arrayref is treated as a group and is validated separately.
+
+=head1 GROUPS
+
+Each hashref that is passed as a validation hash is treated as a
+group. Keys matching the regex m/^group\s+(\w+)$/ are reserved and
+are counted as GROUP OPTIONS. Keys matching the regex m/^general\s+(\w+)$/
+are reserved and are counted as GENERAL OPTIONS. Other keys (if
+any, should be keys that need validation).
+
+If the GROUP OPTION 'group validate_if' is set, the group will only
+be validated if the conditions are met. Any group with out a validate_if
+fill be automatically validated.
+
+Each of the items listed in the group will be validated. The
+validation order is determined in one of three ways:
+
+=over 4
+
+=item Specify 'group fields' arrayref.
+
+ # order will be (username, password, 'm/\w+_foo/', somethingelse)
+ {
+ 'group title' => "User Information",
+ 'group fields' => [
+ {field => 'username', required => 1},
+ {field => 'password', required => 1},
+ {field => 'm/\w+_foo/', required => 1},
+ ],
+ somethingelse => {required => 1},
+ }
+
+=item Specify 'group order' arrayref.
+
+ # order will be (username, password, 'm/\w+_foo/', somethingelse)
+ {
+ 'group title' => "User Information",
+ 'group order' => [qw(username password), 'm/\w+_foo/'],
+ username => {required => 1},
+ password => {required => 1},
+ 'm/\w+_foo/' => {required => 1},
+ somethingelse => {required => 1},
+ }
+
+=item Do nothing - use sorted order.
+
+ # order will be ('m/\w+_foo/', password, somethingelse, username)
+ {
+ 'group title' => "User Information",
+ username => {required => 1},
+ password => {required => 1},
+ 'm/\w+_foo/' => {required => 1},
+ somethingelse => {required => 1},
+ }
+
+=back
+
+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.
+
+ '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
+form of 'm/somepattern/'. If a regular expression is used, all keys
+matching that pattern will be validated.
+
+=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.
+
+=over 4
+
+=item C<validate_if>
+
+If validate_if is specified, the field will only be validated
+if the conditions are met. Works in JS.
+
+ validate_if => {field => 'name', required => 1, max_len => 30}
+ # Will only validate if the field "name" is present and is less than 30 chars.
+
+ validate_if => 'name',
+ # SAME as
+ validate_if => {field => 'name', required => 1},
+
+ validate_if => '! name',
+ # SAME as
+ validate_if => {field => 'name', max_in_set => '0 of name'},
+
+ validate_if => {field => 'country', compare => "eq US"},
+ # only if country's value is equal to US
+
+ validate_if => {field => 'country', compare => "ne US"},
+ # if country doesn't equal US
+
+ validate_if => {field => 'password', match => 'm/^md5\([a-z0-9]{20}\)$/'},
+ # if password looks like md5(12345678901234567890)
+
+ {
+ field => 'm/^(\w+)_pass/',
+ validate_if => '$1_user',
+ required => 1,
+ }
+ # will validate foo_pass only if foo_user was present.
+
+The validate_if may also contain an arrayref of validation items. So that
+multiple checks can be run. They will be run in order. validate_if will
+return true only if all options returned true.
+
+ validate_if => ['email', 'phone', 'fax']
+
+Optionally, if validate_if is an arrayref, it may contain the word
+'OR' as a special keyword. If the item preceding 'OR' fails validation
+the item after 'OR' will be tested instead. If the item preceding 'OR'
+passes validation the item after 'OR' will not be tested.
+
+ validate_if => [qw(zip OR postalcode)],
+
+=item C<required_if>
+
+Requires the form field if the condition is satisfied. The conditions
+available are the same as for validate_if. This is somewhat the same
+as saying:
+
+ validate_if => 'some_condition',
+ required => 1
+
+ required_if => 'some_condition',
+
+ {
+ 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,
+no other checks will be run.
+
+=item C<min_values> and C<max_values>
+
+Allows for specifying the maximum number of form elements passed.
+max_values defaults to 1 (You must explicitly set it higher
+to allow more than one item by any given name).
+
+=item C<min_in_set> and C<max_in_set>
+
+Somewhat like min_values and max_values except that you specify the
+fields that participate in the count. Also - entries that are not
+defined or do not have length are not counted. An optional "of" can
+be placed after the number for human readibility.
+
+ 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
+
+=item C<enum>
+
+Allows for checking whether an item matches a set of options. In perl
+the value may be passed as an arrayref. In the conf or in perl the
+value may be passed of the options joined with ||.
+
+ {
+ field => 'password_type',
+ enum => 'plaintext||crypt||md5', # OR enum => [qw(plaintext crypt md5)],
+ }
+
+=item C<equals>
+
+Allows for comparison of two form elements. Can have an optional !.
+
+ {
+ field => 'password',
+ equals => 'password_verify',
+ },
+ {
+ field => 'domain1',
+ equals => '!domain2', # make sure the fields are not the same
+ }
+
+=item C<min_len and max_len>
+
+Allows for check on the length of fields
+
+ {
+ 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\./',
+ }
+
+=item C<compare>
+
+Allows for custom comparisons. Available types are
+>, <, >=, <=, !=, ==, gt, lt, ge, le, ne, and eq. Comparisons
+also work in the JS.
+
+ {
+ field => 'my_number',
+ match => 'm/^\d+$/',
+ compare1 => '> 100',
+ compare2 => '< 255',
+ compare3 => '!= 150',
+ }
+
+=item C<sql>
+
+SQL query based - not available in JS. The database handle will be looked
+for in the value $self->{dbhs}->{foo} if sql_db_type is set to 'foo',
+otherwise it will default to $self->{dbh}. If $self->{dbhs}->{foo} or
+$self->{dbh} is a coderef - they will be called and should return a dbh.
+
+ {
+ field => 'username',
+ sql => 'SELECT COUNT(*) FROM users WHERE username = ?',
+ sql_error_if => 1, # default is 1 - set to 0 to negate result
+ # sql_db_type => 'foo', # will look for a dbh under $self->{dbhs}->{foo}
+ }
+
+=item C<custom>
+
+Custom value - not available in JS. Allows for extra programming types.
+May be either a boolean value predetermined before calling validate, or may be
+a coderef that will be called during validation. If coderef is called, it will
+be passed the field name, the form value for that name, and a reference to the
+field validation hash. If the custom type returns false the element fails
+validation and an error is added.
+
+ {
+ field => 'username',
+ custom => sub {
+ my ($key, $val, $type, $field_val_hash) = @_;
+ # do something here
+ return 0;
+ },
+ }
+
+=item C<custom_js>
+
+Custom value - only available in JS. Allows for extra programming types.
+May be either a boolean value predermined 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.',
+ }
+
+=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',
+ }
+
+=back
+
+=head1 SPECIAL VALIDATION TYPES
+
+=over 4
+
+=item C<field>
+
+Specify which field to work on. Key may be a regex in the form 'm/\w+_user/'.
+This key is required if 'group fields' is used or if validate_if or required_if
+are used. It can optionally be used with other types to specify a different form
+element to operate on. On errors, if a non-default error is found, $field
+will be swapped with the value found in field.
+
+The field name may also be a regular expression in the
+form of 'm/somepattern/'. If a regular expression is used, all keys
+matching that pattern will be validated.
+
+=item C<name>
+
+Name to use for errors. If a name is not specified, default errors will use
+"The field $field" as the name. If a non-default error is found, $name
+will be swapped with this name.
+
+=item C<delegate_error>
+
+This option allows for any errors generated on a field to delegate to
+a different field. If the field name was a regex, any patterns will
+be swapped into the delegate_error value. This option is generally only
+useful with the as_hash method of the error object (for inline errors).
+
+ {
+ field => 'zip',
+ match => 'm/^\d{5}/',
+ },
+ {
+ field => 'zip_plus4',
+ match => 'm/^\d{4}/',
+ delegate_error => 'zip',
+ },
+
+ {
+ field => 'm/^(id_[\d+])_user$/',
+ delegate_error => '$1',
+ },
+
+=item C<exclude_js>
+
+This allows the cgi to do checking while keeping the checks from
+being run in JavaScript
+
+ {
+ field => 'cgi_var',
+ required => 1,
+ exclude_js => 1,
+ }
+
+=item C<exclude_cgi>
+
+This allows the js to do checking while keeping the checks from
+being run in the cgi
+
+ {
+ field => 'js_var',
+ required => 1,
+ exclude_cgi => 1,
+ }
+
+=back
+
+=head1 MODIFYING VALIDATION TYPES
+
+=over 4
+
+=item C<do_not_trim>
+
+By default, validate will trim leading and trailing whitespace
+from submitted values. Set do_not_trim to 1 to allow it to
+not trim.
+
+ {field => 'foo', do_not_trim => 1}
+
+=item C<replace>
+
+Pass a swap pattern to change the actual value of the form.
+Any perl regex can be passed.
+
+ {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).
+
+ {field => 'country', default => 'EN'}
+
+=item C<to_upper_case> and C<to_lower_case>
+
+Do what they say they do.
+
+=item C<untaint>
+
+Requires that the validated field has been also checked with
+an enum, equals, match, compare, custom, or type check. If the
+field has been checked and there are no errors - the field is "untainted."
+
+This is for use in conjunction with the -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.
+
+The error object has several methods for determining what the errors were.
+
+=over 4
+
+=item C<as_array>
+
+Returns an array or arrayref (depending on scalar context) of errors that
+occurred in the order that they occured. 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
+is ' '). The as_array_ options may also be set via a hashref passed to as_array.
+as_array_title defaults to 'Please correct the following items:'.
+
+ ### if this returns the following
+ my $array = $err_obj->as_array;
+ # $array looks like
+ # ['Please correct the following items:', ' error1', ' error2']
+
+ ### then this would return the following
+ my $array = $err_obj->as_array({
+ as_array_prefix => ' - ',
+ as_array_title => 'Something went wrong:',
+ });
+ # $array looks like
+ # ['Something went wrong:', ' - error1', ' - error2']
+
+=item C<as_string>
+
+Returns values of as_array joined with a newline. This method is used as
+the stringification for the error object. Values of as_array are joined with
+'as_string_join' which defaults to "\n". If 'as_string_header' is set, it will
+be prepended onto the error string. If 'as_string_footer' is set, it will be
+postpended onto the error string.
+
+ ### if this returns the following
+ my $string = $err_obj->as_string;
+ # $string looks like
+ # "Please correct the following items:\n error1\n error2"
+
+ ### then this would return the following
+ my $string = $err_obj->as_string({
+ as_array_prefix => ' - ',
+ as_array_title => 'Something went wrong:',
+ as_string_join => '<br />',
+ as_string_header => '<span class="error">',
+ as_string_footer => '</span>',
+ });
+ # $string looks like
+ # '<span class="error">Something went wrong:<br /> - error1<br /> - error2</span>'
+
+=item C<as_hash>
+
+Returns a hash or hashref (depending on scalar context) of errors that
+occurred. Each key is the field name of the form that failed validation with
+'as_hash_suffix' added on as a suffix. as_hash_suffix is available as a 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.
+
+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
+will be used to join the arrayref. The only argument required to force the
+stringification is 'as_hash_join'.
+
+ ### if this returns the following
+ my $hash = $err_obj->as_hash;
+ # $hash looks like
+ # {key1_error => ['error1', 'error2']}
+
+ ### then this would return the following
+ my $hash = $err_obj->as_hash({
+ as_hash_suffix => '_foo',
+ as_hash_join => '<br />',
+ as_hash_header => '<span class="error">'
+ as_hash_footer => '</span>'
+ });
+ # $hash looks like
+ # {key1_foo => '<span class="error">error1<br />error2</span>'}
+
+=back
+
+=head1 GROUP OPTIONS
+
+Any key in a validation hash matching the pattern m/^group\s+(\w+)$/
+is considered a group option. The current know options are:
+
+=over 4
+
+=item C<'group title'>
+
+Used as a group section heading when as_array or as_string is called
+by the error object.
+
+=item C<'group order'>
+
+Order in which to validate key/value pairs of group.
+
+=item C<'group fields'>
+
+Arrayref of validation items to validate.
+
+=item C<'group validate_if'>
+
+Conditions that will be checked to see if the group should be validated.
+If no validate_if option is found, the group will be validated.
+
+=back
+
+=head1 GENERAL OPTIONS
+
+Any key in a validation hash matching the pattern m/^general\s+(\w+)$/
+is considered a general option. General options will also be looked
+for in the Validate object ($self) and can be set when instantiating
+the object ($self->{raise_error} is equivalent to
+$valhash->{'general raise_error'}). The current know options are:
+
+General options may be set in any group using the syntax:
+
+ 'general general_option_name' => 'general_option_value'
+
+They will only be set if the group's validate_if is successful or
+if the group does not have a validate_if. It is also possible to set
+a "group general" option using the following syntax:
+
+ 'group general_option_name' => 'general_option_value'
+
+These items will only be set if the group fails validation.
+If a group has a validate_if block and passes validation, the group
+items will not be used. This is so that a failed section can have
+its own settings. Note though that the last option found will be
+used and that items set in $self override those set in the validation
+hash.
+
+Options may also be set globally before calling validate by
+populating the %DEFAULT_OPTIONS global hash.
+
+=over 4
+
+=item C<'general raise_error'>
+
+If raise_error is true, any call to validate that fails validation
+will die with an error object as the value.
+
+=item C<'general no_extra_fields'>
+
+If no_extra_fields is true, validate will add errors for any field found
+in form that does not have a field_val hashref in the validation hash.
+Default is false. If no_extra_fields is set to 'used', it will check for
+any keys that were not in a group that was validated.
+
+An important exception to this is that field_val hashrefs or field names listed
+in a validate_if or required_if statement will not be included. You must
+have an explicit entry for each key.
+
+=item C<'general \w+_error'>
+
+These items allow for an override of the default errors.
+
+ 'general required_error' => '$name is really required',
+ 'general max_len_error' => '$name must be shorter than $value characters',
+ # OR #
+ my $self = CGI::Ex::Validate->new({
+ max_len_error => '$name must be shorter than $value characters',
+ });
+
+=item C<'general as_array_title'>
+
+Used as the section title for all errors that occur, when as_array
+or as_string is called by the error object.
+
+=item C<'general as_array_prefix'>
+
+Used as prefix to individual errors that occur, when as_array
+or as_string is called by the error object. Each individual error
+will be prefixed with this string. Headings will not be prefixed.
+Default is ' '.
+
+=item C<'general as_string_join'>
+
+When as_string is called, the values from as_array will be joined with
+as_string_join. Default value is "\n".
+
+=item C<'general as_string_header'>
+
+If set, will be prepended 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.
+
+=item C<'general as_hash_suffix'>
+
+Added on to key names during the call to as_hash. Default is '_error'.
+
+=item C<'general as_hash_join'>
+
+By default, as_hash will return hashref values that are errors joined with
+the default as_hash_join value of <br />. It can also return values that are
+arrayrefs of the errors. This can be done by setting as_hash_join to a non-true value
+(for example '')
+
+=item C<'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.
+
+=item C<'general as_hash_footer'>
+
+If as_hash_join has been set to a true value, as_hash_footer may be set to
+a string that will be postpended on to the error string.
+
+=item C<'general no_inline'>
+
+If set to true, the javascript validation will not attempt to generate inline
+errors. Default is true. Inline errors are independent of confirm and alert
+errors.
+
+=item C<'general no_confirm'>
+
+If set to true, the javascript validation will try to use an alert instead
+of a confirm to inform the user of errors. Alert and confirm are independent
+or inline errors. Default is false.
+
+=item C<'general no_alert'>
+
+If set to true, the javascript validation will not show an alert box
+when errors occur. Default is false. This option only comes into
+play if no_confirm is also set. This option is independent of inline
+errors. Although it is possible to turn off all errors by setting
+no_inline, no_confirm, and no_alert all to 1, it is suggested that at
+least one of the error reporting facilities is left on.
+
+=back
+
+It is possible to have a group that contains nothing but general options.
+
+ my $val_hash = [
+ {'general error_title' => 'The following things went wrong',
+ 'general error_prefix' => ' - ',
+ 'general raise_error' => 1,
+ 'general name_suffix' => '_foo_error',
+ 'general required_error' => '$name is required',
+ },
+ {'group title' => 'User Information',
+ username => {required => 1},
+ email => {required => 1},
+ password => {required => 1},
+ },
+ ];
+
+=head1 JAVASCRIPT
+
+CGI::Ex::Validate provides for having duplicate validation on the
+client side as on the server side. Errors can be shown in any
+combination of inline and confirm, inline and alert, inline only,
+confirm only, alert only, and none. These combinations are controlled
+by the general options no_inline, no_confirm, and no_alert.
+Javascript validation can be generated for a page using the
+C<-E<gt>generate_js> Method of CGI::Ex::Validate. It is also possible
+to store the validation inline with the html. This can be done by
+giving each of the elements to be validated an attribute called
+"validation", or by setting a global javascript variable called
+"document.validation" or "var validation". An html file containing this
+validation will be read in using CGI::Ex::Conf::read_handler_html.
+
+All inline html validation must be written in yaml.
+
+It is anticipated that the html will contain something like either of the
+following examples:
+
+ <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script>
+ <script src="/cgi-bin/js/CGI/Ex/validate.js"></script>
+ <script>
+ // \n\ allows all browsers to view this as a single string
+ document.validation = "\n\
+ general no_confirm: 1\n\
+ general no_alert: 1\n\
+ group order: [username, password]\n\
+ username:\n\
+ required: 1\n\
+ max_len: 20\n\
+ password:\n\
+ required: 1\n\
+ max_len: 30\n\
+ ";
+ if (document.check_form) document.check_form('my_form_name');
+ </script>
+
+Alternately we can use element attributes:
+
+ <form name="my_form_name">
+
+ Username: <input type=text size=20 name=username validation="
+ required: 1
+ max_len: 20
+ "><br>
+ <span class=error id=username_error>[% username_error %]</span><br>
+
+ Password: <input type=text size=20 name=password validation="
+ required: 1
+ max_len: 30
+ "><br>
+ <span class=error id=password_error>[% password_error %]</span><br>
+
+ <input type=submit>
+
+ </form>
+
+ <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script>
+ <script src="/cgi-bin/js/CGI/Ex/validate.js"></script>
+ <script>
+ if (document.check_form) document.check_form('my_form_name');
+ </script>
+
+The read_handler_html from CGI::Ex::Conf will find either of these
+types of validation.
+
+If inline errors are asked for, each error that occurs will attempt
+to find an html element with its name as the id. For example, if
+the field "username" failed validation and created a "username_error",
+the javascript would set the html of <span id="username_error"></span>
+to the error message.
+
+It is suggested to use something like the following so that you can
+have inline javascript validation as well as report validation errors
+from the server side as well.
+
+ <span class=error id=password_error>[% password_error %]</span><br>
+
+If the javascript fails for some reason, the form should still be able
+to submit as normal (fail gracefully).
+
+If the confirm option is used, the errors will be displayed to the user.
+If they choose OK they will be able to try and fix the errors. If they
+choose cancel, the form will submit anyway and will rely on the server
+to do the validation. This is for fail safety to make sure that if the
+javascript didn't validate correctly, the user can still submit the data.
+
+=head1 AUTHOR
+
+Paul Seamons
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
+
--- /dev/null
+/*
+ * Code taken directly from source listed below via the BSD license with one
+ * function added at bottom - Paul Seamons - March 2004
+ */
+
+
+/*
+ * A JavaScript implementation of the RSA Data Security, Inc. MD5 Message
+ * Digest Algorithm, as defined in RFC 1321.
+ * Version 2.1 Copyright (C) Paul Johnston 1999 - 2002.
+ * Other contributors: Greg Holt, Andrew Kepert, Ydnar, Lostinet
+ * Distributed under the BSD License
+ * See http://pajhome.org.uk/crypt/md5 for more info.
+ */
+
+/*
+ * Configurable variables. You may need to tweak these to be compatible with
+ * the server-side, but the defaults work in most cases.
+ */
+var hexcase = 0; /* hex output format. 0 - lowercase; 1 - uppercase */
+var b64pad = ""; /* base-64 pad character. "=" for strict RFC compliance */
+var chrsz = 8; /* bits per input character. 8 - ASCII; 16 - Unicode */
+
+/*
+ * These are the functions you'll usually want to call
+ * They take string arguments and return either hex or base-64 encoded strings
+ */
+function hex_md5(s){ return binl2hex(core_md5(str2binl(s), s.length * chrsz));}
+function b64_md5(s){ return binl2b64(core_md5(str2binl(s), s.length * chrsz));}
+function str_md5(s){ return binl2str(core_md5(str2binl(s), s.length * chrsz));}
+function hex_hmac_md5(key, data) { return binl2hex(core_hmac_md5(key, data)); }
+function b64_hmac_md5(key, data) { return binl2b64(core_hmac_md5(key, data)); }
+function str_hmac_md5(key, data) { return binl2str(core_hmac_md5(key, data)); }
+
+/*
+ * Perform a simple self-test to see if the VM is working
+ */
+function md5_vm_test()
+{
+ return hex_md5("abc") == "900150983cd24fb0d6963f7d28e17f72";
+}
+
+/*
+ * Calculate the MD5 of an array of little-endian words, and a bit length
+ */
+function core_md5(x, len)
+{
+ /* append padding */
+ x[len >> 5] |= 0x80 << ((len) % 32);
+ x[(((len + 64) >>> 9) << 4) + 14] = len;
+
+ var a = 1732584193;
+ var b = -271733879;
+ var c = -1732584194;
+ var d = 271733878;
+
+ for(var i = 0; i < x.length; i += 16)
+ {
+ var olda = a;
+ var oldb = b;
+ var oldc = c;
+ var oldd = d;
+
+ a = md5_ff(a, b, c, d, x[i+ 0], 7 , -680876936);
+ d = md5_ff(d, a, b, c, x[i+ 1], 12, -389564586);
+ c = md5_ff(c, d, a, b, x[i+ 2], 17, 606105819);
+ b = md5_ff(b, c, d, a, x[i+ 3], 22, -1044525330);
+ a = md5_ff(a, b, c, d, x[i+ 4], 7 , -176418897);
+ d = md5_ff(d, a, b, c, x[i+ 5], 12, 1200080426);
+ c = md5_ff(c, d, a, b, x[i+ 6], 17, -1473231341);
+ b = md5_ff(b, c, d, a, x[i+ 7], 22, -45705983);
+ a = md5_ff(a, b, c, d, x[i+ 8], 7 , 1770035416);
+ d = md5_ff(d, a, b, c, x[i+ 9], 12, -1958414417);
+ c = md5_ff(c, d, a, b, x[i+10], 17, -42063);
+ b = md5_ff(b, c, d, a, x[i+11], 22, -1990404162);
+ a = md5_ff(a, b, c, d, x[i+12], 7 , 1804603682);
+ d = md5_ff(d, a, b, c, x[i+13], 12, -40341101);
+ c = md5_ff(c, d, a, b, x[i+14], 17, -1502002290);
+ b = md5_ff(b, c, d, a, x[i+15], 22, 1236535329);
+
+ a = md5_gg(a, b, c, d, x[i+ 1], 5 , -165796510);
+ d = md5_gg(d, a, b, c, x[i+ 6], 9 , -1069501632);
+ c = md5_gg(c, d, a, b, x[i+11], 14, 643717713);
+ b = md5_gg(b, c, d, a, x[i+ 0], 20, -373897302);
+ a = md5_gg(a, b, c, d, x[i+ 5], 5 , -701558691);
+ d = md5_gg(d, a, b, c, x[i+10], 9 , 38016083);
+ c = md5_gg(c, d, a, b, x[i+15], 14, -660478335);
+ b = md5_gg(b, c, d, a, x[i+ 4], 20, -405537848);
+ a = md5_gg(a, b, c, d, x[i+ 9], 5 , 568446438);
+ d = md5_gg(d, a, b, c, x[i+14], 9 , -1019803690);
+ c = md5_gg(c, d, a, b, x[i+ 3], 14, -187363961);
+ b = md5_gg(b, c, d, a, x[i+ 8], 20, 1163531501);
+ a = md5_gg(a, b, c, d, x[i+13], 5 , -1444681467);
+ d = md5_gg(d, a, b, c, x[i+ 2], 9 , -51403784);
+ c = md5_gg(c, d, a, b, x[i+ 7], 14, 1735328473);
+ b = md5_gg(b, c, d, a, x[i+12], 20, -1926607734);
+
+ a = md5_hh(a, b, c, d, x[i+ 5], 4 , -378558);
+ d = md5_hh(d, a, b, c, x[i+ 8], 11, -2022574463);
+ c = md5_hh(c, d, a, b, x[i+11], 16, 1839030562);
+ b = md5_hh(b, c, d, a, x[i+14], 23, -35309556);
+ a = md5_hh(a, b, c, d, x[i+ 1], 4 , -1530992060);
+ d = md5_hh(d, a, b, c, x[i+ 4], 11, 1272893353);
+ c = md5_hh(c, d, a, b, x[i+ 7], 16, -155497632);
+ b = md5_hh(b, c, d, a, x[i+10], 23, -1094730640);
+ a = md5_hh(a, b, c, d, x[i+13], 4 , 681279174);
+ d = md5_hh(d, a, b, c, x[i+ 0], 11, -358537222);
+ c = md5_hh(c, d, a, b, x[i+ 3], 16, -722521979);
+ b = md5_hh(b, c, d, a, x[i+ 6], 23, 76029189);
+ a = md5_hh(a, b, c, d, x[i+ 9], 4 , -640364487);
+ d = md5_hh(d, a, b, c, x[i+12], 11, -421815835);
+ c = md5_hh(c, d, a, b, x[i+15], 16, 530742520);
+ b = md5_hh(b, c, d, a, x[i+ 2], 23, -995338651);
+
+ a = md5_ii(a, b, c, d, x[i+ 0], 6 , -198630844);
+ d = md5_ii(d, a, b, c, x[i+ 7], 10, 1126891415);
+ c = md5_ii(c, d, a, b, x[i+14], 15, -1416354905);
+ b = md5_ii(b, c, d, a, x[i+ 5], 21, -57434055);
+ a = md5_ii(a, b, c, d, x[i+12], 6 , 1700485571);
+ d = md5_ii(d, a, b, c, x[i+ 3], 10, -1894986606);
+ c = md5_ii(c, d, a, b, x[i+10], 15, -1051523);
+ b = md5_ii(b, c, d, a, x[i+ 1], 21, -2054922799);
+ a = md5_ii(a, b, c, d, x[i+ 8], 6 , 1873313359);
+ d = md5_ii(d, a, b, c, x[i+15], 10, -30611744);
+ c = md5_ii(c, d, a, b, x[i+ 6], 15, -1560198380);
+ b = md5_ii(b, c, d, a, x[i+13], 21, 1309151649);
+ a = md5_ii(a, b, c, d, x[i+ 4], 6 , -145523070);
+ d = md5_ii(d, a, b, c, x[i+11], 10, -1120210379);
+ c = md5_ii(c, d, a, b, x[i+ 2], 15, 718787259);
+ b = md5_ii(b, c, d, a, x[i+ 9], 21, -343485551);
+
+ a = safe_add(a, olda);
+ b = safe_add(b, oldb);
+ c = safe_add(c, oldc);
+ d = safe_add(d, oldd);
+ }
+ return Array(a, b, c, d);
+
+}
+
+/*
+ * These functions implement the four basic operations the algorithm uses.
+ */
+function md5_cmn(q, a, b, x, s, t)
+{
+ return safe_add(bit_rol(safe_add(safe_add(a, q), safe_add(x, t)), s),b);
+}
+function md5_ff(a, b, c, d, x, s, t)
+{
+ return md5_cmn((b & c) | ((~b) & d), a, b, x, s, t);
+}
+function md5_gg(a, b, c, d, x, s, t)
+{
+ return md5_cmn((b & d) | (c & (~d)), a, b, x, s, t);
+}
+function md5_hh(a, b, c, d, x, s, t)
+{
+ return md5_cmn(b ^ c ^ d, a, b, x, s, t);
+}
+function md5_ii(a, b, c, d, x, s, t)
+{
+ return md5_cmn(c ^ (b | (~d)), a, b, x, s, t);
+}
+
+/*
+ * Calculate the HMAC-MD5, of a key and some data
+ */
+function core_hmac_md5(key, data)
+{
+ var bkey = str2binl(key);
+ if(bkey.length > 16) bkey = core_md5(bkey, key.length * chrsz);
+
+ var ipad = Array(16), opad = Array(16);
+ for(var i = 0; i < 16; i++)
+ {
+ ipad[i] = bkey[i] ^ 0x36363636;
+ opad[i] = bkey[i] ^ 0x5C5C5C5C;
+ }
+
+ var hash = core_md5(ipad.concat(str2binl(data)), 512 + data.length * chrsz);
+ return core_md5(opad.concat(hash), 512 + 128);
+}
+
+/*
+ * Add integers, wrapping at 2^32. This uses 16-bit operations internally
+ * to work around bugs in some JS interpreters.
+ */
+function safe_add(x, y)
+{
+ var lsw = (x & 0xFFFF) + (y & 0xFFFF);
+ var msw = (x >> 16) + (y >> 16) + (lsw >> 16);
+ return (msw << 16) | (lsw & 0xFFFF);
+}
+
+/*
+ * Bitwise rotate a 32-bit number to the left.
+ */
+function bit_rol(num, cnt)
+{
+ return (num << cnt) | (num >>> (32 - cnt));
+}
+
+/*
+ * Convert a string to an array of little-endian words
+ * If chrsz is ASCII, characters >255 have their hi-byte silently ignored.
+ */
+function str2binl(str)
+{
+ var bin = Array();
+ var mask = (1 << chrsz) - 1;
+ for(var i = 0; i < str.length * chrsz; i += chrsz)
+ bin[i>>5] |= (str.charCodeAt(i / chrsz) & mask) << (i%32);
+ return bin;
+}
+
+/*
+ * Convert an array of little-endian words to a string
+ */
+function binl2str(bin)
+{
+ var str = "";
+ var mask = (1 << chrsz) - 1;
+ for(var i = 0; i < bin.length * 32; i += chrsz)
+ str += String.fromCharCode((bin[i>>5] >>> (i % 32)) & mask);
+ return str;
+}
+
+/*
+ * Convert an array of little-endian words to a hex string.
+ */
+function binl2hex(binarray)
+{
+ var hex_tab = hexcase ? "0123456789ABCDEF" : "0123456789abcdef";
+ var str = "";
+ for(var i = 0; i < binarray.length * 4; i++)
+ {
+ str += hex_tab.charAt((binarray[i>>2] >> ((i%4)*8+4)) & 0xF) +
+ hex_tab.charAt((binarray[i>>2] >> ((i%4)*8 )) & 0xF);
+ }
+ return str;
+}
+
+/*
+ * Convert an array of little-endian words to a base-64 string
+ */
+function binl2b64(binarray)
+{
+ var tab = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
+ var str = "";
+ for(var i = 0; i < binarray.length * 4; i += 3)
+ {
+ var triplet = (((binarray[i >> 2] >> 8 * ( i %4)) & 0xFF) << 16)
+ | (((binarray[i+1 >> 2] >> 8 * ((i+1)%4)) & 0xFF) << 8 )
+ | ((binarray[i+2 >> 2] >> 8 * ((i+2)%4)) & 0xFF);
+ for(var j = 0; j < 4; j++)
+ {
+ if(i * 8 + j * 6 > binarray.length * 32) str += b64pad;
+ else str += tab.charAt((triplet >> 6*(3-j)) & 0x3F);
+ }
+ }
+ return str;
+}
+
+/* simple sub added so we can test for existance */
+document.md5_hex = function (s) {
+ return hex_md5(s);
+}
+
+document.md5_is_functional = function () {
+ return md5_vm_test();
+}
--- /dev/null
+/*
+ * Code taken directly from source listed below via the BSD license with two
+ * function added at bottom - Paul Seamons - March 2004
+ */
+
+
+/*
+ * A JavaScript implementation of the Secure Hash Algorithm, SHA-1, as defined
+ * in FIPS PUB 180-1
+ * Version 2.1 Copyright Paul Johnston 2000 - 2002.
+ * Other contributors: Greg Holt, Andrew Kepert, Ydnar, Lostinet
+ * Distributed under the BSD License
+ * See http://pajhome.org.uk/crypt/md5 for details.
+ */
+
+/*
+ * Configurable variables. You may need to tweak these to be compatible with
+ * the server-side, but the defaults work in most cases.
+ */
+var hexcase = 0; /* hex output format. 0 - lowercase; 1 - uppercase */
+var b64pad = ""; /* base-64 pad character. "=" for strict RFC compliance */
+var chrsz = 8; /* bits per input character. 8 - ASCII; 16 - Unicode */
+
+/*
+ * These are the functions you'll usually want to call
+ * They take string arguments and return either hex or base-64 encoded strings
+ */
+function hex_sha1(s){return binb2hex(core_sha1(str2binb(s),s.length * chrsz));}
+function b64_sha1(s){return binb2b64(core_sha1(str2binb(s),s.length * chrsz));}
+function str_sha1(s){return binb2str(core_sha1(str2binb(s),s.length * chrsz));}
+function hex_hmac_sha1(key, data){ return binb2hex(core_hmac_sha1(key, data));}
+function b64_hmac_sha1(key, data){ return binb2b64(core_hmac_sha1(key, data));}
+function str_hmac_sha1(key, data){ return binb2str(core_hmac_sha1(key, data));}
+
+/*
+ * Perform a simple self-test to see if the VM is working
+ */
+function sha1_vm_test()
+{
+ return hex_sha1("abc") == "a9993e364706816aba3e25717850c26c9cd0d89d";
+}
+
+/*
+ * Calculate the SHA-1 of an array of big-endian words, and a bit length
+ */
+function core_sha1(x, len)
+{
+ /* append padding */
+ x[len >> 5] |= 0x80 << (24 - len % 32);
+ x[((len + 64 >> 9) << 4) + 15] = len;
+
+ var w = Array(80);
+ var a = 1732584193;
+ var b = -271733879;
+ var c = -1732584194;
+ var d = 271733878;
+ var e = -1009589776;
+
+ for(var i = 0; i < x.length; i += 16)
+ {
+ var olda = a;
+ var oldb = b;
+ var oldc = c;
+ var oldd = d;
+ var olde = e;
+
+ for(var j = 0; j < 80; j++)
+ {
+ if(j < 16) w[j] = x[i + j];
+ else w[j] = rol(w[j-3] ^ w[j-8] ^ w[j-14] ^ w[j-16], 1);
+ var t = safe_add(safe_add(rol(a, 5), sha1_ft(j, b, c, d)),
+ safe_add(safe_add(e, w[j]), sha1_kt(j)));
+ e = d;
+ d = c;
+ c = rol(b, 30);
+ b = a;
+ a = t;
+ }
+
+ a = safe_add(a, olda);
+ b = safe_add(b, oldb);
+ c = safe_add(c, oldc);
+ d = safe_add(d, oldd);
+ e = safe_add(e, olde);
+ }
+ return Array(a, b, c, d, e);
+
+}
+
+/*
+ * Perform the appropriate triplet combination function for the current
+ * iteration
+ */
+function sha1_ft(t, b, c, d)
+{
+ if(t < 20) return (b & c) | ((~b) & d);
+ if(t < 40) return b ^ c ^ d;
+ if(t < 60) return (b & c) | (b & d) | (c & d);
+ return b ^ c ^ d;
+}
+
+/*
+ * Determine the appropriate additive constant for the current iteration
+ */
+function sha1_kt(t)
+{
+ return (t < 20) ? 1518500249 : (t < 40) ? 1859775393 :
+ (t < 60) ? -1894007588 : -899497514;
+}
+
+/*
+ * Calculate the HMAC-SHA1 of a key and some data
+ */
+function core_hmac_sha1(key, data)
+{
+ var bkey = str2binb(key);
+ if(bkey.length > 16) bkey = core_sha1(bkey, key.length * chrsz);
+
+ var ipad = Array(16), opad = Array(16);
+ for(var i = 0; i < 16; i++)
+ {
+ ipad[i] = bkey[i] ^ 0x36363636;
+ opad[i] = bkey[i] ^ 0x5C5C5C5C;
+ }
+
+ var hash = core_sha1(ipad.concat(str2binb(data)), 512 + data.length * chrsz);
+ return core_sha1(opad.concat(hash), 512 + 160);
+}
+
+/*
+ * Add integers, wrapping at 2^32. This uses 16-bit operations internally
+ * to work around bugs in some JS interpreters.
+ */
+function safe_add(x, y)
+{
+ var lsw = (x & 0xFFFF) + (y & 0xFFFF);
+ var msw = (x >> 16) + (y >> 16) + (lsw >> 16);
+ return (msw << 16) | (lsw & 0xFFFF);
+}
+
+/*
+ * Bitwise rotate a 32-bit number to the left.
+ */
+function rol(num, cnt)
+{
+ return (num << cnt) | (num >>> (32 - cnt));
+}
+
+/*
+ * Convert an 8-bit or 16-bit string to an array of big-endian words
+ * In 8-bit function, characters >255 have their hi-byte silently ignored.
+ */
+function str2binb(str)
+{
+ var bin = Array();
+ var mask = (1 << chrsz) - 1;
+ for(var i = 0; i < str.length * chrsz; i += chrsz)
+ bin[i>>5] |= (str.charCodeAt(i / chrsz) & mask) << (24 - i%32);
+ return bin;
+}
+
+/*
+ * Convert an array of big-endian words to a string
+ */
+function binb2str(bin)
+{
+ var str = "";
+ var mask = (1 << chrsz) - 1;
+ for(var i = 0; i < bin.length * 32; i += chrsz)
+ str += String.fromCharCode((bin[i>>5] >>> (24 - i%32)) & mask);
+ return str;
+}
+
+/*
+ * Convert an array of big-endian words to a hex string.
+ */
+function binb2hex(binarray)
+{
+ var hex_tab = hexcase ? "0123456789ABCDEF" : "0123456789abcdef";
+ var str = "";
+ for(var i = 0; i < binarray.length * 4; i++)
+ {
+ str += hex_tab.charAt((binarray[i>>2] >> ((3 - i%4)*8+4)) & 0xF) +
+ hex_tab.charAt((binarray[i>>2] >> ((3 - i%4)*8 )) & 0xF);
+ }
+ return str;
+}
+
+/*
+ * Convert an array of big-endian words to a base-64 string
+ */
+function binb2b64(binarray)
+{
+ var tab = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
+ var str = "";
+ for(var i = 0; i < binarray.length * 4; i += 3)
+ {
+ var triplet = (((binarray[i >> 2] >> 8 * (3 - i %4)) & 0xFF) << 16)
+ | (((binarray[i+1 >> 2] >> 8 * (3 - (i+1)%4)) & 0xFF) << 8 )
+ | ((binarray[i+2 >> 2] >> 8 * (3 - (i+2)%4)) & 0xFF);
+ for(var j = 0; j < 4; j++)
+ {
+ if(i * 8 + j * 6 > binarray.length * 32) str += b64pad;
+ else str += tab.charAt((triplet >> 6*(3-j)) & 0x3F);
+ }
+ }
+ return str;
+}
+
+/* simple sub added so we can test for existance */
+document.sha1_hex = function (s) {
+ return hex_sha1(s);
+}
+
+document.sha1_is_functional = function () {
+ return sha1_vm_test();
+}
--- /dev/null
+/**----------------------------------------------------------------***
+* Copyright 2004 - 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 $
+
+function Validate () {
+ this.error = vob_error;
+ this.validate = vob_validate;
+ this.check_conditional = vob_check_conditional;
+ this.filter_types = vob_filter_types;
+ this.add_error = vob_add_error;
+ this.validate_buddy = vob_validate_buddy;
+ this.check_type = vob_check_type;
+ this.get_form_value = vob_get_form_value;
+}
+
+function ValidateError (errors, extra) {
+ this.errors = errors;
+ this.extra = extra;
+
+ this.as_string = eob_as_string;
+ this.as_array = eob_as_array;
+ this.as_hash = eob_as_hash;
+ this.get_error_text = eob_get_error_text;
+ this.first_field = eob_first_field;
+}
+
+///----------------------------------------------------------------///
+
+function vob_error (err) {
+ alert (err);
+}
+
+function vob_validate (form, val_hash) {
+ if (typeof(val_hash) == 'string') {
+ if (! document.yaml_load)
+ return this.error("Cannot parse yaml string - document.yaml_load is not loaded");
+ val_hash = document.yaml_load(val_hash);
+ }
+
+ var ERRORS = new Array ();
+ var EXTRA = new Array ();
+ // var USED_GROUPS = new Array();
+
+ // distinguishing between associative and index based arrays is harder than in perl
+ if (! val_hash.length) val_hash = new Array(val_hash);
+ for (var i = 0; i < val_hash.length; i ++) {
+ var group_val = val_hash[i];
+ if (typeof(group_val) != 'object' || group_val.length) return this.error("Validation groups must be a hash");
+ var title = group_val['group title'];
+ var validate_if = group_val['group validate_if'];
+
+ if (validate_if && ! this.check_conditional(form, validate_if)) continue;
+ // USED_GROUPS.push(group_val);
+
+ /// if the validation items were not passed as an arrayref
+ /// 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;
+ order = order.sort();
+ if (fields) {
+ if (typeof(fields) != 'object' || ! fields.length)
+ return this.error("'group fields' must be a non-empty array");
+ } else {
+ fields = new Array();
+ var _order = (group_val['group order']) ? group_val['group order'] : order;
+ if (typeof(_order) != 'object' || ! _order.length)
+ return this.error("'group order' must be a non-empty array");
+ for (var j = 0; j < _order.length; j ++) {
+ var field = _order[j];
+ if (field.match('^(group|general)\\s')) continue;
+ var field_val = group_val[field];
+ if (! field_val) {
+ if (field == 'OR') field_val = 'OR';
+ else return this.error('No element found in group for '+field);
+ }
+ if (typeof(field_val) == 'object' && ! field_val['field']) field_val['field'] = field;
+ fields[fields.length] = field_val;
+ }
+ }
+
+ /// check which fields have been used
+ var found = new Array();
+ for (var j = 0; j < fields.length; j ++) {
+ var field_val = fields[j];
+ var field = field_val['field'];
+ if (! field) return this.error("Missing field key in validation");
+ // if (found[field]) return this.error('Duplicate order found for '+field+' in group order or fields');
+ found[field] = 1;
+ }
+
+ /// add any remaining fields from the order
+ for (var j = 0; j < order.length; j ++) {
+ var field = order[j];
+ if (found[field] || field.match('^(group|general)\\s')) continue;
+ var field_val = group_val[field];
+ if (typeof(field_val) != 'object' || field_val.length) return this.error('Found a non-hash value on field '+field);
+ if (! field_val['field']) field_val['field'] = field;
+ fields[fields.length] = field_val;
+ }
+
+ /// now lets do the validation
+ var is_found = 1;
+ var errors = new Array();
+ var hold_error;
+
+ for (var j = 0; j < fields.length; j ++) {
+ var ref = fields[j];
+ if (typeof(ref) != 'object' && ref == 'OR') {
+ if (is_found) j ++;
+ is_found = 1;
+ continue;
+ }
+ is_found = 1;
+ if (! ref['field']) return this.error("Missing field key during normal validation");
+ var err = this.validate_buddy(form, ref['field'], ref);
+
+ /// test the error - if errors occur allow for OR - if OR fails use errors from first fail
+ if (err.length) {
+ if (j <= fields.length && typeof(fields[j + 1] != 'object') && fields[j + 1] == 'OR') {
+ hold_error = err;
+ } else {
+ if (hold_error) err = hold_error;
+ for (var k = 0; k < err.length; k ++) errors[errors.length] = err[k];
+ hold_error = '';
+ }
+ } else {
+ hold_error = '';
+ }
+ }
+
+ /// add on errors as requested
+ if (errors.length) {
+ if (title) ERRORS[ERRORS.length] = title;
+ for (var j = 0; j < errors.length; j ++) ERRORS[ERRORS.length] = errors[j];
+ }
+
+ /// add on general options, and group options if errors in group occurred
+ var m;
+ for (var j = 0; j < order.length; j ++) {
+ var field = order[j];
+ if (! (m = field.match('^(general|group)\\s+(\\w+)$'))) continue;
+ if (m[1] == 'group' && (errors.length == 0 || m[2].match('^(field|order|title)$'))) continue;
+ EXTRA[m[2]] = group_val[field];
+ }
+ }
+
+ /// store any extra items from self
+ for (var key in this) {
+ if (! key.match('_error$')
+ && ! key.match('^(raise_error|as_hash_\\w+|as_array_\\w+|as_string_\\w+)$')) continue;
+ EXTRA[key] = this[key];
+ }
+
+ /// allow for checking for unused keys
+ // if (EXTRA['no_extra_fields'])
+ // won't do anything about this for now - let the server handle it
+
+ /// return what they want
+ if (ERRORS.length) return new ValidateError(ERRORS, EXTRA);
+ return;
+}
+
+
+/// allow for optional validation on groups and on individual items
+function vob_check_conditional (form, ifs, N_level, ifs_match) {
+
+ if (! N_level) N_level = 0;
+ N_level ++;
+
+ /// can pass a single hash - or an array ref of hashes
+ if (! ifs) {
+ return this.error("Need reference passed to check_conditional");
+ } else if (typeof(ifs) != 'object') {
+ ifs = new Array(ifs);
+ } else if (! ifs.length) { // turn hash into array of hash
+ ifs = new Array(ifs);
+ }
+
+ /// run the if options here
+ /// multiple items can be passed - all are required unless OR is used to separate
+ var is_found = 1;
+ var m;
+ for (var i = 0; i < ifs.length; i ++) {
+ var ref = ifs[i];
+ if (typeof(ref) != 'object') {
+ if (ref == 'OR') {
+ if (is_found) i++;
+ is_found = 1;
+ continue;
+ } else {
+ var field = ref;
+ ref = new Array();
+ if (m = field.match('^(\\s*!\\s*)')) {
+ field = field.substring(m[1].length);
+ ref['max_in_set'] = '0 of ' + field;
+ } else {
+ ref['required'] = 1;
+ }
+ ref['field'] = field;
+ }
+ }
+ if (! is_found) break;
+
+ /// get the field - allow for custom variables based upon a match
+ var field = ref['field'];
+ if (! field) return this.error("Missing field key during validate_if");
+ field = field.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+
+ var err = this.validate_buddy(form, field, ref, N_level);
+ if (err.length) is_found = 0;
+ }
+ return is_found;
+}
+
+function vob_filter_types (type, types) {
+ var values = new Array();
+ var regexp = new RegExp('^'+type+'_?\\d*$');
+ for (var i = 0; i < types.length; i++)
+ if (types[i].match(regexp)) values[values.length] = types[i];
+ return values;
+}
+
+function vob_add_error (errors,field,type,field_val,ifs_match) {
+ errors[errors.length] = new Array(field, type, field_val, ifs_match);
+}
+
+/// this is where the main checking goes on
+function vob_validate_buddy (form, field, field_val, N_level, ifs_match) {
+ if (! N_level) N_level = 0;
+ if (++ N_level > 10) return this.error("Max dependency level reached " + N_level);
+ if (! form.elements) return;
+
+ var errors = new Array();
+ var types = new Array();
+ for (var key in field_val) types[types.length] = key;
+ types = types.sort();
+
+ /// allow for not running some tests in the cgi
+ if (this.filter_types('exclude_js', types).length) return errors;
+
+ /// allow for field names that contain regular expressions
+ var m;
+ if (m = field.match('^(!\\s*|)m([^\\s\\w])(.*)\\2([eigsmx]*)$')) {
+ var not = m[1];
+ var pat = m[3];
+ var opt = m[4];
+ if (opt.indexOf('e') != -1) return this.error("The e option cannot be used on field "+field);
+ opt = opt.replace(new RegExp('[sg]','g'),'');
+ var reg = new RegExp(pat, opt);
+
+ var keys = new Array();
+ for (var i = 0; i < form.elements.length; i ++) {
+ var _field = form.elements[i].name;
+ if (! _field) continue;
+ if ( (not && ! (m = _field.match(reg))) || (m = _field.match(reg))) {
+ var err = this.validate_buddy(form, _field, field_val, N_level, m);
+ for (var j = 0; j < err.length; j ++) errors[errors.length] = err[j];
+ }
+ }
+ return errors;
+ }
+
+ var _value = this.get_form_value(form[field]);
+ var values;
+ if (typeof(_value) == 'object') {
+ values = _value;
+ } else {
+ values = new Array();
+ values[values.length] = _value;
+ }
+ var n_values = (typeof(_value) == 'undefined') ? 0 : values.length;
+
+ /// allow for default value
+ var tests = this.filter_types('default', types);
+ if (n_values == 0 || (n_values == 1 && values[0].length == 0)) {
+ for (var i = 0; i < tests.length; i ++) {
+ var el = form[field];
+ var type = el.type;
+ if (type && (type == 'hidden' || type == 'password' || type == 'text' || type == 'textarea' || type == 'submit')) el.value = values[0] = field_val[tests[i]];
+ }
+ }
+
+ /// allow for a few form modifiers
+ var modified = 0;
+ for (var i = 0; i < values.length; i ++) {
+ if (typeof(values[i]) == 'undefined') continue;
+ if (! this.filter_types('do_not_trim',types).length)
+ values[i] = values[i].replace('^\\s+','').replace(new RegExp('\\s+$',''),'');
+ if (this.filter_types('to_upper_case',types).length) {
+ values[i] = values[i].toUpperCase();
+ } else if (this.filter_types('to_lower_case',types).length) {
+ values[i] = values[i].toLowerCase();
+ }
+ }
+ var tests = this.filter_types('replace', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var ref = field_val[tests[i]];
+ ref = (typeof(ref) == 'object') ? ref : ref.split(new RegExp('\\s*\\|\\|\\s*'));
+ for (var j = 0; j < ref.length; j ++) {
+ if (! (m = ref[j].match('^\\s*s([^\\s\\w])(.+)\\1(.*)\\1([eigmx]*)$')))
+ return this.error("Not sure how to parse that replace "+ref[j]);
+ var pat = m[2];
+ var swap = m[3];
+ var opt = m[4];
+ if (opt.indexOf('e') != -1)
+ return this.error("The e option cannot be used on field "+field+", replace "+tests[i]);
+ var regexp = new RegExp(pat, opt);
+ for (var k = 0; k < values.length; k ++) {
+ if (values[k].match(regexp)) modified = 1;
+ values[k] = values[k].replace(regexp,swap);
+ }
+ }
+ }
+ if (modified && n_values == 1) {
+ var el = form[field];
+ var type = el.type;
+ if (! type) return '';
+ if (type == 'hidden' || type == 'password' || type == 'text' || type == 'textarea' || type == 'submit')
+ el.value = values[0];
+ }
+
+ /// only continue if a validate_if is not present or passes test
+ var needs_val = 0;
+ var n_vif = 0;
+ var tests = this.filter_types('validate_if', types);
+ for (var i = 0; i < tests.length; i ++) {
+ n_vif ++;
+ var ifs = field_val[tests[i]];
+ var ret = this.check_conditional(form, ifs, N_level, ifs_match);
+ if (ret) needs_val ++;
+ }
+ if (! needs_val && n_vif) return errors;
+
+
+ /// check for simple existence
+ /// optionally check only if another condition is met
+ var is_required = '';
+ var tests = this.filter_types('required', types);
+ for (var i = 0; i < tests.length; i ++) {
+ if (! field_val[tests[i]] || field_val[tests[i]] == 0) continue;
+ is_required = tests[i];
+ break;
+ }
+ if (! is_required) {
+ var tests = this.filter_types('required_if', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var ifs = field_val[tests[i]];
+ if (! this.check_conditional(form, ifs, N_level, ifs_match)) continue;
+ is_required = tests[i];
+ break;
+ }
+ }
+ if (is_required && (typeof(_value) == 'undefined'
+ || ((typeof(_value) == 'object' && _value.length == 0)
+ || ! _value.length))) {
+ this.add_error(errors, field, is_required, field_val, ifs_match);
+ return errors;
+ }
+
+ /// min values check
+ var tests = this.filter_types('min_values', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var n = field_val[tests[i]];
+ if (n_values < n) {
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ return errors;
+ }
+ }
+
+ /// max values check
+ var tests = this.filter_types('max_values', types);
+ if (! tests.length) {
+ tests[tests.length] = 'max_values';
+ field_val['max_values'] = 1;
+ }
+ for (var i = 0; i < tests.length; i ++) {
+ var n = field_val[tests[i]];
+ if (n_values > n) {
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ return errors;
+ }
+ }
+
+ /// min_in_set and max_in_set check
+ for (var h = 0; h < 2 ; h++) {
+ var minmax = (h == 0) ? 'min' : 'max';
+ var tests = this.filter_types(minmax+'_in_set', types);
+ for (var i = 0; i < tests.length; i ++) {
+ if (! (m = field_val[tests[i]].match('^\\s*(\\d+)(?:\\s*[oO][fF])?\\s+(.+)\\s*$')))
+ return this.error("Invalid in_set check "+field_val[tests[i]]);
+ var n = m[1];
+ var _fields = m[2].split(new RegExp('[\\s,]+'));
+ for (var k = 0; k < _fields.length; k ++) {
+ var _value = this.get_form_value(form[_fields[k]]);
+ var _values;
+ if (typeof(_value) == 'undefined') continue;
+ if (typeof(_value) == 'object') {
+ _values = _value;
+ } else {
+ _values = new Array();
+ _values[_values.length] = _value;
+ }
+ for (var l = 0; l < _values.length; l ++) {
+ var _value = _values[l];
+ if (typeof(_value) != 'undefined' && _value.length) n --;
+ }
+ }
+ if ( (minmax == 'min' && n > 0)
+ || (minmax == 'max' && n < 0)) {
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ return errors;
+ }
+ }
+ }
+
+ // the remaining tests operate on each value of a field
+ for (var n = 0; n < values.length; n ++) {
+ var value = values[n];
+
+ /// allow for enum types
+ var tests = this.filter_types('enum', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var hold = field_val[tests[i]];
+ var _enum = (typeof(hold) == 'object') ? hold : hold.split(new RegExp('\\s*\\|\\|\\s*'));
+ var is_found = 0;
+ for (var j = 0; j < _enum.length; j ++) {
+ if (value != _enum[j]) continue;
+ is_found = 1;
+ break;
+ }
+ if (! is_found) this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+
+ /// field equality test
+ var tests = this.filter_types('equals', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var field2 = field_val[tests[i]];
+ var not = field2.match('^!\\s*');
+ if (not) field2 = field2.substring(not[0].length);
+ var success = 0;
+ if (m = field2.match('^(["\'])(.*)\\1$')) {
+ if (value == m[2]) success = 1;
+ } else {
+ var value2 = this.get_form_value(form[field2]);
+ if (typeof(value2) == 'undefined') value2 = '';
+ if (value == value2) success = 1;
+ }
+ if (not && success || ! not && ! success)
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+
+ /// length min check
+ var tests = this.filter_types('min_len', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var n = field_val[tests[i]];
+ if (value.length < n) this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+
+ /// length max check
+ var tests = this.filter_types('max_len', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var n = field_val[tests[i]];
+ if (value.length > n) this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+
+ /// now do match types
+ var tests = this.filter_types('match', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var ref = field_val[tests[i]];
+ ref = (typeof(ref) == 'object') ? ref
+ : (typeof(ref) == 'function') ? new Array(ref)
+ : ref.split(new RegExp('\\s*\\|\\|\\s*'));
+ for (var j = 0; j < ref.length; j ++) {
+ if (typeof(ref[j]) == 'function') {
+ if (! value.match(ref[j])) this.add_error(errors, field, tests[i], field_val, ifs_match);
+ } else {
+ if (! (m = ref[j].match('^\\s*(!\\s*|)m([^\\s\\w])(.*)\\2([eigsmx]*)\\s*$')))
+ return this.error("Not sure how to parse that match ("+ref[j]+")");
+ var not = m[1];
+ var pat = m[3];
+ var opt = m[4];
+ if (opt.indexOf('e') != -1)
+ return this.error("The e option cannot be used on field "+field+", test "+tests[i]);
+ opt = opt.replace(new RegExp('[sg]','g'),'');
+ var regexp = new RegExp(pat, opt);
+ if ( ( not && value.match(regexp))
+ || (! not && ! value.match(regexp))) {
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+ }
+ }
+ }
+
+ /// allow for comparison checks
+ var tests = this.filter_types('compare', types);
+ for (var i = 0; i < tests.length; i ++) {
+ var ref = field_val[tests[i]];
+ ref = (typeof(ref) == 'object') ? ref : ref.split(new RegExp('\\s*\\|\\|\\s*'));
+ for (var j = 0; j < ref.length; j ++) {
+ var comp = ref[j];
+ if (! comp) continue;
+ var hold = false;
+ var copy = value;
+ if (m = comp.match('^\\s*(>|<|[><!=]=)\\s*([\\d\.\-]+)\\s*$')) {
+ if (! copy) copy = 0;
+ copy *= 1;
+ if (m[1] == '>' ) hold = (copy > m[2])
+ else if (m[1] == '<' ) hold = (copy < m[2])
+ else if (m[1] == '>=') hold = (copy >= m[2])
+ else if (m[1] == '<=') hold = (copy <= m[2])
+ else if (m[1] == '!=') hold = (copy != m[2])
+ else if (m[1] == '==') hold = (copy == m[2])
+ } else if (m = comp.match('^\\s*(eq|ne|gt|ge|lt|le)\\s+(.+?)\\s*$')) {
+ m[2] = m[2].replace('^(["\'])(.*)\\1$','$1');
+ if (m[1] == 'gt') hold = (copy > m[2])
+ else if (m[1] == 'lt') hold = (copy < m[2])
+ else if (m[1] == 'ge') hold = (copy >= m[2])
+ else if (m[1] == 'le') hold = (copy <= m[2])
+ else if (m[1] == 'ne') hold = (copy != m[2])
+ else if (m[1] == 'eq') hold = (copy == m[2])
+ } else {
+ return this.error("Not sure how to compare \""+comp+"\"");
+ }
+ if (! hold) this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+ }
+
+ /// do specific type checks
+ var tests = this.filter_types('type',types);
+ for (var i = 0; i < tests.length; i ++)
+ if (! this.check_type(value, field_val[tests[i]], field, form))
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+
+ /// do custom_js type checks
+ // this will allow for a custom piece of javascript
+ // the js is evaluated and should return 1 for success
+ // or 0 for failure - the variables field, value, and field_val (the hash) are available
+ var tests = this.filter_types('custom_js',types);
+ for (var i = 0; i < tests.length; i ++)
+ if (! eval(field_val[tests[i]]))
+ this.add_error(errors, field, tests[i], field_val, ifs_match);
+ }
+
+ /// all done - time to return
+ return errors;
+}
+
+/// used to validate specific types
+function vob_check_type (value, type, field, form) {
+ var m;
+
+ /// do valid email address for our system
+ if (type == 'EMAIL') {
+ if (! value) return 0;
+ if (! (m = value.match('^(.+)\@(.+?)$'))) return 0;
+ if (m[1].length > 60) return 0;
+ if (m[2].length > 100) return 0;
+ if (! this.check_type(m[2],'DOMAIN') && ! this.check_type(m[2],'IP')) return 0;
+ if (! this.check_type(m[1],'LOCAL_PART')) return 0;
+
+ /// 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('(\\.-|-\\.|\\.\\.)')) return 0;
+
+ /// standard IP address
+ } else if (type == 'IP') {
+ if (! value) return 0;
+ var dig = value.split(new RegExp('\\.'));
+ if (dig.length != 4) return 0;
+ for (var i = 0; i < 4; i ++)
+ if (typeof(dig[i]) == 'undefined' || dig[i].match('\\D') || dig[i] > 255) return 0;
+
+ /// domain name - including tld and subdomains (which are all domains)
+ } else if (type == 'DOMAIN') {
+ if (! value) return 0;
+ if (! value.match('^[a-z0-9.-]{4,255}$')) return 0;
+ if (value.match('^[.\\-]')) return 0;
+ if (value.match('(\\.-|-\\.|\\.\\.)')) return 0;
+ if (! (m = value.match('\.([a-z]+)$'))) return 0;
+ value = value.substring(0,value.lastIndexOf('.'));
+
+ if (m[1] == 'name') {
+ if (! value.match('^[a-z0-9][a-z0-9\\-]{0,62}\\.[a-z0-9][a-z0-9\\-]{0,62}$')) return 0;
+ } else
+ if (! value.match('^([a-z0-9][a-z0-9\\-]{0,62}\\.)*[a-z0-9][a-z0-9\\-]{0,62}$')) return 0;
+
+ /// validate a url
+ } else if (type == 'URL') {
+ if (! value) return 0;
+ if (! (m = value.match(new RegExp('^https?://([^/]+)','i'),''))) return 0;
+ value = value.substring(m[0].length);
+ if (! this.check_type(m[1],'DOMAIN') && ! this.check_type(m[1],'IP')) return 0;
+ if (value && ! this.check_type(value,'URI')) return 0;
+
+ /// validate a uri - the path portion of a request
+ } else if (type == 'URI') {
+ if (! value) return 0;
+ if (value.match('\\s')) return 0;
+
+ } else if (type == 'CC') {
+ if (! value) return 0;
+ if (value.match('[^\\d\\- ]') || value.length > 16 || value.length < 13) return;
+ /// simple mod10 check
+ value = value.replace(new RegExp('[\\- ]','g'), '');
+ var sum = 0;
+ var swc = 0;
+
+ for (var i = value.length - 1; i >= 0; i --) {
+ if (++ swc > 2) swc = 1;
+ var y = value.charAt(i) * swc;
+ if (y > 9) y -= 9;
+ sum += y;
+ }
+ if (sum % 10) return 0;
+
+ }
+
+ return 1;
+}
+
+// little routine that will get the values from the form
+// it will return multiple values as an array
+function vob_get_form_value (el) {
+ if (! el) return '';
+ if (el.disabled) return '';
+ var type = el.type ? el.type.toLowerCase() : '';
+ if (el.length && type != 'select-one') {
+ var a = new Array();
+ for (var j=0;j<el.length;j++) {
+ if (type.indexOf('multiple') != -1) {
+ if (el[j].selected) a[a.length] = el[j].value;
+ } else {
+ if (el[j].checked) a[a.length] = vob_get_form_value(el[j]);
+ }
+ }
+ if (a.length == 0) return '';
+ if (a.length == 1) return a[0];
+ return a;
+ }
+ if (! type) return '';
+ if (type == 'hidden' || type == 'password' || type == 'text' || type == 'textarea' || type == 'submit')
+ return el.value;
+ if (type.indexOf('select') != -1) {
+ if (! el.length) return '';
+ return el[el.selectedIndex].value;
+ }
+ if (type == 'checkbox' || type == 'radio') {
+ return el.checked ? el.value : '';
+ }
+ if (type == 'file') {
+ return el.value; // hope this works
+ }
+ alert('Unknown form type for '+el.name+': '+type);
+ return '';
+}
+
+///----------------------------------------------------------------///
+
+function eob_get_val (key, extra2, extra1, _default) {
+ if (typeof(extra2[key]) != 'undefined') return extra2[key];
+ if (typeof(extra1[key]) != 'undefined') return extra1[key];
+ return _default;
+}
+
+function eob_as_string (extra2) {
+ var extra1 = this.extra;
+ if (! extra2) extra2 = new Array();
+
+ var joiner = eob_get_val('as_string_join', extra2, extra1, '\n');
+ var header = eob_get_val('as_string_header', extra2, extra1, '');
+ var footer = eob_get_val('as_string_footer', extra2, extra1, '');
+
+ return header + this.as_array(extra2).join(joiner) + footer;
+}
+
+/// return an array of applicable errors
+function eob_as_array (extra2) {
+ var errors = this.errors;
+ var extra1 = this.extra;
+ if (! extra2) extra2 = new Array();
+
+ var title = eob_get_val('as_array_title', extra2, extra1, 'Please correct the following items:');
+
+ /// if there are heading items then we may end up needing a prefix
+ var has_headings;
+ if (title) has_headings = 1;
+ else {
+ for (var i = 0; i < errors.length; i ++) {
+ if (typeof(errors[i]) != 'string') continue;
+ has_headings = 1;
+ break;
+ }
+ }
+
+ var prefix = eob_get_val('as_array_prefix', extra2, extra1, has_headings ? ' ' : '');
+
+ /// get the array ready
+ var arr = new Array();
+ if (title && title.length) arr[arr.length] = title;
+ /// add the errors
+ var found = new Array();
+ for (var i = 0; i < errors.length; i ++) {
+ if (typeof(errors[i]) == 'string') {
+ arr[arr.length] = errors[i];
+ found = new Array();
+ } else {
+ var text = this.get_error_text(errors[i]);
+ if (found[text]) continue;
+ found[text] = 1;
+ arr[arr.length] = prefix + text;
+ }
+ }
+
+ return arr;
+}
+
+/// return a hash of applicable errors
+function eob_as_hash (extra2) {
+ var errors = this.errors;
+ var extra1 = this.extra;
+ if (! extra2) extra2 = new Array();
+ var suffix = eob_get_val('as_hash_suffix', extra2, extra1, '_error');
+ var joiner = eob_get_val('as_hash_join', extra2, extra1, '<br />');
+
+ /// now add to the hash
+ var found = new Array();
+ var ret = new Array();
+ for (var i = 0; i < errors.length; i ++) {
+ if (typeof(errors[i]) == 'string') continue;
+ if (! errors[i].length) continue;
+
+ var field = errors[i][0];
+ var type = errors[i][1];
+ var field_val = errors[i][2];
+ var ifs_match = errors[i][3];
+
+ if (! field) return alert("Missing field name");
+ if (field_val['delegate_error']) {
+ field = field_val['delegate_error'];
+ field = field.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+ }
+
+ var text = this.get_error_text(errors[i]);
+ if (! found[field]) found[field] = new Array();
+ if (found[field][text]) continue;
+ found[field][text] = 1;
+
+ field += suffix;
+ if (! ret[field]) ret[field] = new Array();
+ ret[field].push(text);
+ }
+
+ /// allow for elements returned as
+ 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;
+ }
+
+ return ret;
+}
+
+/// return a user friendly error message
+function eob_get_error_text (err) {
+ var extra = this.extra;
+ var field = err[0];
+ var type = err[1];
+ var field_val = err[2];
+ var ifs_match = err[3];
+ var m;
+
+ var dig = (m = type.match('(_?\\d+)$')) ? m[1] : '';
+ var type_lc = type.toLowerCase();
+
+ /// allow for delegated field names - only used for defaults
+ if (field_val['delegate_error']) {
+ field = field_val['delegate_error'];
+ field = field.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+ }
+
+ /// the the name of this thing
+ var name = (field_val['name']) ? field_val['name'] : "The field " +field;
+ name = name.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+
+
+ /// type can look like "required" or "required2" or "required100023"
+ /// allow for fallback from required100023_error through required_error
+ var possible_keys = new Array(type + '_error');
+ if (dig.length) possible_keys.unshift(type + dig + '_error');
+
+ /// look in the passed hash or self first
+ for (var i = 0; i < possible_keys.length; i ++) {
+ var key = possible_keys[i];
+ var ret = field_val[key];
+ if (! ret) {
+ if (extra[key]) ret = extra[key];
+ else continue;
+ }
+ ret = ret.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+ ret = ret.replace(new RegExp('\\$field','g'), field);
+ ret = ret.replace(new RegExp('\\$name' ,'g'), name);
+ if (field_val[type + dig] && typeof(field_val[type + dig]) == 'string')
+ ret = ret.replace(new RegExp('\\$value' ,'g'), field_val[type + dig]);
+ return ret;
+ }
+
+ /// set default messages
+ if (type == 'required' || type == 'required_if') {
+ return name + " is required.";
+
+ } else if (type == 'min_values') {
+ var n = field_val["min_values" + dig];
+ var values = (n == 1) ? 'value' : 'values';
+ return name + " had less than "+n+" "+values+".";
+
+ } else if (type == 'max_values') {
+ var n = field_val["max_values" + dig];
+ var values = (n == 1) ? 'value' : 'values';
+ return name + " had more than "+n+" "+values+".";
+
+ } else if (type == 'min_in_set') {
+ var set = field_val["min_in_set" + dig];
+ return "Not enough fields were chosen from the set ("+set+")";
+ return "Too many fields were chosen from the set ("+set+")";
+
+ } else if (type == 'max_in_set') {
+ var set = field_val["max_in_set" + dig];
+ return "Too many fields were chosen from the set ("+set+")";
+
+ } else if (type == 'enum') {
+ return name + " is not in the given list.";
+
+ } else if (type == 'equals') {
+ var field2 = field_val["equals" + dig];
+ var name2 = field_val["equals" +dig+ "_name"];
+ if (! name2) name2 = "the field " +field2;
+ name2 = name2.replace(new RegExp('\\$(\\d+)','g'), function (all, N) {
+ if (typeof(ifs_match) != 'object'
+ || typeof(ifs_match[N]) == 'undefined') return ''
+ return ifs_match[N];
+ });
+ return name + " did not equal " + name2 +".";
+
+ } else if (type == 'min_len') {
+ var n = field_val["min_len"+dig];
+ var chars = (n == 1) ? 'character' : 'characters';
+ return name + " was less than "+n+" "+chars+".";
+
+ } else if (type == 'max_len') {
+ var n = field_val["max_len"+dig];
+ var chars = (n == 1) ? 'character' : 'characters';
+ return name + " was more than "+n+" "+chars+".";
+
+ } else if (type == 'match') {
+ return name + " contains invalid characters.";
+
+ } else if (type == 'compare') {
+ return name + " did not fit comparison.";
+
+ } else if (type == 'type') {
+ var _type = field_val["type"+dig];
+ return name + " did not match type "+_type+".";
+
+ } else if (type == 'custom_js') {
+ return name + " did not match custom_js"+dig+" check.";
+
+ }
+
+ return alert("Missing error on field "+field+" for type "+type+dig);
+}
+
+function eob_first_field () {
+ for (var i = 0; i < this.errors.length; i++) {
+ if (typeof(this.errors[i]) != 'object') continue;
+ if (! this.errors[i][0]) continue;
+ return this.errors[i][0];
+ }
+ return;
+}
+
+///----------------------------------------------------------------///
+
+document.validate = function (form, val_hash) {
+ // undo previous inline
+ if (document.did_inline) {
+ for (var key in document.did_inline) {
+ var el = document.getElementById(key);
+ if (el) el.innerHTML = '';
+ }
+ document.did_inline = undefined;
+ }
+
+ // do the validate
+ val_hash = document.load_val_hash(form, val_hash);
+ if (typeof(val_hash) == 'undefined') return true;
+ if (! document.val_obj) document.val_obj = new Validate();
+ var err_obj = document.val_obj.validate(form, val_hash);
+
+ // return success
+ if (! err_obj) return true;
+
+ // focus
+ var field = err_obj.first_field();
+ if (field && form[field] && form[field].focus) form[field].focus();
+
+ // inline
+ if (! err_obj.extra.no_inline) {
+ var d = document.did_inline = new Array();
+ var hash = err_obj.as_hash();
+ for (var key in hash) {
+ var el = document.getElementById(key);
+ if (el) el.innerHTML = hash[key];
+ d[key] = 1;
+ }
+ }
+
+ // alert
+ if (! err_obj.extra.no_confirm) {
+ return confirm(err_obj.as_string()) ? false : true;
+ } else if (! err_obj.extra.no_alert) {
+ alert(err_obj.as_string());
+ return false;
+ } else if (! err_obj.extra.no_inline) {
+ return false;
+ } else {
+ return true;
+ }
+}
+
+document.load_val_hash = function (form, val_hash) {
+ // check the form we are using
+ if (! form) return alert('Missing form or form name');
+ if (typeof(form) == 'string') {
+ if (! document[form]) return alert('No form by name '+form);
+ form = document[form];
+ }
+
+ // if we already have validation - use it
+ if (form.val_hash) return form.val_hash;
+
+ // load in the validation and save it for future use
+ if (typeof(val_hash) != 'object') {
+ // get the hash from a javascript function
+ if (typeof(val_hash) == 'function') {
+ val_hash = val_hash(formname);
+ } else if (typeof(val_hash) == 'undefined') {
+ var el;
+ // get hash from a global js variable
+ if (typeof(document.validation) != 'undefined') {
+ val_hash = document.validation;
+ // get hash from a element by if of validation
+ } else if (el = document.getElementById('validation')) {
+ val_hash = el.innerHTML;
+ val_hash = val_hash.replace(new RegExp('<', 'ig'),'<');
+ val_hash = val_hash.replace(new RegExp('>', 'ig'),'>');
+ val_hash = val_hash.replace(new RegExp('&','ig'),'&');
+ // read hash from <input name=foo validation="">
+ } else {
+ var order = new Array();
+ var str = '';
+ var yaml = form.getAttribute('validation');
+ if (yaml) {
+ if (m = yaml.match('^( +)')) yaml = yaml.replace(new RegExp('^'+m[1], 'g'), ''); //unindent
+ yaml = yaml.replace(new RegExp('\\s*$',''),'\n'); // add trailing
+ str += yaml;
+ }
+ var m;
+ for (var i = 0; i < form.elements.length; i ++) {
+ var name = form.elements[i].name;
+ var yaml = form.elements[i].getAttribute('validation');
+ if (! name || ! yaml) continue;
+ yaml = yaml.replace(new RegExp('\\s*$',''),'\n'); // add trailing
+ yaml = yaml.replace(new RegExp('^(.)','mg'),' $1'); // indent all
+ yaml = yaml.replace(new RegExp('^( *[^\\s&*\\[\\{])',''),'\n$1'); // add newline
+ str += name +':' + yaml;
+ order[order.length] = name;
+ }
+ if (str) val_hash = str + "group order: [" + order.join(', ') + "]\n";
+ }
+ }
+ if (typeof(val_hash) == 'string') {
+ if (! document.yaml_load) return;
+ document.hide_yaml_errors = (! document.show_yaml_errors);
+ if (location.search && location.search.indexOf('show_yaml_errors') != -1)
+ document.hide_yaml_errors = 0;
+ val_hash = document.yaml_load(val_hash);
+ if (document.yaml_error_occured) return;
+ }
+ }
+
+ // attach to the form
+ form.val_hash = val_hash;
+ return form.val_hash;
+}
+
+
+document.check_form = function (form, val_hash) {
+ // check the form we are using
+ if (! form) return alert('Missing form or form name');
+ if (typeof(form) == 'string') {
+ if (! document[form]) return alert('No form by name '+form);
+ form = document[form];
+ }
+
+ // void call - allow for getting it at run time rather than later
+ document.load_val_hash(form, val_hash);
+
+ // attach handler
+ form.onsubmit = function () {return document.validate(this)};
+}
+
+// the end //
--- /dev/null
+/**----------------------------------------------------------------***
+* Copyright 2003 - Paul Seamons *
+* Distributed under the Perl Artistic License without warranty *
+* Based upon YAML.pm v0.35 from Perl *
+***----------------------------------------------------------------**/
+
+// $Revision: 1.16 $
+
+// allow for missing methods in ie 5.0
+
+if (! Array.prototype.unshift)
+ Array.prototype.unshift = function (add) {
+ for (var i=this.length; i > 0; i--) this[i] = this[i - 1];
+ this[0] = add;
+ };
+
+if (!Array.prototype.shift)
+ Array.prototype.shift = function () {
+ var ret = this[0];
+ for (var i=0; i<this.length-1; i++) this[i] = this[i + 1];
+ this.length -= 1;
+ return ret;
+ };
+
+if (!Array.prototype.push)
+ Array.prototype.push = function (add) {
+ this[this.length] = add;
+ };
+
+// and now - the rest of the library
+
+function YAML () {
+ this.parse = yaml_parse;
+ this.error = yaml_error;
+ this.warn = yaml_warn;
+ this.parse_throwaway = yaml_parse_throwaway;
+ this.parse_node = yaml_parse_node;
+ this.parse_next_line = yaml_parse_next_line;
+ this.parse_qualifiers = yaml_parse_qualifiers;
+ this.parse_explicit = yaml_parse_explicit;
+ this.parse_implicit = yaml_parse_implicit;
+ this.parse_map = yaml_parse_map;
+ this.parse_seq = yaml_parse_seq;
+ this.parse_inline = yaml_parse_inline;
+}
+
+function yaml_error (err) {
+ err += '\nDocument: '+this.document+'\n';
+ err += '\nLine: ' +this.line +'\n';
+ if (! document.hide_yaml_errors) alert(err);
+ document.yaml_error_occured = 1;
+ return;
+}
+
+function yaml_warn (err) {
+ if (! document.hide_yaml_errors) alert(err);
+ return;
+}
+
+function yaml_parse (text) {
+ document.yaml_error_occured = undefined;
+
+ // translate line endings down to \012
+ text = text.replace(new RegExp('\015\012','g'), '\012');
+ text = text.replace(new RegExp('\015','g'), '\012');
+ if (text.match('[\\x00-\\x08\\x0B-\\x0D\\x0E-\\x1F]'))
+ return this.error("Bad characters found");
+ if (text.length && ! text.match('\012$'))
+ text += '\012';
+
+ this.line = 1;
+ this.lines = text.split("\012");
+ this.document = 0;
+ this.documents = new Array();
+
+ this.parse_throwaway();
+ if (! this.eoy && ! this.lines[0].match('^---(\\s|$)')) {
+ this.lines.unshift('--- #YAML:1.0');
+ this.line --;
+ }
+
+ // loop looking for data structures
+ while (! this.eoy) {
+ this.anchors = new Array();
+ this.offset = new Array();
+ this.options = new Array();
+ this.document ++;
+ this.done = 0;
+ this.level = 0;
+ this.offset[0] = -1;
+ this.preface = '';
+ this.content = '';
+ this.indent = -1;
+
+ var m = this.lines[0].match('---\\s*(.*)$')
+ if (! m) return this.error("Missing YAML separator\n("+this.lines[0]+")");
+ var words = m[1].split("\\s+");
+ while (words.length && (m = words[0].match('^#(\\w+):(\\S.*)$'))) {
+ words.shift();
+ if (this.options[m[1]]) {
+ yaml.warn("Parse warn - multiple options " + m[1]);
+ continue;
+ }
+ this.options[m[1]] = m[2];
+ }
+
+ if (this.options['YAML'] && this.options['YAML'] != '1.0')
+ return this.error('Bad YAML version number - must be 1.0');
+ if (this.options['TAB'] && ! this.options['TAB'].match('^(NONE|\\d+)(:HARD)?$'))
+ return this.error('Unrecognized TAB policy');
+
+ this.documents.push(this.parse_node());
+ }
+
+ return this.documents;
+}
+
+function yaml_parse_throwaway () {
+ while (this.lines.length && this.lines[0].match('^\\s*(#|$)')) {
+ this.lines.shift();
+ this.line ++;
+ }
+ this.eoy = this.done = ! this.lines.length;
+}
+
+function yaml_parse_node (no_next) {
+ if (! no_next) this.parse_next_line(2); // COLLECTION
+
+ var preface = this.preface;
+ this.preface = '';
+ var node = '';
+ var type = '';
+ var indicator = '';
+ var escape = '';
+ var chomp = '';
+
+ var info = this.parse_qualifiers(preface);
+ var anchor = info[0];
+ var alias = info[1];
+ var explicit = info[2];
+ var implicit = info[3];
+ var yclass = info[4];
+ preface = info[5];
+
+
+ if (alias) {
+ if (! this.anchors[alias]) return this.error("Parse error - missing alias: "+alias);
+ return this.anchors[alias];
+ }
+
+ // see if this is a literal or an unfold block
+ this.inline = '';
+ if (preface.length) {
+ m = preface.match('^([>\\|])([+\\-]?)\\d*\\s*');
+ if (m) {
+ indicator = m[1];
+ chomp = m[2];
+ preface = preface.substring(0,m[0].length);
+ } else {
+ this.inline = preface;
+ preface = '';
+ }
+ }
+
+
+ if (this.inline.length) {
+ node = this.parse_inline(1, implicit, explicit, yclass);
+ if (this.inline.length) return this.error("Parse error - must be single line ("+this.inline+')');
+ } else {
+ this.level ++;
+ // block items
+ if (indicator) {
+ node = '';
+ while (! this.done && this.indent == this.offset[this.level]) {
+ node += this.content + '\n';
+ this.parse_next_line(1); // LEAF
+ }
+ if (indicator == '>') {
+ node = node.replace(new RegExp('[ \\t]*\n[ \\t]*(\\S)','gm'), ' $1');
+ }
+ if (! chomp || chomp == '-') node = node.replace(new RegExp('\n$',''),'');
+ if (implicit) node = this.parse_implicit(node);
+
+ } else {
+ if (! this.offset[this.level]) this.offset[this.level] = 0;
+ if (this.indent == this.offset[this.level]) {
+ if (this.content.match('^-( |$)')) {
+ node = this.parse_seq(anchor);
+ } else if (this.content.match('(^\\?|:( |$))')) {
+ node = this.parse_map(anchor);
+ } else if (preface.match('^\\s*$')) {
+ node = ''; //this.parse_implicit('');
+ } else {
+ return this.error('Parse error - bad node +('+this.content+')('+preface+')');
+ }
+ } else {
+ node = '';
+ }
+ }
+ this.level --
+ }
+ this.offset = this.offset.splice(0, this.level + 1);
+
+ if (explicit) {
+ if (yclass) return this.error("Parse error - classes not supported");
+ else node = this.parse_explicit(node, explicit);
+ }
+ if (anchor) this.anchors[anchor] = node;
+
+ return node;
+}
+
+function yaml_parse_next_line (type) {
+ var m;
+ var level = this.level;
+ var offset = this.offset[level];
+
+ if (offset == undefined) return this.error("Parse error - Bad level " + level);
+
+ // done with the current line - get the next
+ // remove following commented lines
+ this.lines.shift();
+ this.line ++;
+ this.eoy = this.done = ! this.lines.length;
+ if (this.eoy) return;
+ this.parse_throwaway();
+ if (this.eoy) return;
+
+ // Determine the offset for a new leaf node
+ if (this.preface && (m = this.preface.match('[>\\|][+\\-]?(\\d*)\\s*$'))) {
+ if (m[1].length && m[1] == '0') return this.error("Parse error zero indent");
+ type = 1;
+ if (m[1].length) {
+ this.offset[level + 1] = offset + m[1];
+ } else if ((m = this.lines[0].match('^( *)\\S')) && m[1].length > offset) {
+ this.offset[level + 1] = m[1].length;
+ } else {
+ this.offset[level + 1] = offset + 1;
+ }
+ level ++;
+ offset = this.offset[level];
+ }
+
+ // COLLECTION
+ if (type == 2 && this.preface.match('^\\s*(!\\S*|&\\S+)*\\s*$')) {
+ m = this.lines[0].match('^( *)\\S');
+ if (! m) return this.error("Missing leading space on line "+this.lines[0]);
+ this.offset[level + 1] = (m[1].length > offset) ? m[1].length : offset + 1;
+ offset = this.offset[++ level];
+
+ // LEAF
+ } else if (type == 1) {
+ // skip blank lines and comment lines
+ while (this.lines.length && this.lines[0].match('^\\s*(#|$)')) {
+ m = this.lines[0].match('^( *)');
+ if (! m) return this.error("Missing leading space on comment " + this.lines[0]);
+ if (m[1].length > offset) break;
+ this.lines.shift();
+ this.line ++;
+ }
+ this.eoy = this.done = ! this.lines.length;
+ } else {
+ this.parse_throwaway();
+ }
+
+ if (this.eoy) return;
+ if (this.lines[0].match('^---(\\s|$)')) {
+ this.done = 1;
+ return;
+ }
+
+ if (type == 1 && (m = this.lines[0].match('^ {'+offset+'}(.*)$'))) {
+ this.indent = offset;
+ this.content = m[1];
+ } else if (this.lines[0].match('^\\s*$')) {
+ this.indent = offset;
+ this.content = '';
+ } else {
+ m = this.lines[0].match('^( *)(\\S.*)$');
+ // # yaml.warn(" indent(${\length($1)}) offsets(@{$o->{offset}}) \n");
+ var len = (m) ? m[1].length : 0;
+ while (this.offset[level] > len) level --;
+ if (this.offset[level] != len)
+ return this.error("Parse error inconsitent indentation:\n"
+ + '(this.lines[0]: '+this.lines[0]+', len: '+len+', level: '+level+', this.offset[level]: '+this.offset[level]+')\n');
+
+ this.indent = len;
+ this.content = m ? m[2] : '';
+ }
+
+ if (this.indent - offset > 1)
+ return this.error("Parse error - indentation");
+
+ return;
+}
+
+function yaml_parse_qualifiers (preface) {
+ var info = new Array();
+ // 0 = anchor
+ // 1 = alias
+ // 2 = explicit
+ // 3 = implicit
+ // 4 = class - not used for now
+ // 5 = preface
+
+ var m;
+ while (preface.match('^[&\\*!]')) {
+ // explicit, implicit
+ if (m = preface.match('^\!(\\S*)\\s*')) {
+ preface = preface.substring(m[0].length);
+ if (m[1].length) info[2] = m[1];
+ else info[3] = 1;
+ // anchor, alias
+ } else if (m = preface.match('^([&\\*])([^ ,:]+)\\s*')) {
+ preface = preface.substring(m[0].length);
+ if (! m[2].match('^\\w+$')) return this.error("Bad name "+m[2]);
+ if (info[0] || info[1]) return this.error("Already found anchor or alias "+m[2]);
+ if (m[1] == '&') info[0] = m[2];
+ if (m[1] == '*') info[1] = m[2];
+ }
+ }
+
+ info[5] = preface;
+ return info;
+}
+
+function yaml_parse_explicit (node, explicit) {
+ var m;
+ if (m = explicit.match('^(int|float|bool|date|time|datetime|binary)$')) {
+ // return this.error("No handler yet for explict " + m[1]);
+ // just won't check types for now
+ return node;
+ } else if (m = explicit.match('^perl/(glob|regexp|code|ref):(\\w(\\w|::)*)?$')) {
+ return this.error("No handler yet for perltype " + m[1]);
+ } else if (m = explicit.match('^perl/(\\@|\\$)?([a-zA-Z](\\w|::)+)$')) {
+ return this.error("No handler yet for perl object " + m[1]);
+ } else if (! (m = explicit.match('/'))) {
+ return this.error("Load error - no conversion "+explicit);
+ } else {
+ return this.error("No YAML::Node handler made yet "+explicit);
+ }
+}
+
+function yaml_parse_implicit (value) {
+ value.replace(new RegExp('\\s*$',''),'');
+ if (value == '') return '';
+ if (value.match('^-?\\d+$')) return 0 + value;
+ if (value.match('^[+-]?(\\d*)(\\.\\d*|)?([Ee][+-]?\\d+)?$')) return 1 * value;
+ if (value.match('^\\d{4}\-\\d{2}\-\\d{2}(T\\d{2}:\\d{2}:\\d{2}(\\.\\d*[1-9])?(Z|[-+]\\d{2}(:\\d{2})?))?$')
+ || value.match('^\\w')) return "" + value;
+ if (value == '~') return undefined;
+ if (value == '+') return 1;
+ if (value == '-') return 0;
+ return this.error("Parse Error bad implicit value ("+value+")");
+}
+
+function yaml_parse_map (anchor) {
+ var m;
+ var node = new Array ();
+ if (anchor) this.anchors[anchor] = node;
+
+ while (! this.done && this.indent == this.offset[this.level]) {
+ var key;
+ if (this.content.match('^\\?\\s*')) {
+ this.preface = this.content;
+ key = '' + this.parse_node();
+ } else if (m = this.content.match('^=\\s*')) {
+ this.content = this.content.substring(m[0].length);
+ key = "\x07YAML\x07VALUE\x07";
+ } else if (m = this.content.match('^//\\s*')) {
+ this.content = this.content.substring(m[0].length);
+ key = "\x07YAML\x07COMMENT\x07";
+ } else {
+
+ this.inline = this.content;
+ key = this.parse_inline();
+ this.content = this.inline;
+ this.inline = '';
+ }
+
+ if (! (m = this.content.match('^:\\s*'))) return this.error("Parse error - bad map element "+this.content);
+ this.content = this.content.substring(m[0].length);
+
+ this.preface = this.content;
+
+ var value = this.parse_node();
+
+ if (node[key]) this.warn('Warn - duplicate key '+key);
+ else node[key] = value;
+
+ }
+
+ return node;
+}
+
+function yaml_parse_seq (anchor) {
+ var m;
+ var node = new Array ();
+ if (anchor) this.anchors[anchor] = node;
+ while (! this.done && this.indent == this.offset[this.level]) {
+ var m;
+ if ((m = this.content.match('^- (.*)$')) || (m = this.content.match('^-()$'))) {
+ this.preface = m[1];
+ } else return this.error("Parse error - bad seq element "+this.content);
+
+ if (m = this.preface.match('^(\\s*)(\\w.*:( |$).*)$')) {
+ this.indent = this.offset[this.level] + 2 + m[1].length;
+ this.content = m[2];
+ this.offset[++ this.level] = this.indent;
+ this.preface = '';
+ node.push(this.parse_map(''));
+ this.level --;
+ this.offset[this.offset.length - 1] = this.level;
+ } else {
+ node.push(this.parse_node());
+ }
+ }
+
+ return node;
+}
+
+function yaml_parse_inline (top, top_implicit, top_explicit, top_class) {
+ this.inline = this.inline.replace('^\\s+','').replace(new RegExp('\\s+$',''),'');
+
+ var info = this.parse_qualifiers(this.inline);
+ var anchor = info[0];
+ var alias = info[1];
+ var explicit = info[2];
+ var implicit = info[3];
+ var yclass = info[4];
+ this.inline = info[5];
+ var node;
+ var m;
+
+ // copy the reference
+ if (alias) {
+ if (! this.anchors[alias]) return this.error("Parse error - missing alias: "+alias);
+ node = this.anchors[alias];
+
+ // new key based array
+ } else if (m = this.inline.match('^\\{\\s*')) {
+ this.inline = this.inline.substring(m[0].length);
+ node = new Array ();
+ while (! (m = this.inline.match('^\\}'))) {
+ var key = this.parse_inline();
+ if (! (m = this.inline.match('^:\\s+'))) return this.error("Parse error - bad map element "+this.inline);
+ this.inline = this.inline.substring(m[0].length);
+ var value = this.parse_inline();
+ if (node[key]) this.warn("Warn - duplicate key found: "+key);
+ else node[key] = value;
+ if (this.inline.match('^\\}')) break;
+ if (! (m = this.inline.match('^,\\s*'))) return this.error("Parse error - missing map comma "+this.inline);
+ this.inline = this.inline.substring(m[0].length);
+ }
+ this.inline = this.inline.substring(m[0].length);
+
+ // new array
+ } else if (m = this.inline.match('^\\[\\s*')) {
+ this.inline = this.inline.substring(m[0].length);
+ node = new Array ();
+ while (! (m = this.inline.match('^\\]'))) {
+ node.push(this.parse_inline());
+ if (m = this.inline.match('^\\]')) break;
+ if (! (m = this.inline.match('^,\\s*'))) return this.error("Parse error - missing seq comma "+this.inline);
+ this.inline = this.inline.substring(m[0].length);
+ }
+ this.inline = this.inline.substring(m[0].length);
+
+ // double quoted
+ } else if (this.inline.match('^"')) {
+ if (m = this.inline.match('^"((?:"|[^"])*)"\\s*(.*)$')) {
+ this.inline = m[2];
+ m[1] = m[1].replace(new RegExp('\\\\"','g'),'"');
+ node = m[1];
+ } else {
+ return this.error("Bad double quote "+this.inline);
+ }
+ node = unescape(node); // built in
+ if (implicit || top_implicit) node = this.parse_implicit(node);
+
+ // single quoted
+ } else if (this.inline.match("^'")) {
+ if (m = this.inline.match("^'((?:''|[^'])*)'\\s*(.*)$")) {
+ this.inline = m[2];
+ m[1] = m[1].replace(new RegExp("''",'g'),"'");
+ node = m[1];
+ } else {
+ return this.error("Bad single quote "+this.inline);
+ }
+ node = unescape(node); // built in
+ if (implicit || top_implicit) node = this.parse_implicit(node);
+
+ // simple
+ } else {
+ if (top) {
+ node = this.inline;
+ this.inline = '';
+ } else {
+ if (m = this.inline.match('^([^!@#%^&*,\\[\\]{}\\:]*)')) {
+ this.inline = this.inline.substring(m[1].length);
+ node = m[1];
+ } else {
+ return this.error ("Bad simple match "+this.inline);
+ }
+ if (! explicit && ! top_explicit) node = this.parse_implicit(node);
+ }
+ }
+ if (explicit || top_explicit) {
+ if (! explicit) explicit = top_explicit;
+ if (yclass) return this.error("Parse error - classes not supported");
+ else node = this.parse_explicit(node, explicit);
+ }
+
+ if (anchor) this.anchors[anchor] = node;
+
+ return node;
+}
+
+document.yaml_load = function (text, anchors) {
+ var yaml = new YAML();
+ return yaml.parse(text, anchors);
+}
+
+document.js_dump = function (obj, name) {
+ var t = '';
+ if (! name) {
+ name = '[obj]';
+ t = 'Dump:\n'
+ }
+ if (typeof(obj) == 'function') return name+'=[FUNCTION]\n'
+ if (typeof(obj) != 'object') return name+'='+obj+'\n';
+ var hold = new Array();
+ for (var i in obj) hold[hold.length] = i;
+ hold = hold.sort();
+ for (var i = 0; i < hold.length; i++) {
+ var n = hold[i];
+ t += document.js_dump(obj[n], name +'.'+n);
+ }
+ return t;
+}
+
+// the end
--- /dev/null
+
+BEGIN {
+ print "1..1\n";
+}
+
+use CGI::Ex;
+
+BEGIN { print "ok 1\n"; }
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 4};
+
+use CGI::Ex;
+ok(1);
+
+my $cgix = CGI::Ex->new;
+my $form = {foo => 'bar', this => {is => {nested => ['wow', 'wee']}}};
+
+ok('bar' eq $cgix->swap_template("[% foo %]", $form));
+
+ok('wee' eq $cgix->swap_template("[% this.is.nested.1 %]", $form));
+
+my $str = "[% this.is.nested.0 %]";
+$cgix->swap_template(\$str, $form);
+ok('wow' eq $str);
+
+$cgix = CGI::Ex->new;
+$cgix->set_form({
+ foo => 'bar',
+ baz => 'wow',
+ this => 'wee',
+});
+$str = "<html>([% foo %]) <br>
+([% baz %]) <br>
+([% this %]) </html>";
+$cgix->swap_template(\$str);
+print $str;
+ok($str eq "<html>(bar) <br>
+(wow) <br>
+(wee) </html>");
--- /dev/null
+
+BEGIN {
+ print "1..1\n";
+}
+
+use CGI::Ex::Validate;
+
+BEGIN { print "ok 1\n"; }
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $form = {
+ user => 'abc',
+ pass => '123',
+};
+my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+};
+
+my $err_obj = CGI::Ex->new->validate($form,$val);
+
+if (! $err_obj) {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $form = {
+ user => 'abc',
+# pass => '123',
+};
+my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+};
+
+my $err_obj = CGI::Ex->new->validate($form,$val);
+
+if ($err_obj) {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+use CGI;
+
+print "ok 1\n";
+
+my $form = CGI->new({
+ user => 'abc',
+ pass => '123',
+});
+my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+};
+
+my $err_obj = CGI::Ex->new->validate($form,$val);
+
+if (! $err_obj) {
+ print "ok 2\n";
+} else {
+ warn "$err_obj\n";
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+use CGI;
+
+print "ok 1\n";
+
+my $form = CGI->new({
+ user => 'abc',
+# pass => '123',
+});
+my $val = {
+ user => {
+ required => 1,
+ },
+ pass => {
+ required => 1,
+ },
+};
+
+my $err_obj = CGI::Ex->new->validate($form,$val);
+
+if ($err_obj) {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+
+### required
+$v = {foo => {required => 1}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({foo => 1}, $v);
+&print_ok(! $e);
+
+### validate_if
+$v = {foo => {required => 1, validate_if => 'bar'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({bar => 1}, $v);
+&print_ok($e);
+
+### required_if
+$v = {foo => {required_if => 'bar'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({bar => 1}, $v);
+&print_ok($e);
+
+### max_values
+$v = {foo => {required => 1}};
+$e = &validate({foo => [1,2]}, $v);
+&print_ok($e);
+
+$v = {foo => {max_values => 2}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "str"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => [1]}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => [1,2]}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => [1,2,3]}, $v);
+&print_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,4]}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => [1,2]}, $v);
+&print_ok($e);
+
+$e = &validate({foo => "str"}, $v);
+&print_ok($e);
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+### enum
+$v = {foo => {enum => [1, 2, 3]}, bar => {enum => "1 || 2||3"}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({foo => 1, bar => 1}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => 1, bar => 2}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => 1, bar => 3}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => 1, bar => 4}, $v);
+&print_ok($e);
+
+# equals
+$v = {foo => {equals => 'bar'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => 1}, $v);
+&print_ok($e);
+
+$e = &validate({bar => 1}, $v);
+&print_ok($e);
+
+$e = &validate({foo => 1, bar => 2}, $v);
+&print_ok($e);
+
+$e = &validate({foo => 1, bar => 1}, $v);
+&print_ok(! $e);
+
+$v = {foo => {equals => '"bar"'}};
+$e = &validate({foo => 1, bar => 1}, $v);
+&print_ok($e);
+
+$e = &validate({foo => 'bar', bar => 1}, $v);
+&print_ok(! $e);
+
+### min_len
+$v = {foo => {min_len => 10}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({foo => ""}, $v);
+&print_ok($e);
+
+$e = &validate({foo => "123456789"}, $v);
+&print_ok($e);
+
+$e = &validate({foo => "1234567890"}, $v);
+&print_ok(! $e);
+
+### max_len
+$v = {foo => {max_len => 10}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => ""}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "1234567890"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "12345678901"}, $v);
+&print_ok($e);
+
+### match
+$v = {foo => {match => qr/^\w+$/}};
+$e = &validate({foo => "abc"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "abc."}, $v);
+&print_ok($e);
+
+$v = {foo => {match => [qr/^\w+$/, qr/^[a-z]+$/]}};
+$e = &validate({foo => "abc"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "abc1"}, $v);
+&print_ok($e);
+
+$v = {foo => {match => 'm/^\w+$/'}};
+$e = &validate({foo => "abc"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "abc."}, $v);
+&print_ok($e);
+
+$v = {foo => {match => 'm/^\w+$/ || m/^[a-z]+$/'}};
+$e = &validate({foo => "abc"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "abc1"}, $v);
+&print_ok($e);
+
+$v = {foo => {match => '! m/^\w+$/'}};
+$e = &validate({foo => "abc"}, $v);
+&print_ok($e);
+
+$e = &validate({foo => "abc."}, $v);
+&print_ok(! $e);
+
+$v = {foo => {match => 'm/^\w+$/'}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$v = {foo => {match => '! m/^\w+$/'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+### compare
+$v = {foo => {compare => '> 0'}};
+$e = &validate({}, $v);
+&print_ok($e);
+$v = {foo => {compare => '== 0'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+$v = {foo => {compare => '< 0'}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => '> 10'}};
+$e = &validate({foo => 11}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 10}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => '== 10'}};
+$e = &validate({foo => 11}, $v);
+&print_ok($e);
+$e = &validate({foo => 10}, $v);
+&print_ok(! $e);
+
+$v = {foo => {compare => '< 10'}};
+$e = &validate({foo => 9}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 10}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => '>= 10'}};
+$e = &validate({foo => 10}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 9}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => '!= 10'}};
+$e = &validate({foo => 10}, $v);
+&print_ok($e);
+$e = &validate({foo => 9}, $v);
+&print_ok(! $e);
+
+$v = {foo => {compare => '<= 10'}};
+$e = &validate({foo => 11}, $v);
+&print_ok($e);
+$e = &validate({foo => 10}, $v);
+&print_ok(! $e);
+
+
+$v = {foo => {compare => 'gt ""'}};
+$e = &validate({}, $v);
+&print_ok($e);
+$v = {foo => {compare => 'eq ""'}};
+$e = &validate({}, $v);
+&print_ok(! $e);
+$v = {foo => {compare => 'lt ""'}};
+$e = &validate({}, $v);
+&print_ok($e); # 68
+
+$v = {foo => {compare => 'gt "c"'}};
+$e = &validate({foo => 'd'}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 'c'}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => 'eq c'}};
+$e = &validate({foo => 'd'}, $v);
+&print_ok($e);
+$e = &validate({foo => 'c'}, $v);
+&print_ok(! $e);
+
+$v = {foo => {compare => 'lt c'}};
+$e = &validate({foo => 'b'}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 'c'}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => 'ge c'}};
+$e = &validate({foo => 'c'}, $v);
+&print_ok(! $e);
+$e = &validate({foo => 'b'}, $v);
+&print_ok($e);
+
+$v = {foo => {compare => 'ne c'}};
+$e = &validate({foo => 'c'}, $v);
+&print_ok($e);
+$e = &validate({foo => 'b'}, $v);
+&print_ok(! $e);
+
+$v = {foo => {compare => 'le c'}};
+$e = &validate({foo => 'd'}, $v);
+&print_ok($e);
+$e = &validate({foo => 'c'}, $v);
+&print_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);
+
+$n = 0;
+$v = {foo => {custom => $n}};
+$e = &validate({}, $v);
+&print_ok($e);
+$e = &validate({foo => "str"}, $v);
+&print_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);
+
+### 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);
+
+### 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);
+$v = {foo => {min_in_set => '2 foo bar baz', max_values => 5}};
+$e = &validate({foo => 1, bar => 1}, $v);
+&print_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);
+
+### validate_if revisited (but negated - uses max_in_set)
+$v = {foo => {required => 1, validate_if => '! bar'}};
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({bar => 1}, $v);
+&print_ok(! $e);
+
+### default value
+my $f = {};
+$v = {foo => {required => 1, default => 'hmmmm'}};
+$e = &validate($f, $v);
+&print_ok(! $e);
+
+&print_ok($f->{foo} && $f->{foo} eq 'hmmmm');
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### three groups, some with validate_if's
+$v = [{
+ 'group validate_if' => 'foo',
+ bar => {required => 1},
+},
+{
+ 'group validate_if' => 'hem',
+ haw => {required => 1},
+},
+{
+ raspberry => {required => 1},
+}];
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### single group
+$v = '
+user:
+ required: 1
+foo:
+ 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);
+
+
+### three groups, some with validate_if's - using arrayref
+$v = '
+- group validate_if: foo
+ bar:
+ required: 1
+- group validate_if: hem
+ haw: { required: 1 }
+- raspberry:
+ required: 1
+';
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+
+### three groups, some with validate_if's - using documents
+$v = '---
+group validate_if: foo
+bar:
+ required: 1
+---
+group validate_if: hem
+haw: { required: 1 }
+---
+raspberry:
+ required: 1
+';
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### where are my samples
+my $dir = __FILE__;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$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);
+
+
+### 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);
+
+
+### three groups, some with validate_if's - using arrayref
+$v = "$dir/yaml2.val";
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+
+### three groups, some with validate_if's - using documents
+$v = "$dir/yaml3.val";
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### where are my samples
+my $dir = __FILE__;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$dir =~ s|[^/]+$|samples| || die "Couldn't determine dir";
+$dir =~ s|^t/|./t/|; # to satisfy conf
+
+### single group
+$v = "$dir/perl1.pl";
+
+$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);
+
+
+### three groups, some with validate_if's - using arrayref
+$v = "$dir/perl2.pl";
+
+$e = &validate({}, $v);
+&print_ok($e);
+
+$e = &validate({
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok($e);
+
+$e = &validate({
+ foo => 1,
+ bar => 1,
+ hem => 1,
+ haw => 1,
+ raspberry => 'tart',
+}, $v);
+&print_ok(! $e);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### where are my samples
+my $dir = __FILE__;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$dir =~ s|[^/]+$|samples| || die "Couldn't determine dir";
+$dir =~ s|^t/|./t/|; # to satisfy conf
+
+### single group
+$v = "$dir/storable1.storable";
+
+### don't use the included binary - write our own - for portable tests
+my $val = {
+ user => {
+ required => 1,
+ },
+ foo => {
+ required_if => 'bar',
+ },
+};
+&print_ok(eval {require Storable});
+&print_ok(&Storable::store($val, $v));
+
+$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);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### test single group for extra fields
+$v = [
+{
+ 'general no_extra_fields' => 'all',
+ foo => {max_len => 10},
+},
+];
+
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "foo"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "foo", bar => "bar"}, $v);
+&print_ok($e);
+
+$e = &validate({bar => "bar"}, $v);
+&print_ok($e);
+
+
+### test on failed validate if
+$v = [
+{
+ 'general no_extra_fields' => 'all',
+ 'group validate_if' => 'baz',
+ foo => {max_len => 10},
+},
+];
+
+$e = &validate({}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "foo"}, $v);
+&print_ok(! $e);
+
+$e = &validate({foo => "foo", bar => "bar"}, $v);
+&print_ok(! $e);
+
+$e = &validate({bar => "bar"}, $v);
+&print_ok(! $e);
+
+### test on successful validate if
+$v = [
+{
+ 'general no_extra_fields' => 'all',
+ 'group validate_if' => 'baz',
+ foo => {max_len => 10},
+ baz => {max_len => 10},
+},
+];
+
+$e = &validate({baz => 1}, $v);
+&print_ok(! $e);
+
+$e = &validate({baz => 1, foo => "foo"}, $v);
+&print_ok(! $e);
+
+$e = &validate({baz => 1, foo => "foo", bar => "bar"}, $v);
+&print_ok($e);
+
+$e = &validate({baz => 1, bar => "bar"}, $v);
+&print_ok($e);
+
+### test on multiple groups, some with validate if
+$v = [
+{
+ 'general no_extra_fields' => 'all',
+ 'group validate_if' => 'baz',
+ foo => {max_len => 10},
+ baz => {max_len => 10},
+},
+{
+ 'group validate_if' => 'hem',
+ haw => {max_len => 10},
+},
+];
+
+$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, foo => "foo", bar => "bar"}, $v);
+&print_ok($e);
+
+$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v);
+&print_ok($e);
+
+
+### test on multiple groups, some with validate if
+$v = [
+{
+ 'general no_extra_fields' => 'used',
+ 'group validate_if' => 'baz',
+ foo => {max_len => 10},
+ baz => {max_len => 10},
+},
+{
+ 'group validate_if' => 'hem',
+ haw => {max_len => 10},
+},
+];
+
+$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, foo => "foo", bar => "bar"}, $v);
+&print_ok($e);
+
+$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v);
+&print_ok($e);
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+$v = [
+{
+ foo => {
+ max_len => 10,
+ replace => 's/[^\d]//g',
+ },
+},
+];
+
+$e = &validate({
+ foo => '123-456-7890',
+}, $v);
+&print_ok(! $e);
+
+
+my $form = {
+ key1 => 'Bu-nch @of characte#rs^',
+ key2 => '123 456 7890',
+};
+
+
+$v = {
+ key1 => {
+ replace => 's/[^\s\w]//g',
+ },
+};
+
+$e = &validate($form, $v);
+&print_ok(! $e && $form->{key1} eq 'Bunch of characters');
+
+$v = {
+ key2 => {
+ replace => 's/(\d{3})\D*(\d{3})\D*(\d{4})/($1) $2-$3/g',
+ },
+};
+
+$e = &validate($form, $v);
+&print_ok(! $e && $form->{key2} eq '(123) 456-7890');
+
+
+$v = {
+ key2 => {
+ replace => 's/.+//g',
+ required => 1,
+ },
+};
+
+$e = &validate($form, $v);
+&print_ok($e && $form->{key2} eq '');
+
+__DATA__
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+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);
+
+###----------------------------------------------------------------###
+
+### where are my samples
+my $dir = __FILE__;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$dir =~ s|[^/]+$|samples| || die "Couldn't determine dir";
+$dir =~ s|^t/|./t/|; # to satisfy conf
+
+### single group
+$v = "$dir/html1.htm";
+
+$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);
+
+
+### three groups, some with validate_if's - using arrayref
+$v = "$dir/html2.htm";
+
+$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);
+
+__DATA__
--- /dev/null
+#!perl -T
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+### Set up taint checking
+sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 } }
+
+my $taint = join(",", $0, %ENV, @ARGV);
+if (! is_tainted($taint) && open(my $fh, "/dev/urandom")) {
+ sysread($fh, $taint, 1);
+}
+$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;
+}
+
+### make sure tainted hash values don't bleed into other values
+my $form = {};
+$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;
+}
+
+###----------------------------------------------------------------###
+### 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";
+
+require CGI::Ex::Validate;
+
+my ($N, $v, $e, $ok) = (0);
+
+
+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, {
+ foo => {
+ match => 'm/^\d+$/',
+ untaint => 1,
+ },
+});
+
+print_ok(! $e);
+print_ok(! is_tainted($form->{foo}));
+
+###----------------------------------------------------------------###
+
+$e = &validate($form, {
+ bar => {
+ match => 'm/^\d+$/',
+ },
+});
+
+print_ok(! $e);
+print_ok(is_tainted($form->{bar}));
+
+###----------------------------------------------------------------###
+
+$e = &validate($form, {
+ bar => {
+ untaint => 1,
+ },
+});
+
+print_ok($e);
+#print $e if $e;
+print_ok(is_tainted($form->{bar}));
+
+###----------------------------------------------------------------###
+
+print_ok(!is_tainted($form->{foo}));
+print_ok( is_tainted($form->{bar}));
+print_ok(!is_tainted($form->{baz}));
+
+__DATA__
--- /dev/null
+
+BEGIN {
+ print "1..1\n";
+}
+
+use CGI::Ex::Fill;
+
+BEGIN { print "ok 1\n"; }
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $hidden_form_in = '
+<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);
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $hidden_form_in = qq{<input type="checkbox" name="foo1" value="bar1">
+<input type="checkbox" name="foo1" value="bar2">
+<input type="checkbox" name="foo1" value="bar3">
+<input type="checkbox" name="foo2" value="bar1">
+<input type="checkbox" name="foo2" value="bar2">
+<input type="checkbox" name="foo2" value="bar3">
+<input type="checkbox" name="foo3" value="bar1">
+<input type="checkbox" name="foo3" checked value="bar2">
+<input type="checkbox" name="foo3" value="bar3">
+<input type="checkbox" name="foo4" value="bar1">
+<input type="checkbox" name="foo4" checked value="bar2">
+<input type="checkbox" name="foo4" value="bar3">
+<input type="checkbox" name="foo5">
+<input type="checkbox" name="foo6">
+<input type="checkbox" name="foo7" checked>
+<input type="checkbox" name="foo8" checked>};
+
+my %fdat = (foo1 => 'bar1',
+ foo2 => ['bar1', 'bar2',],
+ foo3 => '',
+ foo5 => 'on',
+ foo6 => '',
+ foo7 => 'on',
+ foo8 => '');
+
+my $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fdat => \%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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..5\n";
+
+use CGI::Ex;
+use CGI;
+
+print "ok 1\n";
+
+my $hidden_form_in = qq{<select multiple name="foo1">
+ <option value="0">bar1</option>
+ <option value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo2">
+ <option value="bar1">bar1</option>
+ <option value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo3">
+ <option value="bar1">bar1</option>
+ <option selected value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo4">
+ <option value="bar1">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 $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fobject => $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";
+}
+
+$hidden_form_in = qq{<select multiple name="foo1">
+ <option>bar1</option>
+ <option>bar2</option>
+ <option>bar3</option>
+</select>
+<select multiple name="foo2">
+ <option> bar1</option>
+ <option> bar2</option>
+ <option>bar3</option>
+</select>
+<select multiple name="foo3">
+ <option>bar1</option>
+ <option selected>bar2</option>
+ <option>bar3</option>
+</select>
+<select multiple name="foo4">
+ <option>bar1</option>
+ <option selected>bar2</option>
+ <option>bar3 </option>
+</select>};
+
+$q = new CGI( { foo1 => 'bar1',
+ foo2 => ['bar1', 'bar2',],
+ foo3 => '' }
+ );
+
+$fif = new CGI::Ex;
+$output = $fif->fill(scalarref => \$hidden_form_in,
+ fobject => $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";
+}
+
+# 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";
+}
+
+$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";
+}
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..3\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+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";
+}
+
+# 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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $hidden_form_in = qq{<INPUT TYPE="radio" NAME="foo1" value="bar1">
+<input type="radio" name="foo1" value="bar2">
+<input type="radio" name="foo1" value="bar3">
+<input type="radio" name="foo1" checked value="bar4">};
+
+my %fdat = (foo1 => 'bar2');
+
+my $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fdat => \%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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+use CGI;
+
+print "ok 1\n";
+
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+print "1..1\n";
+use CGI::Ex;
+
+my $html =<<"__HTML__";
+<HTML>
+<BODY>
+<FORM action="test.cgi" method="POST">
+<INPUT type="hidden" name="hidden" value=">"">
+<INPUT type="text" name="text" value="<>"õ"><BR>
+<INPUT type="radio" name="radio" value=""<>">test<BR>
+<INPUT type="checkbox" name="checkbox" value=""<>">test<BR>
+<INPUT type="checkbox" name="checkbox" value=""><>">test<BR>
+<SELECT name="select">
+<OPTION value="<>"><>
+<OPTION value=">>">>>
+<OPTION value="õ"><<
+<OPTION>>>>
+</SELECT><BR>
+<TEXTAREA name="textarea" rows="5"><>"</TEXTAREA><P>
+<INPUT type="submit" value=" OK ">
+</FORM>
+</BODY>
+</HTML>
+__HTML__
+
+my %fdat = ();
+
+my $fif = CGI::Ex->new;
+my $output = $fif->fill(scalarref => \$html,
+ fdat => \%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";
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+use Test;
+BEGIN { plan tests => 3 }
+
+use CGI::Ex;
+
+my $form = <<EOF;
+<FORM name="foo1">
+<INPUT TYPE="TEXT" NAME="foo1" value="nada">
+</FORM>
+<FORM name="foo2">
+<INPUT TYPE="TEXT" NAME="foo2" value="nada">
+</FORM>
+<FORM>
+<INPUT TYPE="TEXT" NAME="foo3" value="nada">
+</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 @v = $output =~ m/<input .*?value="(.*?)"/ig;
+ok($v[0], 'nada');
+ok($v[1], 'bar2');
+ok($v[2], 'nada');
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..3\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+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";
+}
+
+%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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+#!/usr/bin/perl -w
+
+# 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}>!);
--- /dev/null
+# -*- Mode: Perl; -*-
+
+#!/usr/bin/perl -w
+
+use CGI qw(:no_debug);
+use CGI::Ex;
+use Test;
+
+BEGIN { plan tests => 2 }
+
+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"/);
+}
+
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+print "ok 1\n";
+
+my $hidden_form_in = qq{<input type="hidden" name="foo">
+<input type="hidden" name="foo" value="ack">};
+
+my %fdat = (foo => 'bar1a');
+
+my $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fdat => \%fdat);
+if ($output =~ m/^<input( (type="hidden"|name="foo"|value="bar1a")){3}>\s*<input( (type="hidden"|name="foo"|value="bar1a")){3}>$/){
+ print "ok 2\n";
+} else {
+ print "Got unexpected out for hidden form:\n$output\n";
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+use CGI;
+
+print "ok 1\n";
+
+my $hidden_form_in = qq{<select multiple name="foo1">
+ <option value="0">bar1</option>
+ <option value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo2">
+ <option value="bar1">bar1</option>
+ <option value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo3">
+ <option value="bar1">bar1</option>
+ <option selected value="bar2">bar2</option>
+ <option value="bar3">bar3</option>
+</select>
+<select multiple name="foo4">
+ <option value="bar1">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 $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fobject => $q,
+ ignore_fields => ['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";
+}
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..1\n";
+
+use CGI::Ex;
+use CGI;
+
+my $html = <<EOF;
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
+<html>
+<body>
+ <input type="radio" name="status" value=0 />Canceled<br>
+ <input type="radio" name="status" value=1 />Confirmed<br>
+ <input type="radio" name="status" value=2 />Wait List<br>
+
+ <input type="radio" name="status" value=3 />No Show<br>
+ <input type="radio" name="status" value=4 />Moved to Another Class<br>
+ <input type="radio" name="status" value=5 />Late Cancel<br>
+</body>
+</html>
+EOF
+
+my $q = CGI->new;
+$q->param('status', 1 );
+
+my $fif = CGI::Ex->new;
+
+my $output = $fif->fill(
+ scalarref => \$html,
+ fobject => $q
+);
+
+my $matches;
+while ($output =~ m!( />)!g) {
+ $matches++;
+}
+
+if ($matches == 6) {
+ print "ok 1\n";
+} else {
+ print "not ok 1\n";
+}
+
+print $output;
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..4\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $ok2 = 0;
+my $ok3 = 0;
+
+my $hidden_form_in = qq{<input type="hidden" name="foo1">
+<input type="hidden" name="foo2" value="ack">};
+
+my %fdat = (foo1 => sub { $ok2 ++; return 'bar1' },
+ );
+my $cdat = sub {
+ $ok3 ++;
+ my $key = shift;
+ return ($key eq 'foo2') ? 'bar2' : '';
+};
+
+my $fif = new CGI::Ex;
+my $output = $fif->fill(scalarref => \$hidden_form_in,
+ fdat => [\%fdat, $cdat]);
+
+print "" . ($ok2 ? "" : "not ") . "ok 2\n";
+print "" . ($ok3 ? "" : "not ") . "ok 3\n";
+
+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";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+
+$^W = 1;
+
+print "1..2\n";
+
+use CGI::Ex;
+
+print "ok 1\n";
+
+my $string = qq{
+<input attr="<br value='waw'>
+<br>" type="hidden" name="foo1">
+};
+
+my %fdat = (foo1 => 'bar1');
+
+
+my $cgix = new CGI::Ex;
+$cgix->fill(text => \$string,
+ form => \%fdat,
+ );
+
+if ($string =~ m/ value="bar1"/) {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+}
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use strict;
+$^W = 1;
+print "1..27\n";
+use CGI::Ex;
+print "ok 1\n";
+
+
+my $string;
+my %fdat = (foo1 => 'bar1');
+my $cgix = new CGI::Ex;
+my $n = 1;
+my $dook = sub {
+ $n ++;
+ print "$n - ($string)\n";
+ 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";
+ }
+};
+
+###----------------------------------------------------------------###
+
+$string = qq{<input name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input name=foo1>};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input name=foo1 />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value value name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value value="" name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input grrr name="foo1" value="">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value= name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input type=hidden value= name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value= type="hidden" name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value="" name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value='' name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input value='one' name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input Value="one" name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input VALUE="one" name="foo1">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<input name="foo1" value="one">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="one">};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="one" >};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="" >};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE= >};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE >};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE= />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="" />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="one" />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+$string = qq{<INPUT NAME="foo1" VALUE="one" />};
+$cgix->fill(text => \$string, form => \%fdat);
+&$dook();
+
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 24};
+
+use CGI::Ex::Conf;
+ok(1);
+
+my $dir = $0;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$dir =~ s|/[^/]+$||;
+$dir = '.' if ! length $dir;
+$dir .= '/samples';
+my $obj = CGI::Ex::Conf->new({
+ paths => ["$dir/conf_path_1", "$dir/conf_path_3"],
+});
+
+### most test for the reading of files
+### are actually performed in the validation tests
+
+ok($obj);
+
+my $hash = $obj->read('apples.pl');
+ok($hash);
+ok($hash->{quantity});
+
+$hash = $obj->read('apples.pl');
+ok($hash);
+ok($hash->{quantity});
+
+
+local $CGI::Ex::Conf::DIRECTIVE = 'FIRST';
+$hash = $obj->read('apples.pl');
+ok($hash);
+ok($hash->{quantity} == 20);
+ok($hash->{foo} eq 'file1');
+
+local $CGI::Ex::Conf::DIRECTIVE = 'LAST';
+$hash = $obj->read('apples.pl');
+ok($hash);
+ok($hash->{quantity} == 30);
+ok($hash->{foo} eq 'file2');
+
+$hash = $obj->read('apples.pl', {directive => 'MERGE'});
+ok($hash);
+ok($hash->{quantity} == 30);
+ok($hash->{foo} eq 'file1'); # has immutable value
+
+
+local $obj->{directive} = 'FIRST';
+$hash = $obj->read('oranges.pl');
+ok($hash);
+ok($hash->{quantity} == 20);
+ok($hash->{foo} eq 'file1');
+
+local $obj->{directive} = 'LAST';
+$hash = $obj->read('oranges.pl');
+ok($hash);
+ok($hash->{quantity} == 30);
+ok($hash->{foo} eq 'file2');
+
+local $obj->{directive} = 'MERGE';
+$hash = $obj->read('oranges.pl');
+ok($hash);
+ok($hash->{quantity} == 20); # has immutable key so all values are immutable
+ok($hash->{foo} eq 'file1'); # has immutable key so all values are immutable
+
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 12};
+
+use CGI::Ex::Conf;
+ok(1);
+
+my $dir = $0;
+$dir =~ tr|\\|/|; # should probably use File::Spec
+$dir =~ s|/[^/]+$||;
+$dir = '.' if ! length $dir;
+$dir .= '/samples';
+my $obj = CGI::Ex::Conf->new({
+ paths => ["$dir/conf_path_1", "$dir/conf_path_3"],
+});
+
+my $tmpfile = "$obj->{paths}->[0]/write_test";
+### most test for the reading of files
+### are actually performed in the validation tests
+
+ok($obj);
+
+my $hash = {
+ one => 1,
+ two => 2,
+ three => {
+ foo => 'Foo',
+ 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;
+
+$file = $tmpfile .'.pl';
+ok( eval { $obj->write_ref($file, $hash) } );
+$in = $obj->read_ref($file);
+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');
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 2};
+
+use CGI::Ex::App;
+ok(1);
+
+my $obj = CGI::Ex::App->new({
+});
+ok($obj);
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 1};
+
+use CGI::Ex::Dump ();
+ok(1);
+
--- /dev/null
+# -*- Mode: Perl; -*-
+
+use Test;
+
+BEGIN {plan tests => 2};
+
+use CGI::Ex::Die;
+ok(1);
+
+ok(eval {
+ import CGI::Ex::Die register => 1;
+ $SIG{__DIE__} eq \&CGI::Ex::Die::die_handler;
+});
--- /dev/null
+#!/usr/bin/perl -w
+
+# [pauls@localhost lib]$ perl ../t/samples/bench_cgix_hfif.pl
+# 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 $n = 1000;
+
+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($n, {
+ 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;
+
+
+### 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);
+use CGI::Ex::Conf;
+use POSIX qw(tmpnam);
+
+$PLACEHOLDER = chr(186).'~'.chr(186);
+
+my $n = -2;
+
+my $cob = CGI::Ex::Conf->new;
+my %files = ();
+
+###----------------------------------------------------------------###
+
+# [pauls@localhost lib]$ perl ../t/samples/bench_conf_readers.pl
+# 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 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($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
+
+if (__FILE__ eq $0) {
+ &handler();
+}
+
+###----------------------------------------------------------------###
+
+use strict;
+use CGI::Ex;
+use CGI::Ex::Validate ();
+use CGI::Ex::Fill ();
+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|^/+||;
+ CGI::Ex->new->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
+ &CGI::Ex::print_content_type();
+ print $content;
+ return;
+ }
+
+
+ ### show some sort of success if there were no errors
+ &CGI::Ex::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
+
+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';
+ }
+}
+
+sub userinfo_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_form {
+ 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 hash_common {
+ return {
+ title => 'My Application',
+ script => $ENV{SCRIPT_NAME},
+ color => ['#ccf', '#aaf'],
+ }
+}
+
+sub print {
+ my $self = shift;
+ my $step = shift;
+ my $form = shift;
+ my $fill = shift;
+
+ my $content = ($step eq 'userinfo') ? &get_content_form()
+ : ($step eq 'main') ? &get_content_success()
+ : "Don't have content for step \"$step\"";
+
+ $self->cgix->swap_template(\$content, $form);
+ $self->cgix->fill(\$content, $fill);
+
+ $self->cgix->print_content_type();
+ print $content;
+}
+
+### this works because we added /js onto $ENV{SCRIPT_NAME} above near js_val
+sub js_pre_step {
+ my $self = shift;
+ my $info = $ENV{PATH_INFO} || '';
+ if ($info =~ m|^/js(/\w+)+.js$|) {
+ $info =~ s|^/+js/+||;
+ $self->cgix->print_js($info);
+ return 1;
+ }
+ return 0;
+}
+
+
+###----------------------------------------------------------------###
+
+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
+{
+ 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
+#!/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
+### 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
+### this yaml will return an arrayref containing three hashrefs
+### this shows three groups
+### the first two groups have validate_if's
+[
+ {
+ 'group validate_if' => 'foo',
+ bar => {
+ required => 1,
+ },
+ },
+ {
+ 'group validate_if' => 'hem',
+ haw => { required => 1 },
+ },
+ {
+ raspberry => {
+ required => 1,
+ },
+ },
+];
--- /dev/null
+### this file is very simplistic
+### but it shows how easy the file can be
+user:
+ required: 1
+foo:
+ required_if: bar
+
+### you could also do
+# user: {required: 1}
+# foo: {required: 1}
--- /dev/null
+### this yaml will return an arrayref containing three hashrefs
+### this shows three groups
+### the first two groups have validate_if's
+- group validate_if: foo
+ bar:
+ required: 1
+- group validate_if: hem
+ haw: { required: 1 }
+- raspberry:
+ required: 1
--- /dev/null
+### this file is the same as yaml2.val
+### except that the groups are separated as documents rather than as
+### an arrayref
+
+---
+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
projects / chaz / p5-CGI-Ex / commitdiff
