From: Paul Seamons Date: Mon, 28 Feb 2005 00:00:00 +0000 (+0000) Subject: CGI::Ex 1.14 X-Git-Tag: v1.14 X-Git-Url: https://git.brokenzipper.com/gitweb?a=commitdiff_plain;h=85070b46d0a93ddbeef07341421adb8389a55418;p=chaz%2Fp5-CGI-Ex CGI::Ex 1.14 --- 85070b46d0a93ddbeef07341421adb8389a55418 diff --git a/CGI-Ex.spec b/CGI-Ex.spec new file mode 100644 index 0000000..95d516b --- /dev/null +++ b/CGI-Ex.spec @@ -0,0 +1,64 @@ +%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 diff --git a/Changes b/Changes new file mode 100644 index 0000000..0f19564 --- /dev/null +++ b/Changes @@ -0,0 +1,101 @@ +2005-02-28 Paul Seamons + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * Version 0.94 is done + * Javascript functionality is in. + +2003-11-01 Paul Seamons + + * Version 0.0 checked in diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..177b5f4 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,89 @@ +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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..94bd9c4 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,14 @@ +CVS/ +^tgz/ +\.~$ +\.# +\w#$ +\.bak$ +Makefile$ +Makefile\.old$ +blib +\.gz$ +.cvsignore +tmon\.out +t/samples/template +wrap \ No newline at end of file diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..0bb9c37 --- /dev/null +++ b/META.yml @@ -0,0 +1,10 @@ +# 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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..8ac2254 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,42 @@ +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; diff --git a/README b/README new file mode 100644 index 0000000..8591b87 --- /dev/null +++ b/README @@ -0,0 +1,370 @@ +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 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 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 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 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("[% foo %]
[% foo %]", $form)); + # $str eq 'bar
bar' + + $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 = "([% foo %])
+ ([% baz %])
+ ([% this %]) "; + $cgix->swap_template(\$str); + #$str eq "(bar)
+ # (wow)
+ # (wee) "; + + 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. + diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm new file mode 100644 index 0000000..cbc5a34 --- /dev/null +++ b/lib/CGI/Ex.pm @@ -0,0 +1,1176 @@ +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 "Location: $loc
\n"; + } else { + print "\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 "\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 "\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 "

JS File not found for print_js

\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 ; + 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 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 + +A regular expression based form filler inner (accessed through B<-Efill> +or directly via its own functions). Can be a drop in replacement for +HTML::FillInForm. See L for more information. + +=item C + +A form field / cgi parameter / any parameter validator (accessed through +B<-Evalidate> 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 for more information. + +=item C + +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 for more information. + +=back + +=head1 METHODS + +=over 4 + +=item C<-Efill> + +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 for +a full explanation of functionality). The arguments to fill are as +follows (and in order of position): + +=over 4 + +=item C + +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 is available if you would like to +copy rather than modify. + +=item C
+ +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 (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 + +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 + +Boolean value defaults to 1. If set to zero - password fields will +not be filled. + +=item C + +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 + +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 + +An array ref of lines of the document. Forces a returned filled html +document. + +=item C + +An filename that will be opened, filled, and returned. + +=item C + +A hashref of key value pairs. + +=item C + +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. + +=back + +See L for more information about the filling process. + +=item C<-Eobject> + +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. + +=item C<-Evalidate> + +Validate has a wide range of options available. (See L +for a full explanation of functionality). Validate has two arguments: + +=over 4 + +=item C + +Can be either a hashref to be validated, or a CGI style object (which +has the param method). + +=item C + +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<-Eget_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<-Eset_form> + +Allow for setting a custom form hash. Useful for testing, or other +purposes. + +=item C<-Eget_cookies> + +Returns a hash of all cookies. + +=item C<-Emake_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<-Econtent_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 -Econtent_type is an error. For clarity, +the method -Eprint_content_type is available. + +=item C<-Eset_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 +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<-Elocation_bounce> + +Depending on if content has already been sent to the browser will either print +a Location header, or will add a +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<-Elast_modified> + +Depending on if content has already been sent to the browser will either print +a Last-Modified header, or will add a +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<-Eexpires> + +Depending on if content has already been sent to the browser will either print +a Expires header, or will add a +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<-Esend_status> + +Send a custom status. Works in both CGI and mod_perl. Arguments are +a status code and the content (optional). + +=item C<-Esend_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<-Eprint_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<-Eswap_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("[% foo %]
[% foo %]", $form)); + # $str eq 'bar
bar' + + $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 = "([% foo %])
+ ([% baz %])
+ ([% this %]) "; + $cgix->swap_template(\$str); + #$str eq "(bar)
+ # (wow)
+ # (wee) "; + +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 - Validator + +=item C - Validator + +=item C - Validator + +=item C - Validator + +=item C - Form filler-iner + +=item C - CGI Getter. Form filler-iner + +=head1 TODO + +Add an integrated template toolkit interface. + +Add an integrated debug module. + +=head1 MODULES + +See also L. + +See also L. + +See also L. + +See also L. + +See also L. + +See also L. + +=head1 AUTHOR + +Paul Seamons + +=head1 LICENSE + +This module may be distributed under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm new file mode 100644 index 0000000..552045a --- /dev/null +++ b/lib/CGI/Ex/App.pm @@ -0,0 +1,1940 @@ +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 =~ /$error"; +} + +###----------------------------------------------------------------### +### 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 => "
\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} .= '
' . $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 \ "

Main Step

+ + + [% foo_error %]
+ + + [% js_validation %] + Link to forbidden step + "; + } + + 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 { + \ "

Success Step

All done.
+ ([% success_msg %])
+ (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<-Enew> + +Object creator. Takes a hash or hashref. + +=item Method C<-Einit> + +Called by the default new method. Allows for any object +initilizations. + +=item Method C<-Eform> + +Returns a hashref of the items passed to the CGI. Returns +$self->{form}. Defaults to CGI::Ex::get_form. + +=item Method C<-Enavigate> + +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<-Enav_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<-Epre_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<-Epost_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<-Ehandle_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<-Ehistory> + +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<-Epath> + +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<-Edefault_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<-Estep_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<-Eset_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<-Eappend_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<-Ereplace_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<-Einsert_path> + +Arguments are the steps to insert. Can be called any time. Inserts +the new steps at the current path location. + +=item Method C<-Ejump> + +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<-Eexit_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<-Erecurse_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<-Evalid_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<-Eprevious_step, -Ecurrent_step, -Enext_step, -Elast_step, -Efirst_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<-Epre_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<-Erun_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<-Ehook> + +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<-Emorph> + +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<-Eunmorph> + +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<-Eallow_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<-Eallow_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<-Emorph_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<-Erun_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<-Epre_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<-Eskip> + +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<-Eprepare> + +Defaults to true. A hook before checking if the info_complete is true. + +=item Hook C<-Einfo_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<-Efinalize> + +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<-Eready_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<-Eset_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<-Evalidate> + +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<-Ehash_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<-Efile_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<-Ejs_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<-Eform_name> + +Return the name of the form to attach the js validation to. Used by +js_validation. + +=item Method C<-Ejs_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<-Ehash_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<-Ehash_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<-Ehash_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<-Eno_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<-Ehash_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<-Ehash_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<-Ehash_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<-Ename_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<-Ename_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<-Efile_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<-Eprint> + +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<-Eprepared_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<-Epost_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<-Epost_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<-Epost_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<-Estash> + +Returns a hashref that can store arbitrary user space data without +clobering the internals of the application. + +=item Method C<-Eadd_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<-Ecleanup> + +Can be used at the end of execution to tear down the structure. +Default method starts a cleanup_cross_references call. + +=item Method C<-Ecleanup_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 + +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 + +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 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 diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm new file mode 100644 index 0000000..e564efd --- /dev/null +++ b/lib/CGI/Ex/Auth.pm @@ -0,0 +1,831 @@ +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{
You do not appear to have cookies enabled.
}; + } 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 %] +
+ [% error %] +
+ + + + + + + + + + + + + + + + [% extra_table %] + +
+
+ [% 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{ + + + }; +} + +###----------------------------------------------------------------### + +### 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 + +Constructor. Takes a hash or hashref of properties as arguments. + +=item C + +Called automatically near the end of new. + +=item C + +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 + +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 + +Method called on successful login. Sets $self->user as well as $ENV{REMOTE_USER}. + +=item C + +Returns the user that was successfully logged in (undef if no success). + +=item C + +Called from success. May be overridden or a subref may be given as a property. + +=item C + +If a key is passed the form hash that matches this key, the current user will +be logged out. Default is "logout". + +=item C + +The name of the auth cookie. Default is "ce_auth". + +=item C + +A field name used during a bounce to see if cookies exist. Default is "ccheck". + +=item C + +The form field name used to pass the username. Default is "ce_user". + +=item C + +The form field name used to pass the password. Default is "ce_pass". + +=item C + +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 + +The name of the html login form to attach the javascript to. Default is "ce_form". + +=item C + +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 + +Called to verify the passed form information or the stored cookie. Calls hook_verify_userpass. + +=item C + +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 + +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 + +Allows for setting the subref used by hook_get_pass_by_user.x + +=item C + +Returns a CGI::Ex object. + +=item C
+ +A hash of passed form info. Defaults to CGI::Ex::get_form. + +=item C + +The current cookies. Defaults to CGI::Ex::get_cookies. + +=item C + +What host are we on. Defaults to a cleaned $ENV{HTTP_HOST}. + +=item C + +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 + +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 + +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 + +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 + +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 + +=cut diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm new file mode 100644 index 0000000..c1d256f --- /dev/null +++ b/lib/CGI/Ex/Conf.pm @@ -0,0 +1,851 @@ +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*{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/{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<-Eread_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<-Eread> + +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<-Ewrite_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<-Ewrite> + +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<-Epreload_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 + +Should be a file containing a perl structure which is the last thing returned. + +=item C and C + +Should be a file containing a structure stored in Storable format. +See L. + +=item C and C and C + +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. + +=item C + +Should be a windows style ini file. See L + +=item C + +Should be an xml file. It will be read in by XMLin. See L. + +=item C and C + +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: + + + # automatically indented and "username:\n" prepended + # AND # + + # AND # + + # AND # + + +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 + diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm new file mode 100644 index 0000000..a3787af --- /dev/null +++ b/lib/CGI/Ex/Die.pm @@ -0,0 +1,178 @@ +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 = "
Error: $msg
\n"; + my $ctrace = ! $SHOW_TRACE ? "" + : "
"
+    . dex_html(ctrace)."
"; + 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.'

'.$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 + +=cut diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm new file mode 100644 index 0000000..fd76291 --- /dev/null +++ b/lib/CGI/Ex/Dump.pm @@ -0,0 +1,242 @@ +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 = 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 = "
$called: $file line $line_n\n";
+    for (0 .. $#dump) {
+      $dump[$_] =~ s/\\n/\n/g;
+      $dump[$_] = _html_quote($dump[$_]);
+      $dump[$_] =~ s|\$VAR1|$var[$_]|g;
+      $html .= $dump[$_];
+    }
+    $html .= "
\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; + 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. + +Setting any of the Data::Dumper globals will alter the output. + +=head1 SUBROUTINES + +=over 4 + +=item C, C + +Prints out pretty output to STDOUT. Formatted for the web if on the web. + +=item C + +Prints to STDERR. + +=item C + +Return the text as a scalar. + +=item C + +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, C + +Turns calls to routines on or off. Default is to be on. + +=back + +=head1 AUTHORS + +Paul Seamons + +=cut diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm new file mode 100644 index 0000000..e1094ef --- /dev/null +++ b/lib/CGI/Ex/Fill.pm @@ -0,0 +1,465 @@ +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|()|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{(]+ # some space + \bname=([\"\']?) # the name tag + $target # with the correct name (allows for regex) + \2 # closing quote + .+? # as much as there is + (?=)) # 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 form elements if they have a name + $$ref =~ s{ + (] )* >) # 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|( $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{ + (}; + +my %fdat = (foo => 'bar>bar'); + +my $fif = new CGI::Ex; +my $output = $fif->fill(scalarref => \$hidden_form_in, + fdat => \%fdat); +if ($output eq ''){ + 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 ''){ + print "ok 3\n"; +} else { + print "Got unexpected out for $hidden_form_in:\n$output\n"; + print "not ok 3\n"; +} diff --git a/t/2_fill_06_radio.t b/t/2_fill_06_radio.t new file mode 100644 index 0000000..53ba4ad --- /dev/null +++ b/t/2_fill_06_radio.t @@ -0,0 +1,29 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; + +print "ok 1\n"; + +my $hidden_form_in = qq{ + + +}; + +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"; +} diff --git a/t/2_fill_07_reuse.t b/t/2_fill_07_reuse.t new file mode 100644 index 0000000..56d97ea --- /dev/null +++ b/t/2_fill_07_reuse.t @@ -0,0 +1,29 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; + +print "ok 1\n"; + +my $hidden_form_in = qq{ +}; + +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/^\s*$/i){ + print "ok 2\n"; +} else { + print "Got unexpected out for $hidden_form_in:\n$output2\n"; + print "not ok 2\n"; +} diff --git a/t/2_fill_08_multiple_objects.t b/t/2_fill_08_multiple_objects.t new file mode 100644 index 0000000..c26cf13 --- /dev/null +++ b/t/2_fill_08_multiple_objects.t @@ -0,0 +1,31 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; +use CGI; + +print "ok 1\n"; + +my $hidden_form_in = qq{ +}; + +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/^\s*$/i){ + print "ok 2\n"; +} else { + print "Got unexpected out for $hidden_form_in:\n$output\n"; + print "not ok 2\n"; +} diff --git a/t/2_fill_09_default_type.t b/t/2_fill_09_default_type.t new file mode 100644 index 0000000..5db1f59 --- /dev/null +++ b/t/2_fill_09_default_type.t @@ -0,0 +1,27 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; + +print "ok 1\n"; + +my $hidden_form_in = qq{ +}; + +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*$/i){ + print "ok 2\n"; +} else { + print "Got unexpected out for $hidden_form_in:\n$output\n"; + print "not ok 2\n"; +} diff --git a/t/2_fill_10_escape.t b/t/2_fill_10_escape.t new file mode 100644 index 0000000..fbacf04 --- /dev/null +++ b/t/2_fill_10_escape.t @@ -0,0 +1,43 @@ +# -*- Mode: Perl; -*- + +use strict; + +print "1..1\n"; +use CGI::Ex; + +my $html =<<"__HTML__"; + + +
+ +
+test
+test
+test
+
+

+ +

+ + +__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"; diff --git a/t/2_fill_11_target.t b/t/2_fill_11_target.t new file mode 100644 index 0000000..4a270de --- /dev/null +++ b/t/2_fill_11_target.t @@ -0,0 +1,38 @@ +# -*- Mode: Perl; -*- + +use strict; +use Test; +BEGIN { plan tests => 3 } + +use CGI::Ex; + +my $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/ +}; + +my %fdat = (foo1 => ['bar1','bar2']); + +my $fif = new CGI::Ex; +my $output = $fif->fill(scalarref => \$hidden_form_in, + fdat => \%fdat); +if ($output =~ m/^\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/^\s*$/i){ + print "ok 3\n"; +} else { + print "Got unexpected out for $hidden_form_in:\n$output\n"; + print "not ok 3\n"; +} diff --git a/t/2_fill_13_warning.t b/t/2_fill_13_warning.t new file mode 100644 index 0000000..882df15 --- /dev/null +++ b/t/2_fill_13_warning.t @@ -0,0 +1,25 @@ +# -*- 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{}; + +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!!); diff --git a/t/2_fill_14_password.t b/t/2_fill_14_password.t new file mode 100644 index 0000000..ddb56f6 --- /dev/null +++ b/t/2_fill_14_password.t @@ -0,0 +1,39 @@ +# -*- Mode: Perl; -*- + +#!/usr/bin/perl -w + +use CGI qw(:no_debug); +use CGI::Ex; +use Test; + +BEGIN { plan tests => 2 } + +local $/; +my $html = qq{}; +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"/); +} + + diff --git a/t/2_fill_15_multiple_fields.t b/t/2_fill_15_multiple_fields.t new file mode 100644 index 0000000..2fd7e86 --- /dev/null +++ b/t/2_fill_15_multiple_fields.t @@ -0,0 +1,25 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; +print "ok 1\n"; + +my $hidden_form_in = qq{ +}; + +my %fdat = (foo => 'bar1a'); + +my $fif = new CGI::Ex; +my $output = $fif->fill(scalarref => \$hidden_form_in, + fdat => \%fdat); +if ($output =~ m/^\s*$/){ + print "ok 2\n"; +} else { + print "Got unexpected out for hidden form:\n$output\n"; + print "not ok 2\n"; +} diff --git a/t/2_fill_16_ignore_fields.t b/t/2_fill_16_ignore_fields.t new file mode 100644 index 0000000..56ffe44 --- /dev/null +++ b/t/2_fill_16_ignore_fields.t @@ -0,0 +1,52 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; +use CGI; + +print "ok 1\n"; + +my $hidden_form_in = qq{ + + +}; +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"; +} + diff --git a/t/2_fill_17_xhtml.t b/t/2_fill_17_xhtml.t new file mode 100644 index 0000000..5fde93b --- /dev/null +++ b/t/2_fill_17_xhtml.t @@ -0,0 +1,49 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..1\n"; + +use CGI::Ex; +use CGI; + +my $html = < + + + Canceled
+ Confirmed
+ Wait List
+ + No Show
+ Moved to Another Class
+ Late Cancel
+ + +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; diff --git a/t/2_fill_18_coderef.t b/t/2_fill_18_coderef.t new file mode 100644 index 0000000..f09b3b0 --- /dev/null +++ b/t/2_fill_18_coderef.t @@ -0,0 +1,39 @@ +# -*- 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{ +}; + +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/^\s*$/){ + print "ok 4\n"; +} else { + print "Got unexpected out for hidden form:\n$output\n"; + print "not ok 4\n"; +} diff --git a/t/2_fill_19_complex.t b/t/2_fill_19_complex.t new file mode 100644 index 0000000..7a86735 --- /dev/null +++ b/t/2_fill_19_complex.t @@ -0,0 +1,30 @@ +# -*- Mode: Perl; -*- + +use strict; + +$^W = 1; + +print "1..2\n"; + +use CGI::Ex; + +print "ok 1\n"; + +my $string = qq{ + +}; + +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"; +} diff --git a/t/2_fill_20_switcharoo.t b/t/2_fill_20_switcharoo.t new file mode 100644 index 0000000..fac4441 --- /dev/null +++ b/t/2_fill_20_switcharoo.t @@ -0,0 +1,132 @@ +# -*- 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{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + +$string = qq{}; +$cgix->fill(text => \$string, form => \%fdat); +&$dook(); + + diff --git a/t/3_conf_00_base.t b/t/3_conf_00_base.t new file mode 100644 index 0000000..31591c0 --- /dev/null +++ b/t/3_conf_00_base.t @@ -0,0 +1,69 @@ +# -*- 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 + + diff --git a/t/3_conf_01_write.t b/t/3_conf_01_write.t new file mode 100644 index 0000000..d77c83a --- /dev/null +++ b/t/3_conf_01_write.t @@ -0,0 +1,71 @@ +# -*- 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'); diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t new file mode 100644 index 0000000..2e3170a --- /dev/null +++ b/t/4_app_00_base.t @@ -0,0 +1,12 @@ +# -*- Mode: Perl; -*- + +use Test; + +BEGIN {plan tests => 2}; + +use CGI::Ex::App; +ok(1); + +my $obj = CGI::Ex::App->new({ +}); +ok($obj); diff --git a/t/5_dump_00_base.t b/t/5_dump_00_base.t new file mode 100644 index 0000000..50cd4a2 --- /dev/null +++ b/t/5_dump_00_base.t @@ -0,0 +1,9 @@ +# -*- Mode: Perl; -*- + +use Test; + +BEGIN {plan tests => 1}; + +use CGI::Ex::Dump (); +ok(1); + diff --git a/t/6_die_00_base.t b/t/6_die_00_base.t new file mode 100644 index 0000000..cca35e7 --- /dev/null +++ b/t/6_die_00_base.t @@ -0,0 +1,13 @@ +# -*- 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; +}); diff --git a/t/samples/bench_cgix_hfif.pl b/t/samples/bench_cgix_hfif.pl new file mode 100755 index 0000000..081f9ec --- /dev/null +++ b/t/samples/bench_cgix_hfif.pl @@ -0,0 +1,106 @@ +#!/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{ + + + +
+ +

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+

















+ + + + + + + + + + + +
+ + +}; + +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'); + }, +}); diff --git a/t/samples/bench_conf_readers.pl b/t/samples/bench_conf_readers.pl new file mode 100644 index 0000000..4a6e319 --- /dev/null +++ b/t/samples/bench_conf_readers.pl @@ -0,0 +1,402 @@ +#!/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; + diff --git a/t/samples/bench_conf_writers.pl b/t/samples/bench_conf_writers.pl new file mode 100644 index 0000000..ac6438c --- /dev/null +++ b/t/samples/bench_conf_writers.pl @@ -0,0 +1,391 @@ +#!/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; + diff --git a/t/samples/bench_method_calling.pl b/t/samples/bench_method_calling.pl new file mode 100755 index 0000000..a65afbc --- /dev/null +++ b/t/samples/bench_method_calling.pl @@ -0,0 +1,111 @@ +#!/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; + } + }, +}); diff --git a/t/samples/cgi_ex_1.cgi b/t/samples/cgi_ex_1.cgi new file mode 100755 index 0000000..18aa11b --- /dev/null +++ b/t/samples/cgi_ex_1.cgi @@ -0,0 +1,181 @@ +#!/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{ + + + [% title %] + + + +

Please Enter information

+ [% error_header %] +
+ +
+ + + + + + + + + + + + + + + + + + + +
Username: + + [% username_error %]
Password: + [% password_error %]
Password Verify: + [% password_verify_error %]
+ +
+ + [% js_val %] + + + }; +} + +sub get_content_success { + return qq{ + + [% title %] + +

Success

+
+ print "I can now continue on with the rest of my script!"; + + + }; +} + + +1; diff --git a/t/samples/cgi_ex_2.cgi b/t/samples/cgi_ex_2.cgi new file mode 100755 index 0000000..73e37e2 --- /dev/null +++ b/t/samples/cgi_ex_2.cgi @@ -0,0 +1,171 @@ +#!/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{ + + + [% title %] + + + +

Please Enter information

+ [% error_header %] +
+ +
+ + + + + + + + + + + + + + + + + + + +
Username: + + [% username_error %]
Password: + [% password_error %]
Password Verify: + [% password_verify_error %]
+ +
+ + [% js_val %] + + + }; +} + +sub get_content_success { + return qq{ + + [% title %] + +

Success

+
+ print "I can now continue on with the rest of my script!"; + + + }; +} + + +1; diff --git a/t/samples/conf_path_1/apples.pl b/t/samples/conf_path_1/apples.pl new file mode 100644 index 0000000..56856ae --- /dev/null +++ b/t/samples/conf_path_1/apples.pl @@ -0,0 +1,5 @@ +{ + quantity => 20, + color => 'red', + foo_immutable => 'file1', +}; diff --git a/t/samples/conf_path_1/oranges.pl b/t/samples/conf_path_1/oranges.pl new file mode 100644 index 0000000..03fc08b --- /dev/null +++ b/t/samples/conf_path_1/oranges.pl @@ -0,0 +1,6 @@ +{ + immutable => 1, + quantity => 20, + color => 'orange', + foo => 'file1', +}; diff --git a/t/samples/conf_path_3/apples.pl b/t/samples/conf_path_3/apples.pl new file mode 100644 index 0000000..e72f0ee --- /dev/null +++ b/t/samples/conf_path_3/apples.pl @@ -0,0 +1,5 @@ +{ + quantity => 30, + color => 'green', + foo => 'file2', +}; diff --git a/t/samples/conf_path_3/oranges.pl b/t/samples/conf_path_3/oranges.pl new file mode 100644 index 0000000..f02324d --- /dev/null +++ b/t/samples/conf_path_3/oranges.pl @@ -0,0 +1,5 @@ +{ + quantity => 30, + color => 'orange', + foo => 'file2', +}; diff --git a/t/samples/generate_js.pl b/t/samples/generate_js.pl new file mode 100644 index 0000000..aeb1ecb --- /dev/null +++ b/t/samples/generate_js.pl @@ -0,0 +1,48 @@ +#!/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' => "
\n
", + '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 " + +
+ +Username:
+
+Password:
+
+ + +
+ +$val + + + +"; diff --git a/t/samples/html1.htm b/t/samples/html1.htm new file mode 100644 index 0000000..9441558 --- /dev/null +++ b/t/samples/html1.htm @@ -0,0 +1,14 @@ +
+ + + +
+ + + diff --git a/t/samples/html2.htm b/t/samples/html2.htm new file mode 100644 index 0000000..1d8a41c --- /dev/null +++ b/t/samples/html2.htm @@ -0,0 +1,10 @@ +
+ + + +
+ diff --git a/t/samples/js_validate_1.html b/t/samples/js_validate_1.html new file mode 100644 index 0000000..d906442 --- /dev/null +++ b/t/samples/js_validate_1.html @@ -0,0 +1,203 @@ + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Username: +
+ +
Password: +
+ +
Verify Password: +
+ +
Email: +
+ +
Verify Email: +
+ +
State/Region: + Specify State
+ OR Region + +
Enum Check: +
+ +
Compare Check: +
+ +
Check one: + Foo
+ Bar
+ Baz
+ +
Check two: + Foo
+ Bar
+ Baz
+ +
Fill In two: +
+ Foo
+ Bar
+ Baz
+
+ +
+
+ + + + + + \ No newline at end of file diff --git a/t/samples/js_validate_2.html b/t/samples/js_validate_2.html new file mode 100644 index 0000000..00c012e --- /dev/null +++ b/t/samples/js_validate_2.html @@ -0,0 +1,116 @@ + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Username: +
+ +
Password: +
+ +
Verify Password: +
+ +
Email: +
+ +
Verify Email: +
+ +
Random Association: +
(type anything - will fill in default if none)
+ +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/t/samples/js_validate_3.html b/t/samples/js_validate_3.html new file mode 100644 index 0000000..0ae65c8 --- /dev/null +++ b/t/samples/js_validate_3.html @@ -0,0 +1,70 @@ + + + + + + + + +
+ + + + + + + + +
Enter a date (YYYY/MM/DD) greater than today:
+ () + 		+
+ +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/t/samples/perl1.pl b/t/samples/perl1.pl new file mode 100644 index 0000000..4b41e16 --- /dev/null +++ b/t/samples/perl1.pl @@ -0,0 +1,11 @@ +### 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 diff --git a/t/samples/perl2.pl b/t/samples/perl2.pl new file mode 100644 index 0000000..4f388d3 --- /dev/null +++ b/t/samples/perl2.pl @@ -0,0 +1,20 @@ +### 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, + }, + }, +]; diff --git a/t/samples/storable1.storable b/t/samples/storable1.storable new file mode 100644 index 0000000..f9d6640 Binary files /dev/null and b/t/samples/storable1.storable differ diff --git a/t/samples/yaml1.val b/t/samples/yaml1.val new file mode 100644 index 0000000..5fd169c --- /dev/null +++ b/t/samples/yaml1.val @@ -0,0 +1,10 @@ +### 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} diff --git a/t/samples/yaml2.val b/t/samples/yaml2.val new file mode 100644 index 0000000..16c208f --- /dev/null +++ b/t/samples/yaml2.val @@ -0,0 +1,10 @@ +### 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 diff --git a/t/samples/yaml3.val b/t/samples/yaml3.val new file mode 100644 index 0000000..07a621a --- /dev/null +++ b/t/samples/yaml3.val @@ -0,0 +1,17 @@ +### 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 + diff --git a/t/samples/yaml_js_1.html b/t/samples/yaml_js_1.html new file mode 100644 index 0000000..7b972b4 --- /dev/null +++ b/t/samples/yaml_js_1.html @@ -0,0 +1,62 @@ + +Yaml Test + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/t/samples/yaml_js_2.html b/t/samples/yaml_js_2.html new file mode 100644 index 0000000..c651eae --- /dev/null +++ b/t/samples/yaml_js_2.html @@ -0,0 +1,114 @@ + +Yaml Test + + +
+ + +
YAML text
+
+
ProducesShould look like
+
+ 		+
Dump:
+[obj].0.baz=bee
+[obj].0.foo=bar
+[obj].0.hem=haw
+
+
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/t/samples/yaml_js_3.html b/t/samples/yaml_js_3.html new file mode 100644 index 0000000..acdd323 --- /dev/null +++ b/t/samples/yaml_js_3.html @@ -0,0 +1,89 @@ + +Yaml Test + + +
+ + +
YAML text
+
+
ProducesShould look like
+
+ 		+
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
+
+
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/t/samples/yaml_js_4.html b/t/samples/yaml_js_4.html new file mode 100644 index 0000000..f05d3db --- /dev/null +++ b/t/samples/yaml_js_4.html @@ -0,0 +1,70 @@ + +Yaml Test + + +
+ + +
YAML text
+
+
ProducesShould look like
+
+ 		+
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
+
+
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file
+ + +
YAML text
+
+
ProducesShould look like
+
+ 		+
Dump:
+[obj].0.foo=bar
+[obj].1.0=baz
+[obj].1.1=bee
+[obj].2.hem=haw
+
+
+ +