From 4eee158dce82376f2f37de29d91c53f60a24aebe Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Tue, 30 May 2006 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.00 --- CGI-Ex.spec | 19 +- Changes | 69 +- MANIFEST | 79 +- MANIFEST.SKIP | 3 +- META.yml | 2 +- README | 218 +- lib/CGI/Ex.pm | 1140 +++--- lib/CGI/Ex/App.pm | 2443 ++++--------- lib/CGI/Ex/App.pod | 2146 +++++++++++ lib/CGI/Ex/Auth.pm | 1463 ++++---- lib/CGI/Ex/Conf.pm | 253 +- lib/CGI/Ex/Die.pm | 15 +- lib/CGI/Ex/Dump.pm | 46 +- lib/CGI/Ex/Fill.pm | 1090 ++++-- lib/CGI/Ex/Template.pm | 3152 ++++++++++++++++- lib/CGI/Ex/Template.pod | 2563 ++++++++++++++ lib/CGI/Ex/Validate.pm | 1009 +++--- lib/CGI/Ex/Var.pm | 1197 +++++++ lib/CGI/Ex/validate.js | 28 +- lib/CGI/Ex/yaml_load.js | 4 +- samples/benchmark/bench_auth.pl | 154 + samples/benchmark/bench_cgix_hfif.pl | 103 + samples/benchmark/bench_conf_readers.pl | 419 +++ samples/benchmark/bench_conf_writers.pl | 398 +++ samples/benchmark/bench_method_calling.pl | 111 + samples/benchmark/bench_optree.pl | 671 ++++ samples/benchmark/bench_template.pl | 382 ++ .../benchmark/bench_template_tag_parser.pl | 187 + samples/benchmark/bench_validation.pl | 126 + samples/benchmark/bench_various_templaters.pl | 230 ++ samples/cgi_ex_1.cgi | 186 + samples/cgi_ex_2.cgi | 150 + samples/conf_path_1/apples.pl | 5 + samples/conf_path_1/oranges.pl | 6 + samples/conf_path_3/apples.pl | 5 + samples/conf_path_3/oranges.pl | 5 + samples/devel/dprof_conf.d | 77 + samples/devel/dprof_template.d | 54 + samples/devel/dprof_validation.d | 41 + samples/generate_js.pl | 48 + samples/html1.htm | 14 + samples/html2.htm | 10 + samples/js_validate_1.html | 203 ++ samples/js_validate_2.html | 116 + samples/js_validate_3.html | 70 + samples/memory_template.pl | 39 + samples/perl1.pl | 11 + samples/perl2.pl | 17 + samples/yaml1.val | 8 + samples/yaml2.val | 7 + samples/yaml3.val | 13 + samples/yaml_js_1.html | 62 + samples/yaml_js_2.html | 114 + samples/yaml_js_3.html | 89 + samples/yaml_js_4.html | 70 + t/0_ex_00_base.t | 169 +- t/1_validate_00_base.t | 41 +- t/1_validate_03_cgi.t | 53 +- t/1_validate_05_types.t | 440 ++- t/1_validate_06_groups.t | 54 +- t/1_validate_07_yaml.t | 99 +- t/1_validate_08_yaml_file.t | 115 +- t/1_validate_11_no_extra.t | 111 +- t/1_validate_12_change.t | 47 +- t/1_validate_14_untaint.t | 85 +- t/2_fill_00_base.t | 151 +- t/2_fill_01_form.t | 24 +- t/2_fill_02_hidden.t | 31 +- t/2_fill_03_checkbox.t | 25 +- t/2_fill_04_select.t | 84 +- t/2_fill_05_textarea.t | 37 +- t/2_fill_06_radio.t | 24 +- t/2_fill_07_reuse.t | 28 +- t/2_fill_08_multiple_objects.t | 41 +- t/2_fill_09_default_type.t | 25 +- t/2_fill_10_escape.t | 23 +- t/2_fill_11_target.t | 26 +- t/2_fill_12_mult.t | 44 +- t/2_fill_13_warning.t | 44 +- t/2_fill_14_password.t | 46 +- t/2_fill_16_ignore_fields.t | 35 +- t/2_fill_17_xhtml.t | 33 +- t/2_fill_18_coderef.t | 29 +- t/2_fill_19_complex.t | 25 +- t/2_fill_20_switcharoo.t | 131 +- t/3_conf_00_base.t | 20 +- t/3_conf_01_write.t | 110 +- t/4_app_00_base.t | 85 +- t/5_dump_00_base.t | 11 +- t/6_die_00_base.t | 11 +- t/7_template_00_base.t | 739 ++++ t/7_template_01_includes.t | 114 + t/8_auth_00_base.t | 120 + 93 files changed, 19271 insertions(+), 5199 deletions(-) create mode 100644 lib/CGI/Ex/App.pod create mode 100644 lib/CGI/Ex/Template.pod create mode 100644 lib/CGI/Ex/Var.pm create mode 100644 samples/benchmark/bench_auth.pl create mode 100755 samples/benchmark/bench_cgix_hfif.pl create mode 100644 samples/benchmark/bench_conf_readers.pl create mode 100644 samples/benchmark/bench_conf_writers.pl create mode 100755 samples/benchmark/bench_method_calling.pl create mode 100644 samples/benchmark/bench_optree.pl create mode 100644 samples/benchmark/bench_template.pl create mode 100644 samples/benchmark/bench_template_tag_parser.pl create mode 100644 samples/benchmark/bench_validation.pl create mode 100644 samples/benchmark/bench_various_templaters.pl create mode 100755 samples/cgi_ex_1.cgi create mode 100755 samples/cgi_ex_2.cgi create mode 100644 samples/conf_path_1/apples.pl create mode 100644 samples/conf_path_1/oranges.pl create mode 100644 samples/conf_path_3/apples.pl create mode 100644 samples/conf_path_3/oranges.pl create mode 100644 samples/devel/dprof_conf.d create mode 100644 samples/devel/dprof_template.d create mode 100644 samples/devel/dprof_validation.d create mode 100644 samples/generate_js.pl create mode 100644 samples/html1.htm create mode 100644 samples/html2.htm create mode 100644 samples/js_validate_1.html create mode 100644 samples/js_validate_2.html create mode 100644 samples/js_validate_3.html create mode 100644 samples/memory_template.pl create mode 100644 samples/perl1.pl create mode 100644 samples/perl2.pl create mode 100644 samples/yaml1.val create mode 100644 samples/yaml2.val create mode 100644 samples/yaml3.val create mode 100644 samples/yaml_js_1.html create mode 100644 samples/yaml_js_2.html create mode 100644 samples/yaml_js_3.html create mode 100644 samples/yaml_js_4.html create mode 100644 t/7_template_00_base.t create mode 100644 t/7_template_01_includes.t create mode 100644 t/8_auth_00_base.t diff --git a/CGI-Ex.spec b/CGI-Ex.spec index 95d516b..f0ab4d9 100644 --- a/CGI-Ex.spec +++ b/CGI-Ex.spec @@ -1,5 +1,5 @@ %define name CGI-Ex -%define version 1.14 +%define version 2.00 %define __find_provides %( echo -n /usr/lib/rpm/find-provides && [ -x /usr/lib/rpm/find-provides.perl ] && echo .perl ) %define __find_requires %( echo -n /usr/lib/rpm/find-requires && [ -x /usr/lib/rpm/find-requires.perl ] && echo .perl ) @@ -19,12 +19,17 @@ 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. +CGI::Ex provides a suite of utilities to make writing CGI scripts +more enjoyable. Although they can all be used separately, the +main functionality of each of the modules is best represented in +the CGI::Ex::App module. CGI::Ex::App takes CGI application building +to the next step. CGI::Ex::App is not quite a framework (which normally +includes prebuilt html) instead CGI::Ex::App is an extended application +flow that dramatically reduces CGI build time in most cases. It does so +using as little magic as possible. See L. + +The main functionality is provided by several other modules that +may be used separately, or together through the CGI::Ex interface. %prep %setup -q -n %{name}-%{version} diff --git a/Changes b/Changes index 0f19564..f7bb39d 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,25 @@ -2005-02-28 Paul Seamons - - * Version 1.14 is done +2.00 + * Added CGI::Ex::Template and test suites + * Allow for CGI::Ex::Template to be fully TT2 syntax compliant + * Re-implementation of CGI::Ex::Auth + * Allow for step to be automatically untainted during loop in CGI::Ex::App + * Fix base_dir_rel to work with "" as the dir in CGI::Ex::App + * Bug fixes in CGI::Ex::Fill + * Better perldoc in CGI::Ex::Fill + * Add named parameter function called fill in CGI::Ex::Fill + * DProfd CGI::Ex::Conf for improvements + * DProfd CGI::Ex::Validate for improvements + * Added conf_read and conf_write methods for Conf + * Cleanup of all of the test + * Add missing tests + * Add Array Prototype fixes from Eamon Daly + * Add examples and cleanup to CGI::Ex::App + * Cleanup hooks in App (add fill_args and template_args) + * Change run_hook syntax in App + * Add dump_history with more history information + * Integrate CGI::Ex::Auth with App + +1.14 2005-02-28 * Bug fix in validate (OR's were not working) * Allow for checking for package existence without require in App * Add hash_swap @@ -10,37 +29,29 @@ * Allow for untaint in CGI::Ex::Validate * Allow for !field in equals of CGI::Ex::Validate * Allow for return of names in CGI::Ex::Validate - * All CGI::Ex to work better with CGI/mod_perl1/mod_perl2 + * Allow CGI::Ex to work better with CGI/mod_perl1/mod_perl2 * Fix required => 0 in javascript -2004-12-02 Paul Seamons - - * Version 1.13 is done +1.13 2004-12-02 * Show more App perldoc examples * Fix some App path bugs * Add more app hooks * Cleanup app code * Allow for Conf to write to each of the types -2004-11-010 Paul Seamons - - * Version 1.12 is done +1.12 2004-11-10 * Show more App perldoc examples * Fix some App path bugs * Change some App method names * Allow for App js_validation * Allow for App validation redirection -2004-11-08 Paul Seamons - - * Version 1.11 is done +1.11 2004-11-08 * Let file path dependent tests succeed * Allow for next current and previous steps in App * Couple of warn cleans in App -2004-11-05 Paul Seamons - - * Version 1.10 is done +1.10 2004-11-05 * Make CGI::Ex::App->print really work with Template * Fix very large javascript variable swapping bug * Numerous upgrades to App @@ -48,9 +59,7 @@ * 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 +1.00 2004-04-23 * Added set_path method * Added Auth module * Fix validate.js for select-multiple @@ -58,9 +67,7 @@ * 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 +0.99 2004-03-22 * Allow swap_template to be called with one argument * Added extended examples in t/samples/cgi_ex_* * Remove dependency on CGI::Util (doesn't exists on some perls) @@ -68,34 +75,26 @@ * Added set_form * Updated tests -2004-03-19 Paul Seamons - - * Version 0.98 is done +0.98 2004-03-19 * Multiple fixes in Fill module * Updates on perldocs (thanks to Simon Bellwood for bug reports) * Addition of Dump (debug) module * Addition of Die module * Addition of App module -2004-03-05 Paul Seamons - +0.97 2004-03-05 * Allow for custom_js type * Fix unshift, shift, and push in ie 5.0 * Fix type CC in validate.js * Allow for duplicate field definitions -2003-11-26 Paul Seamons - - * Version 0.96 is done +0.96 2003-11-26 * Fix for pos not resetting in CGI::Ex::Fill * Fix for general items set in self not being passed to generate_js * Workaround for yaml_load.js |- not properly trimming whitespace -2003-11-26 Paul Seamons - - * Version 0.94 is done +0.94 2003-11-26 * Javascript functionality is in. -2003-11-01 Paul Seamons - +0.0 2003-11-01 * Version 0.0 checked in diff --git a/MANIFEST b/MANIFEST index 177b5f4..bfbd9b8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2,6 +2,7 @@ CGI-Ex.spec Changes lib/CGI/Ex.pm lib/CGI/Ex/App.pm +lib/CGI/Ex/App.pod lib/CGI/Ex/Auth.pm lib/CGI/Ex/Conf.pm lib/CGI/Ex/Die.pm @@ -10,30 +11,60 @@ lib/CGI/Ex/Fill.pm lib/CGI/Ex/md5.js lib/CGI/Ex/sha1.js lib/CGI/Ex/Template.pm +lib/CGI/Ex/Template.pod lib/CGI/Ex/validate.js lib/CGI/Ex/Validate.pm +lib/CGI/Ex/Var.pm lib/CGI/Ex/yaml_load.js Makefile.PL -MANIFEST This list of files +MANIFEST MANIFEST.SKIP -META.yml Module meta-data (added by MakeMaker) +META.yml README +samples/benchmark/bench_auth.pl +samples/benchmark/bench_cgix_hfif.pl +samples/benchmark/bench_conf_readers.pl +samples/benchmark/bench_conf_writers.pl +samples/benchmark/bench_method_calling.pl +samples/benchmark/bench_optree.pl +samples/benchmark/bench_template.pl +samples/benchmark/bench_template_tag_parser.pl +samples/benchmark/bench_validation.pl +samples/benchmark/bench_various_templaters.pl +samples/cgi_ex_1.cgi +samples/cgi_ex_2.cgi +samples/conf_path_1/apples.pl +samples/conf_path_1/oranges.pl +samples/conf_path_3/apples.pl +samples/conf_path_3/oranges.pl +samples/devel/dprof_conf.d +samples/devel/dprof_template.d +samples/devel/dprof_validation.d +samples/generate_js.pl +samples/html1.htm +samples/html2.htm +samples/js_validate_1.html +samples/js_validate_2.html +samples/js_validate_3.html +samples/memory_template.pl +samples/perl1.pl +samples/perl2.pl +samples/yaml1.val +samples/yaml2.val +samples/yaml3.val +samples/yaml_js_1.html +samples/yaml_js_2.html +samples/yaml_js_3.html +samples/yaml_js_4.html t/0_ex_00_base.t -t/0_ex_01_swap.t t/1_validate_00_base.t -t/1_validate_01_form.t -t/1_validate_02_form_fail.t t/1_validate_03_cgi.t -t/1_validate_04_cgi_fail.t t/1_validate_05_types.t t/1_validate_06_groups.t t/1_validate_07_yaml.t t/1_validate_08_yaml_file.t -t/1_validate_09_perl_file.t -t/1_validate_10_storable_file.t t/1_validate_11_no_extra.t t/1_validate_12_change.t -t/1_validate_13_html_file.t t/1_validate_14_untaint.t t/2_fill_00_base.t t/2_fill_01_form.t @@ -50,7 +81,6 @@ 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 @@ -61,29 +91,6 @@ 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 +t/7_template_00_base.t +t/7_template_01_includes.t +t/8_auth_00_base.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 94bd9c4..70b054a 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -10,5 +10,4 @@ blib \.gz$ .cvsignore tmon\.out -t/samples/template -wrap \ No newline at end of file +WrapEx.pm diff --git a/META.yml b/META.yml index 0bb9c37..42b202a 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: CGI-Ex -version: 1.14 +version: 2.00 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/README b/README index 8591b87..8fd2d39 100644 --- a/README +++ b/README @@ -1,104 +1,64 @@ NAME - CGI::Ex - CGI utility suite (form getter/filler/validator/app builder) - -SYNOPSIS - ### CGI Module Extensions - - my $cgix = CGI::Ex->new; - my $hashref = $cgix->get_form; # uses CGI by default - - ### send the Content-type header - whether or not we are mod_perl - $cgix->print_content_type; - - my $val_hash = $cgix->conf_read($pathtovalidation); - - my $err_obj = $cgix->validate($hashref, $val_hash); - if ($err_obj) { - my $errors = $err_obj->as_hash; - my $input = "Some content"; - my $content = ""; - SomeTemplateObject->process($input, $errors, $content); - $cgix->fill({text => \$content, form => $hashref}); - print $content; - exit; - } - - print "Success\n"; - - ### Filling functionality - - $cgix->fill({text => \$text, form => \%hash}); - $cgix->fill({text => \$text, fdat => \%hash}); - $cgix->fill({text => \$text, fobject => $cgiobject}); - $cgix->fill({text => \$text, form => [\%hash1, $cgiobject]}); - $cgix->fill({text => \$text); # uses $self->object as the form - $cgix->fill({text => \$text, - form => \%hash, - target => 'formname', - fill_password => 0, - ignore_fields => ['one','two']}); - $cgix->fill(\$text); # uses $self->object as the form - $cgix->fill(\$text, \%hash, 'formname', 0, ['one','two']); - my $copy = $cgix->fill({scalarref => \$text, fdat => \%hash}); - my $copy = $cgix->fill({arrayref => \@lines, fdat => \%hash}); - my $copy = $cgix->fill({file => $filename, fdat => \%hash}); - - ### Validation functionality - - my $err_obj = $cgix->validate($form, $val_hash); - my $err_obj = $cgix->validate($form, $path_to_validation); - my $err_obj = $cgix->validate($form, $yaml_string); - - ### get errors separated by key name - ### useful for inline errors - my $hash = $err_obj->as_hash; - my %hash = $err_obj->as_hash; - - ### get aggregate list of errors - ### useful for central error description - my $array = $err_obj->as_array; - my @array = $err_obj->as_array; - - ### get a string - ### useful for central error description - my $string = $err_obj->as_string; - my $string = "$err_obj"; - - $cgix->{raise_error} = 1; - $cgix->validate($form, $val_hash); - # SAME AS # - my $err_obj = $cgix->validate($form, $val_hash); - die $err_obj if $err_obj; - - ### Settings functionality - - ### read file via yaml - my $ref = $cgix->conf_read('/full/path/to/conf.yaml'); - - ### merge all found settings.pl files together - @CGI::Ex::Conf::DEFAULT_PATHS = qw(/tmp /my/data/dir /home/foo); - @CGI::Ex::Conf::DIRECTIVE = 'MERGE'; - @CGI::Ex::Conf::DEFAULT_EXT = 'pl'; - my $ref = $cgix->conf_read('settings'); + CGI::Ex - CGI utility suite - makes powerful application writing fun and + easy + +CGI::Ex SYNOPSIS + ### You probably don't want to use CGI::Ex directly + ### You probably should use CGI::Ex::App instead. + + my $cgix = CGI::Ex->new; + + $cgix->print_content_type; + + my $hash = $cgix->form; + + if ($hash->{'bounce'}) { + + $cgix->set_cookie({ + name => ..., + value => ..., + }); + + $cgix->location_bounce($new_url_location); + exit; + } + + if (scalar keys %$form) { + my $val_hash = $cgix->conf_read($pathtovalidation); + my $err_obj = $cgix->validate($hash, $val_hash); + if ($err_obj) { + my $errors = $err_obj->as_hash; + my $input = "Some content"; + my $content = ""; + $cgix->swap_template(\$input, $errors, $content); + $cgix->fill({text => \$content, form => $hashref}); + print $content; + exit; + } else { + print "Success"; + } + } else { + print "Main page"; + } DESCRIPTION CGI::Ex provides a suite of utilities to make writing CGI scripts more enjoyable. Although they can all be used separately, the main functionality of each of the modules is best represented in the CGI::Ex::App module. CGI::Ex::App takes CGI application building to the - next step. CGI::Ex::App is not a framework (which normally includes - prebuilt html) instead CGI::Ex::App is an extended application flow that - normally dramatically reduces CGI build time. See CGI::Ex::App. - - CGI::Ex is another form filler / validator / conf reader / template - interface. Its goal is to take the wide scope of validators and other - useful CGI application modules out there and merge them into one utility - that has all of the necessary features of them all, as well as several - extended methods that I have found useful in working on the web. + next step. CGI::Ex::App is not quite a framework (which normally + includes pre-built html) instead CGI::Ex::App is an extended application + flow that dramatically reduces CGI build time in most cases. It does so + using as little magic as possible. See CGI::Ex::App. The main functionality is provided by several other modules that may be used separately, or together through the CGI::Ex interface. + "CGI::Ex::Template" + A Template::Toolkit compatible processing engine. With a few + limitations, CGI::Ex::Template can be a drop in replacement for + Template::Toolkit. + "CGI::Ex::Fill" A regular expression based form filler inner (accessed through ->fill or directly via its own functions). Can be a drop in @@ -121,7 +81,11 @@ DESCRIPTION and xml and open architecture for definition of others. See CGI::Ex::Conf for more information. -METHODS + "CGI::Ex::Auth" + A highly configurable web based authentication system. See + CGI::Ex::Auth for more information. + +CGI::Ex METHODS "->fill" fill is used for filling hash or cgi object values into an existing html document (it doesn't deal at all with how you got the @@ -136,7 +100,7 @@ METHODS "text" Text should be a reference to a scalar string containing the html to be modified (actually it could be any reference or - object reference that can be modfied as a string). It will be + object reference that can be modified as a string). It will be modified in place. Another named argument scalarref is available if you would like to copy rather than modify. @@ -145,11 +109,11 @@ METHODS array of multiple hashrefs, cgi objects, and coderefs. Hashes should be key value pairs. CGI objects should be able to call the method param (This can be overrided). Coderefs should expect - expect the field name as an argument and should return a value. - Values returned by form may be undef, scalar, arrayref, or - coderef (coderef values should expect an argument of field name - and should return a value). The code ref options are available - to delay or add options to the bringing in of form informatin - + the field name as an argument and should return a value. Values + returned by form may be undef, scalar, arrayref, or coderef + (coderef values should expect an argument of field name and + should return a value). The code ref options are available to + delay or add options to the bringing in of form information - without having to tie the hash. Coderefs are not available in HTML::FillInForm. Also HTML::FillInForm only allows CGI objects if an arrayref is used. @@ -170,7 +134,7 @@ METHODS of names, or a hashref with the names as keys. The hashref option is not available in CGI::Ex::Fill. - Other named arguments are available for compatiblity with + Other named arguments are available for compatibility with HTML::FillInForm. They may only be used as named arguments. "scalarref" @@ -218,16 +182,34 @@ METHODS "->get_form" Very similar to CGI->new->Vars except that arrays are returned as - arrays. Not sure why CGI::Val didn't do this anyway (well - yes - - legacy Perl 4 - but at some point things need to be updated). + arrays. Not sure why CGI didn't do this anyway (well - yes - legacy + Perl 4 - but at some point things need to be updated). + + my $hash = $cgix->get_form; + my $hash = $cgix->get_form(CGI->new); + my $hash = get_form(); + my $hash = get_form(CGI->new); "->set_form" Allow for setting a custom form hash. Useful for testing, or other purposes. + $cgix->set_form(\%new_form); + "->get_cookies" Returns a hash of all cookies. + my $hash = $cgix->get_cookies; + my $hash = $cgix->get_cookies(CGI->new); + my $hash = get_cookies(); + my $hash = get_cookies(CGI->new); + + "->set_cookies" + Allow for setting a custom cookies hash. Useful for testing, or + other purposes. + + $cgix->set_cookies(\%new_cookies); + "->make_form" Takes a hash and returns a query_string. A second optional argument may contain an arrayref of keys to use from the hash in building the @@ -325,7 +307,7 @@ METHODS #$str eq "(bar)
# (wow)
# (wee) "; - + For further examples, please see the code contained in t/samples/cgi_ex_* of this distribution. @@ -333,38 +315,26 @@ METHODS templates that were being swapped by CGI::Ex::swap_template should be compatible with Template::Toolkit. -EXISTING MODULES - The following is a list of existing validator and formfiller modules at - the time of this writing (I'm sure this probably isn't exaustive). - - "Email::Valid" - Validator - "SSN::Validate" - Validator - "Embperl::Form::Validate" - Validator - "Data::CGIForm" - Validator - "HTML::FillInForm" - Form filler-iner - "CGI" - CGI Getter. Form filler-iner - -TODO - Add an integrated template toolkit interface. +MODULES + See also CGI::Ex::App. - Add an integrated debug module. + See also CGI::Ex::Auth. -MODULES - See also CGI::Ex::Fill. + See also CGI::Ex::Conf. - See also CGI::Ex::Validate. + See also CGI::Ex::Die. - See also CGI::Ex::Conf. + See also CGI::Ex::Dump. - See also CGI::Ex::Die. + See also CGI::Ex::Fill. - See also CGI::Ex::App. + See also CGI::Ex::Template. - See also CGI::Ex::Dump. + See also CGI::Ex::Validate. AUTHOR - Paul Seamons + Paul Seamons LICENSE - This module may be distributed under the same terms as Perl itself. + This module may be distributed under the same terms as Perl itself. diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index cbc5a34..03d0f02 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -1,9 +1,13 @@ package CGI::Ex; -### CGI Extended +=head1 NAME + +CGI::Ex - CGI utility suite - makes powerful application writing fun and easy + +=cut ###----------------------------------------------------------------### -# Copyright 2003 - Paul Seamons # +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### @@ -11,70 +15,69 @@ package CGI::Ex; use strict; use vars qw($VERSION - $PREFERRED_FILL_MODULE $PREFERRED_CGI_MODULE $PREFERRED_CGI_REQUIRED - $TEMPLATE_OPEN - $TEMPLATE_CLOSE $AUTOLOAD $DEBUG_LOCATION_BOUNCE @EXPORT @EXPORT_OK ); use base qw(Exporter); -$VERSION = '1.14'; -$PREFERRED_FILL_MODULE ||= ''; -$PREFERRED_CGI_MODULE ||= 'CGI'; -$TEMPLATE_OPEN ||= qr/\[%\s*/; -$TEMPLATE_CLOSE ||= qr/\s*%\]/; -@EXPORT = (); -@EXPORT_OK = qw(get_form - get_cookies - print_content_type - content_type - content_typed - set_cookie - ); +BEGIN { + $VERSION = '2.00'; + $PREFERRED_CGI_MODULE ||= 'CGI'; + @EXPORT = (); + @EXPORT_OK = qw(get_form + get_cookies + print_content_type + content_type + content_typed + set_cookie + location_bounce + ); +} ###----------------------------------------------------------------### # my $cgix = CGI::Ex->new; sub new { - my $class = shift || die "Missing class name"; - my $self = ref($_[0]) ? shift : {@_}; - return bless $self, $class; + my $class = shift || die "Missing class name"; + my $self = ref($_[0]) ? shift : {@_}; + return bless $self, $class; } +###----------------------------------------------------------------### + ### allow for holding another classed CGI style object # my $query = $cgix->object; # $cgix->object(CGI->new); sub object { - my $self = shift; - die 'Usage: my $query = $cgix_obj->object' if ! ref $self; - return $self->{'object'} = shift if $#_ != -1; - return $self->{'object'} ||= do { - $PREFERRED_CGI_REQUIRED ||= do { - my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE; - $file .= ".pm"; - $file =~ s|::|/|g; - eval { require $file }; - die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@; - 1; # return of inner do - }; - $PREFERRED_CGI_MODULE->new; # return of the do - }; + my $self = shift || die 'Usage: my $query = $cgix_obj->object'; + $self->{'object'} = shift if $#_ != -1; + + if (! defined $self->{'object'}) { + $PREFERRED_CGI_REQUIRED ||= do { + my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE; + $file .= ".pm"; + $file =~ s|::|/|g; + eval { require $file }; + die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@; + 1; # return of do + }; + $self->{'object'} = $PREFERRED_CGI_MODULE->new; + } + + return $self->{'object'}; } -### allow for calling their methods +### allow for calling CGI MODULE methods sub AUTOLOAD { - my $self = shift; - my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD"; - return wantarray # does wantarray propogate up ? - ? ($self->object->$meth(@_)) - : $self->object->$meth(@_); + my $self = shift; + my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD"; + return $self->object->$meth(@_); } -sub DESTROY {} +sub DESTROY { } ###----------------------------------------------------------------### @@ -85,69 +88,62 @@ sub DESTROY {} # my $hash = get_form(); # my $hash = get_form(CGI->new); sub get_form { - my $self = shift; - $self = __PACKAGE__->new if ! $self; - die 'Usage: $cgix_obj->get_form' if ! ref $self; - if (! UNIVERSAL::isa($self, __PACKAGE__)) { # get_form(CGI->new) syntax - my $obj = $self; - $self = __PACKAGE__->new; - $self->object($obj); - } - return $self->{'form'} if $self->{'form'}; - - ### get the info out of the object - my $obj = shift || $self->object; - my %hash = (); - foreach my $key ($obj->param) { - my @val = $obj->param($key); - $hash{$key} = ($#val == -1) ? die : ($#val == 0) ? $val[0] : \@val; - } - return $self->{'form'} = \%hash; + my $self = shift || __PACKAGE__->new; + if (! $self->isa(__PACKAGE__)) { # get_form(CGI->new) syntax + my $obj = $self; + $self = __PACKAGE__->new; + $self->object($obj); + } + return $self->{'form'} if $self->{'form'}; + + ### get the info out of the object + my $obj = shift || $self->object; + my %hash = (); + foreach my $key ($obj->param) { + my @val = $obj->param($key); + $hash{$key} = ($#val <= 0) ? $val[0] : \@val; + } + return $self->{'form'} = \%hash; } ### allow for a setter ### $cgix->set_form(\%form); sub set_form { - my $self = shift; - die 'Usage: $cgix_obj->set_form(\%form)' if ! ref $self; - $self->{'form'} = shift || {}; + my $self = shift || die 'Usage: $cgix_obj->set_form(\%form)'; + return $self->{'form'} = shift || {}; } ### Combined get and set form # my $hash = $cgix->form; # $cgix->form(\%form); sub form { - my $self = shift; - die (defined wantarray - ? 'Usage: my $form = $cgix_obj->form' : 'Usage: $cgix_obj->form(\%form)') - if ! UNIVERSAL::isa($self, __PACKAGE__); - return $self->set_form(shift) if $#_ != -1; - return $self->get_form; + my $self = shift; + return $self->set_form(shift) if @_ == 1; + return $self->get_form; } ### allow for creating a url encoded key value sequence # my $str = $cgix->make_form(\%form); # my $str = $cgix->make_form(\%form, \@keys_to_include); sub make_form { - my $self = shift; - die 'Usage: $cgix_obj->make_form(\%form)' if ! ref $self; - my $form = shift || $self->get_form; - my $keys = ref($_[0]) ? shift : [sort keys %$form]; - my $str = ''; - foreach (@$keys) { - my $key = $_; # make a copy - my $val = $form->{$key}; - $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg; - $key =~ y/ /+/; - foreach (ref($val) ? @$val : $val) { - my $_val = $_; # make a copy - $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg; - $_val =~ y/ /+/; - $str .= "$key=$_val&"; # intentionally not using join + my $self = shift || die 'Usage: $cgix_obj->make_form(\%form)'; + my $form = shift || $self->get_form; + my $keys = ref($_[0]) ? shift : [sort keys %$form]; + my $str = ''; + foreach (@$keys) { + my $key = $_; # make a copy + my $val = $form->{$key}; + $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg; + $key =~ y/ /+/; + foreach (ref($val) ? @$val : $val) { + my $_val = $_; # make a copy + $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg; + $_val =~ y/ /+/; + $str .= "$key=$_val&"; # intentionally not using join + } } - } - chop $str; - return $str; + chop $str; + return $str; } ###----------------------------------------------------------------### @@ -159,44 +155,37 @@ sub make_form { # my $hash = get_cookies(); # my $hash = get_cookies(CGI->new); sub get_cookies { - my $self = shift; - $self = __PACKAGE__->new if ! $self; - die 'Usage: $cgix_obj->get_cookies' if ! ref $self; - if (! UNIVERSAL::isa($self, __PACKAGE__)) { # get_cookies(CGI->new) syntax - my $obj = $self; - $self = __PACKAGE__->new; - $self->object($obj); - } - return $self->{'cookies'} if $self->{'cookies'}; - - my $obj = shift || $self->object; - use CGI::Ex::Dump qw(debug); - my %hash = (); - foreach my $key ($obj->cookie) { - my @val = $obj->cookie($key); - $hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val; - } - return $self->{'cookies'} = \%hash; + my $self = shift || __PACKAGE__->new; + if (! $self->isa(__PACKAGE__)) { # get_cookies(CGI->new) syntax + my $obj = $self; + $self = __PACKAGE__->new; + $self->object($obj); + } + return $self->{'cookies'} if $self->{'cookies'}; + + my $obj = shift || $self->object; + my %hash = (); + foreach my $key ($obj->cookie) { + my @val = $obj->cookie($key); + $hash{$key} = ($#val == -1) ? next : ($#val == 0) ? $val[0] : \@val; + } + return $self->{'cookies'} = \%hash; } ### Allow for a setter ### $cgix->set_cookies(\%cookies); sub set_cookies { - my $self = shift; - die 'Usage: $cgix_obj->set_cookies(\%cookies)' if ! ref $self; - $self->{'cookies'} = shift || {}; + my $self = shift || die 'Usage: $cgix_obj->set_cookies(\%cookies)'; + return $self->{'cookies'} = shift || {}; } ### Combined get and set cookies # my $hash = $cgix->cookies; # $cgix->cookies(\%cookies); sub cookies { - my $self = shift; - die (defined wantarray - ? 'Usage: my $hash = $cgix_obj->cookies' : 'Usage: $cgix_obj->cookies(\%cookies)') - if ! UNIVERSAL::isa($self, __PACKAGE__); - return $self->set_cookies(shift) if $#_ != -1; - return $self->get_cookies; + my $self = shift; + return $self->set_cookies(shift) if @_ == 1; + return $self->get_cookies; } ###----------------------------------------------------------------### @@ -205,33 +194,40 @@ sub cookies { # my $r = $cgix->apache_request # $cgix->apache_request($r); sub apache_request { - my $self = shift; - die 'Usage: $cgix_obj->apache_request' if ! ref $self; - $self->{'apache_request'} = shift if $#_ != -1; - if (! defined $self->{'apache_request'}) { - return if ! $self->mod_perl_version; - $self->{'apache_request'} = Apache->request; - } - return $self->{'apache_request'}; + my $self = shift || die 'Usage: $cgix_obj->apache_request'; + $self->{'apache_request'} = shift if $#_ != -1; + + if (! $self->{'apache_request'}) { + if ($self->is_mod_perl_1) { + require Apache; + $self->{'apache_request'} = Apache->request; + } elsif ($self->is_mod_perl_2) { + require Apache2::RequestRec; + require Apache2::RequestUtil; + $self->{'apache_request'} = Apache2::RequestUtil->request; + } + } + + return $self->{'apache_request'}; } ### Get the version of mod_perl running (0 if not mod_perl) # my $version = $cgix->mod_perl_version; sub mod_perl_version { - my $self = shift; - die 'Usage: $cgix_obj->mod_perl_version' if ! ref $self; - if (! defined $self->{'mod_perl_version'}) { - return 0 if ! $ENV{'MOD_PERL'}; - # mod_perl/1.27 or mod_perl/1.99_16 - # if MOD_PERL is set - don't die if regex fails - just assume 1.0 - $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m|^mod_perl/(\d+\.[\d_]+)$|) - ? $1 : '1.0_0'; - } - return $self->{'mod_perl_version'}; + my $self = shift || die 'Usage: $cgix_obj->mod_perl_version'; + + if (! defined $self->{'mod_perl_version'}) { + return 0 if ! $ENV{'MOD_PERL'}; + # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1 + # if MOD_PERL is set - don't die if regex fails - just assume 1.0 + $self->{'mod_perl_version'} = ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) + ? $1 : '1.0_0'; + } + return $self->{'mod_perl_version'}; } -sub is_mod_perl_1 { shift->mod_perl_version < 1.98 } -sub is_mod_perl_2 { shift->mod_perl_version >= 1.98 } +sub is_mod_perl_1 { my $m = shift->mod_perl_version; return $m < 1.98 && $m > 0 } +sub is_mod_perl_2 { my $m = shift->mod_perl_version; return $m >= 1.98 } ### Allow for a setter # $cgix->set_apache_request($r) @@ -240,9 +236,7 @@ sub set_apache_request { shift->apache_request(shift) } ###----------------------------------------------------------------### ### same signature as print_content_type -sub content_type { - &print_content_type; -} +sub content_type { &print_content_type } ### will send the Content-type header # $cgix->print_content_type; @@ -250,41 +244,39 @@ sub content_type { # print_content_type(); # print_content_type('text/plain); sub print_content_type { - my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift); - $self = __PACKAGE__->new if ! $self; - die 'Usage: $cgix_obj->print_content_type' if ! ref $self; - if ($type) { - die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo - } else { - $type = 'text/html'; - } - - if (my $r = $self->apache_request) { - return if $r->bytes_sent; - $r->content_type($type); - $r->send_http_header if $self->is_mod_perl_1; - } else { - if (! $ENV{'CONTENT_TYPED'}) { - print "Content-Type: $type\r\n\r\n"; - $ENV{'CONTENT_TYPED'} = ''; + my ($self, $type) = ($#_ >= 1) ? @_ : ref($_[0]) ? (shift, undef) : (undef, shift); + $self = __PACKAGE__->new if ! $self; + + if ($type) { + die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo + } else { + $type = 'text/html'; + } + + if (my $r = $self->apache_request) { + return if $r->bytes_sent; + $r->content_type($type); + $r->send_http_header if $self->is_mod_perl_1; + } else { + if (! $ENV{'CONTENT_TYPED'}) { + print "Content-Type: $type\r\n\r\n"; + $ENV{'CONTENT_TYPED'} = ''; + } + $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]); } - $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]); - } } ### Boolean check if content has been typed # $cgix->content_typed; # content_typed(); sub content_typed { - my $self = shift; - $self = __PACKAGE__->new if ! $self; - die 'Usage: $cgix_obj->content_typed' if ! ref $self; - - if (my $r = $self->apache_request) { - return $r->bytes_sent; - } else { - return ($ENV{'CONTENT_TYPED'}) ? 1 : undef; - } + my $self = shift || __PACKAGE__->new; + + if (my $r = $self->apache_request) { + return $r->bytes_sent; + } else { + return $ENV{'CONTENT_TYPED'} ? 1 : undef; + } } ###----------------------------------------------------------------### @@ -294,36 +286,35 @@ sub content_typed { # $cgix->location_bounce($url); # location_bounce($url); sub location_bounce { - my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift); - $self = __PACKAGE__->new if ! $self; - die 'Usage: $cgix_obj->location_bounce($url)' if ! ref $self; + my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift); + $self = __PACKAGE__->new if ! $self; + + if ($self->content_typed) { + if ($DEBUG_LOCATION_BOUNCE) { + print "Location: $loc
\n"; + } else { + print "\n"; + } + + } elsif (my $r = $self->apache_request) { + $r->status(302); + if ($self->is_mod_perl_1) { + $r->header_out("Location", $loc); + $r->content_type('text/html'); + $r->send_http_header; + $r->print("Bounced to $loc\n"); + } else { + $r->headers_out->add("Location", $loc); + $r->content_type('text/html'); + $r->rflush; + } - if ($self->content_typed) { - if ($DEBUG_LOCATION_BOUNCE) { - print "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"; + 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 @@ -333,35 +324,34 @@ sub location_bounce { # 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); - } + 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 { - print "Set-Cookie: $cookie\r\n" + if (my $r = $self->apache_request) { + if ($self->is_mod_perl_1) { + $r->header_out("Set-cookie", $cookie); + } else { + $r->headers_out->add("Set-Cookie", $cookie); + } + } else { + print "Set-Cookie: $cookie\r\n"; + } } - } } ### print the last modified time @@ -369,119 +359,108 @@ sub set_cookie { # $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); - } + my $self = shift || die 'Usage: $cgix_obj->last_modified($time)'; # may be called as function or method + my $time = shift || time; + my $key = shift || 'Last-Modified'; + + ### get a time string - looks like: + ### Mon Dec 9 18:03:21 2002 + ### valid RFC (although not prefered) + $time = scalar gmtime time_calc($time); + + if ($self->content_typed) { + print "\n"; + } elsif (my $r = $self->apache_request) { + if ($self->is_mod_perl_1) { + $r->header_out($key, $time); + } else { + $r->headers_out->add($key, $time); + } } else { - print "$key: $time\r\n" + print "$key: $time\r\n"; } - } - } ### add expires header sub expires { - my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as a function or method - my $time = shift || time; - return $self->last_modified($time, 'Expires'); + my $self = ref($_[0]) ? shift : __PACKAGE__->new; # may be called as a function or method + my $time = shift || time; + return $self->last_modified($time, 'Expires'); } ### similar to expires_calc from CGI::Util ### allows for lenient calling, hour instead of just h, etc ### takes time or 0 or now or filename or types of -23minutes sub time_calc { - my $time = shift; # may only be called as a function - if (! $time || lc($time) eq 'now') { - return time; - } elsif ($time =~ m/^\d+$/) { - return $time; - } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) { - my $m = { - 's' => 1, - 'm' => 60, - 'h' => 60 * 60, - 'd' => 60 * 60 * 24, - 'w' => 60 * 60 * 24 * 7, - 'M' => 60 * 60 * 24 * 30, - 'y' => 60 * 60 * 24 * 365, - }; - return time + ($m->{lc($3)} || 1) * "$1$2"; - } else { - my @stat = stat $time; - die "Could not find file \"$time\" for time_calc" if $#stat == -1; - return $stat[9]; - } + my $time = shift; # may only be called as a function + if (! $time || lc($time) eq 'now') { + return time; + } elsif ($time =~ m/^\d+$/) { + return $time; + } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) { + my $m = { + 's' => 1, + 'm' => 60, + 'h' => 60 * 60, + 'd' => 60 * 60 * 24, + 'w' => 60 * 60 * 24 * 7, + 'M' => 60 * 60 * 24 * 30, + 'y' => 60 * 60 * 24 * 365, + }; + return time + ($m->{lc($3)} || 1) * "$1$2"; + } else { + my @stat = stat $time; + die "Could not find file \"$time\" for time_calc" if $#stat == -1; + return $stat[9]; + } } ### allow for generic status send sub send_status { - my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method - my $code = shift || die "Missing status"; - my $mesg = shift; - if (! defined $mesg) { - $mesg = "HTTP Status of $code received\n"; - } - if ($self->content_typed) { - die "Cannot send a status ($code - $mesg) after content has been sent"; - } - if (my $r = $self->apache_request) { - $r->status($code); - if ($self->is_mod_perl_1) { - $r->content_type('text/html'); - $r->send_http_header; - $r->print($mesg); + my $self = shift || die 'Usage: $cgix_obj->send_status(302 => "Bounced")'; + my $code = shift || die "Missing status"; + my $mesg = shift; + if (! defined $mesg) { + $mesg = "HTTP Status of $code received\n"; + } + if ($self->content_typed) { + die "Cannot send a status ($code - $mesg) after content has been sent"; + } + if (my $r = $self->apache_request) { + $r->status($code); + if ($self->is_mod_perl_1) { + $r->content_type('text/html'); + $r->send_http_header; + $r->print($mesg); + } else { + # not sure of best way to send the message in MP2 + } } else { - # not sure of best way to send the message in MP2 + print "Status: $code\r\n"; + $self->print_content_type; + print $mesg; } - } else { - print "Status: $code\r\n"; - $self->print_content_type; - print $mesg; - } } ### allow for sending a simple header sub send_header { - my $self = ref($_[0]) ? shift : __PACKAGE__; # may be called as function or method - my $key = shift; - my $value = shift; - if ($self->content_typed) { - die "Cannot send a header ($key - $value) after content has been sent"; - } - if (my $r = $self->apache_request) { - if ($self->is_mod_perl_1) { - $r->header_out($key, $value); + my $self = shift || die 'Usage: $cgix_obj->send_header'; + my $key = shift; + my $val = shift; + if ($self->content_typed) { + die "Cannot send a header ($key - $val) after content has been sent"; + } + if (my $r = $self->apache_request) { + if ($self->is_mod_perl_1) { + $r->header_out($key, $val); + } else { + $r->headers_out->add($key, $val); + } } else { - my $t = $r->headers_out; - $t->add($key, $value); - $r->headers_out($t); + print "$key: $val\r\n"; } - } else { - print "$key: $value\r\n"; - } } ###----------------------------------------------------------------### @@ -489,59 +468,51 @@ sub send_header { ### allow for printing out a static javascript file ### for example $self->print_js("CGI::Ex::validate.js"); sub print_js { - my ($self, $js_file) = ($#_ == 1) ? (@_) : (__PACKAGE__, shift); - $self = $self->new if ! ref $self; - - ### fix up the file - force .js on the end - $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i; - $js_file =~ s|::|/|g; - - ### get file info - my $stat; - if (! $js_file) { - # do nothing - give the 404 - } elsif ($js_file !~ m|^\.{0,2}/|) { - foreach my $path (@INC) { - my $_file = "$path/$js_file"; - next if ! -f $_file; - $js_file = $_file; - $stat = [stat _]; - last; + my $self = shift || die 'Usage: $cgix_obj->print_js($js_file)'; + my $js_file = shift || ''; + $self = $self->new if ! ref $self; + + ### fix up the file - force .js on the end + $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i; + $js_file =~ s|::|/|g; + + ### get file info + my $stat; + if ($js_file && $js_file =~ m|^(\w+(?:/+\w+)*\.js)$|i) { + foreach my $path (@INC) { + my $_file = "$path/$1"; + next if ! -f $_file; + $js_file = $_file; + $stat = [stat _]; + last; + } } - } else { - if (-f $js_file) { - $stat = [stat _]; + + ### no file = 404 + if (! $stat) { + if (! $self->content_typed) { + $self->send_status(404, "JS File not found for print_js\n"); + } else { + print "

JS File not found for print_js

\n"; + } + return; } - } - ### no - file - 404 - if (! $stat) { + ### do headers if (! $self->content_typed) { - $self->send_status(404, "JS File not found for print_js\n"); - } else { - print "

JS File not found for print_js

\n"; + $self->last_modified($stat->[9]); + $self->expires('+ 1 year'); + $self->print_content_type('application/x-javascript'); } - return; - } + return if $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'HEAD'; - ### do headers - if (! $self->content_typed) { - $self->last_modified($stat->[9]); - $self->expires('+ 1 year'); - $self->print_content_type('application/x-javascript'); - } - - return if $ENV{REQUEST_METHOD} && $ENV{REQUEST_METHOD} eq 'HEAD'; - - ### send the contents - if (open IN, $js_file) { + ### send the contents + local *FH; + open(FH, "<$js_file") || die "Couldn't open file $js_file: $!"; local $/ = undef; - print ; - close IN; - } else { - die "Couldn't open file $js_file: $!"; - } + print ; + close FH; } ###----------------------------------------------------------------### @@ -550,191 +521,130 @@ sub print_js { ### or another specified filler. Argument style is similar to ### HTML::FillInForm. May be called as a method or a function. sub fill { - my $self = shift; - my $args = shift; - if (ref($args)) { - if (! UNIVERSAL::isa($args, 'HASH')) { - $args = {text => $args}; - @$args{'form','target','fill_password','ignore_fields'} = @_; - } - } else { - $args = {$args, @_}; - } - - my $module = $self->{fill_module} || $PREFERRED_FILL_MODULE; - - ### allow for using the standard HTML::FillInForm - ### too bad it won't modify our file in place for us - if ($module eq 'HTML::FillInForm') { - eval { require HTML::FillInForm }; - if ($@) { - die "Couldn't require HTML::FillInForm: $@"; - } - $args->{scalarref} = $args->{text} if $args->{text}; - $args->{fdat} = $args->{form} if $args->{form}; - my $filled = HTML::FillInForm->new->fill(%$args); - if ($args->{text}) { - my $ref = $args->{text}; - $$ref = $filled; - return 1; - } - return $filled; - - ### allow for some other type - for whatever reason - } elsif ($module) { - my $file = $module; - $file .= '.pm' if $file !~ /\.\w+$/; - $file =~ s|::|/|g; - eval { require $file }; - if ($@) { - die "Couldn't require $module: $@"; - } - return $module->new->fill(%$args); - - ### well - we will use our own then - } else { - require CGI::Ex::Fill; - - ### get the text to work on - my $ref; - if ($args->{text}) { # preferred method - gets modified in place - $ref = $args->{text}; - } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm - my $str = ${ $args->{scalarref} }; - $ref = \$str; - } elsif ($args->{arrayref}) { # joined together (copy) - my $str = join "", @{ $args->{arrayref} }; - $ref = \$str; - } elsif ($args->{file}) { # read it in - open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!"; - my $str = ''; - read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!"; - close IN; - $ref = \$str; + my $self = shift; + my $args = shift; + if (ref($args)) { + if (! UNIVERSAL::isa($args, 'HASH')) { + $args = {text => $args}; + @$args{'form','target','fill_password','ignore_fields'} = @_; + } } else { - die "No suitable text found for fill."; + $args = {$args, @_}; } - ### allow for data to be passed many ways - my $form = $args->{form} || $args->{fobject} - || $args->{fdat} || $self->object; - - &CGI::Ex::Fill::form_fill($ref, - $form, - $args->{target}, - $args->{fill_password}, - $args->{ignore_fields}, - ); - return ! $args->{text} ? $$ref : 1; - } + my $module = $self->{'fill_module'} || 'CGI::Ex::Fill'; + + ### allow for using the standard HTML::FillInForm + ### too bad it won't modify our file in place for us + if ($module eq 'HTML::FillInForm') { + eval { require HTML::FillInForm }; + if ($@) { + die "Couldn't require HTML::FillInForm: $@"; + } + $args->{scalarref} = $args->{text} if $args->{text}; + $args->{fdat} = $args->{form} if $args->{form}; + my $filled = HTML::FillInForm->new->fill(%$args); + if ($args->{text}) { + my $ref = $args->{text}; + $$ref = $filled; + return 1; + } + return $filled; + + } else { + require CGI::Ex::Fill; + + ### get the text to work on + my $ref; + if ($args->{text}) { # preferred method - gets modified in place + $ref = $args->{text}; + } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm + my $str = ${ $args->{scalarref} }; + $ref = \$str; + } elsif ($args->{arrayref}) { # joined together (copy) + my $str = join "", @{ $args->{arrayref} }; + $ref = \$str; + } elsif ($args->{file}) { # read it in + open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!"; + my $str = ''; + read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!"; + close IN; + $ref = \$str; + } else { + die "No suitable text found for fill."; + } + + ### allow for data to be passed many ways + my $form = $args->{form} || $args->{fobject} + || $args->{fdat} || $self->object; + + CGI::Ex::Fill::form_fill($ref, + $form, + $args->{target}, + $args->{fill_password}, + $args->{ignore_fields}, + ); + return ! $args->{text} ? $$ref : 1; + } } ###----------------------------------------------------------------### sub validate { - my $self = shift || die "Sub \"validate\" must be called as a method"; - my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift); + my $self = shift || die 'Usage: my $er = $cgix_obj->validate($form, $val_hash_or_file)'; + my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift); - require CGI::Ex::Validate; + require CGI::Ex::Validate; - my $args = {}; - $args->{raise_error} = 1 if $self->{raise_error}; - return CGI::Ex::Validate->new($args)->validate($form, $file); + my $args = {}; + $args->{raise_error} = 1 if $self->{raise_error}; + return CGI::Ex::Validate->new($args)->validate($form, $file); } ###----------------------------------------------------------------### sub conf_obj { - my $self = shift || die "Sub \"conf_obj\" must be called as a method"; - return $self->{conf_obj} ||= do { - require CGI::Ex::Conf; - CGI::Ex::Conf->new(@_); - }; + my $self = shift || die 'Usage: my $ob = $cgix_obj->conf_obj($args)'; + return $self->{conf_obj} ||= do { + require CGI::Ex::Conf; + CGI::Ex::Conf->new(@_); + }; } sub conf_read { - my $self = shift || die "Sub \"conf_read\" must be called as a method"; - return $self->conf_obj->read(@_); + my $self = shift || die 'Usage: my $conf = $cgix_obj->conf_read($file)'; + return $self->conf_obj->read(@_); } ###----------------------------------------------------------------### -### This is intended as a simple yet strong subroutine to swap -### in tags to a document. It is intended to be very basic -### for those who may not want the full features of a Templating -### system such as Template::Toolkit (even though they should -### investigate them because they are pretty nice) sub swap_template { - my $self = shift || die "Sub \"swap_template\" must be called as a method"; - my $str = shift; - return $str if ! $str; - my $ref = ref($str) ? $str : \$str; - - ### basic - allow for passing a hash, or object, or code ref - my $form = shift; - $form = $self if ! $form && ref($self); - $form = $self->get_form() if UNIVERSAL::isa($form, __PACKAGE__); - - my $get_form_value; - if (UNIVERSAL::isa($form, 'HASH')) { - $get_form_value = sub { - my $key = shift; - return defined($form->{$key}) ? $form->{$key} : ''; - }; - } elsif (my $meth = UNIVERSAL::can($form, 'param')) { - $get_form_value = sub { - my $key = shift; - my $val = $form->$meth($key); - return defined($val) ? $val : ''; - }; - } elsif (UNIVERSAL::isa($form, 'CODE')) { - $get_form_value = sub { - my $key = shift; - my $val = &{ $form }($key); - return defined($val) ? $val : ''; - }; - } else { - die "Not sure how to use $form passed to swap_template_tags"; - } - - ### now do the swap - $$ref =~ s{$TEMPLATE_OPEN \b (\w+) ((?:\.\w+)*) \b $TEMPLATE_CLOSE}{ - if (! $2) { - &$get_form_value($1); + my $self = shift || die 'Usage: my $out = $cgix_obj->swap_template($file, \%vars, $template_args)'; + my $str = shift; + my $form = shift; + my $args = shift || {}; + $form = $self if ! $form && ref($self); + $form = $self->get_form if UNIVERSAL::isa($form, __PACKAGE__); + + my ($ref, $return) = ref($str) ? ($str, 0) : (\$str, 1); + + ### look up the module + my $module = $self->{'template_module'} || 'CGI::Ex::Template'; + my $pkg = "$module.pm"; + $pkg =~ s|::|/|g; + require $pkg; + + ### swap it + my $out = ''; + $module->new($args)->process($ref, $form, \$out); + + if (! $return) { + $$ref = $out; + return 1; } else { - my @extra = split(/\./, substr($2,1)); - my $ref = &$get_form_value($1); - my $val; - while (defined(my $key = shift(@extra))) { - if (UNIVERSAL::isa($ref, 'HASH')) { - if (! exists($ref->{$key}) || ! defined($ref->{$key})) { - $val = ''; - last; - } - $ref = $ref->{$key}; - } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if (! exists($ref->[$key]) || ! defined($ref->[$key])) { - $val = ''; - last; - } - $ref = $ref->[$key]; - } else { - $val = ''; - last; - } - } - if (! defined($val)) { - if ($#extra == -1) { - $val = $ref; - } - $val = '' if ! defined($val); - } - $val; # return of the swap + return $out; } - }xeg; - - return ref($str) ? 1 : $$ref; } ###----------------------------------------------------------------### @@ -743,90 +653,45 @@ sub swap_template { __END__ -=head1 NAME +=head1 CGI::Ex SYNOPSIS -CGI::Ex - CGI utility suite (form getter/filler/validator/app builder) + ### You probably don't want to use CGI::Ex directly + ### You probably should use CGI::Ex::App instead. -=head1 SYNOPSIS + my $cgix = CGI::Ex->new; - ### CGI Module Extensions + $cgix->print_content_type; - my $cgix = CGI::Ex->new; - my $hashref = $cgix->get_form; # uses CGI by default - - ### send the Content-type header - whether or not we are mod_perl - $cgix->print_content_type; - - my $val_hash = $cgix->conf_read($pathtovalidation); - - my $err_obj = $cgix->validate($hashref, $val_hash); - if ($err_obj) { - my $errors = $err_obj->as_hash; - my $input = "Some content"; - my $content = ""; - SomeTemplateObject->process($input, $errors, $content); - $cgix->fill({text => \$content, form => $hashref}); - print $content; - exit; - } - - print "Success\n"; - - ### Filling functionality - - $cgix->fill({text => \$text, form => \%hash}); - $cgix->fill({text => \$text, fdat => \%hash}); - $cgix->fill({text => \$text, fobject => $cgiobject}); - $cgix->fill({text => \$text, form => [\%hash1, $cgiobject]}); - $cgix->fill({text => \$text); # uses $self->object as the form - $cgix->fill({text => \$text, - form => \%hash, - target => 'formname', - fill_password => 0, - ignore_fields => ['one','two']}); - $cgix->fill(\$text); # uses $self->object as the form - $cgix->fill(\$text, \%hash, 'formname', 0, ['one','two']); - my $copy = $cgix->fill({scalarref => \$text, fdat => \%hash}); - my $copy = $cgix->fill({arrayref => \@lines, fdat => \%hash}); - my $copy = $cgix->fill({file => $filename, fdat => \%hash}); - - ### Validation functionality - - my $err_obj = $cgix->validate($form, $val_hash); - my $err_obj = $cgix->validate($form, $path_to_validation); - my $err_obj = $cgix->validate($form, $yaml_string); - - ### get errors separated by key name - ### useful for inline errors - my $hash = $err_obj->as_hash; - my %hash = $err_obj->as_hash; - - ### get aggregate list of errors - ### useful for central error description - my $array = $err_obj->as_array; - my @array = $err_obj->as_array; - - ### get a string - ### useful for central error description - my $string = $err_obj->as_string; - my $string = "$err_obj"; - - $cgix->{raise_error} = 1; - $cgix->validate($form, $val_hash); - # SAME AS # - my $err_obj = $cgix->validate($form, $val_hash); - die $err_obj if $err_obj; - - ### Settings functionality - - ### read file via yaml - my $ref = $cgix->conf_read('/full/path/to/conf.yaml'); - - ### merge all found settings.pl files together - @CGI::Ex::Conf::DEFAULT_PATHS = qw(/tmp /my/data/dir /home/foo); - @CGI::Ex::Conf::DIRECTIVE = 'MERGE'; - @CGI::Ex::Conf::DEFAULT_EXT = 'pl'; - my $ref = $cgix->conf_read('settings'); + my $hash = $cgix->form; + + if ($hash->{'bounce'}) { + + $cgix->set_cookie({ + name => ..., + value => ..., + }); + + $cgix->location_bounce($new_url_location); + exit; + } + + if (scalar keys %$form) { + my $val_hash = $cgix->conf_read($pathtovalidation); + my $err_obj = $cgix->validate($hash, $val_hash); + if ($err_obj) { + my $errors = $err_obj->as_hash; + my $input = "Some content"; + my $content = ""; + $cgix->swap_template(\$input, $errors, $content); + $cgix->fill({text => \$content, form => $hashref}); + print $content; + exit; + } else { + print "Success"; + } + } else { + print "Main page"; + } =head1 DESCRIPTION @@ -834,21 +699,21 @@ 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. +to the next step. CGI::Ex::App is not quite a framework (which normally +includes pre-built html) instead CGI::Ex::App is an extended application +flow that dramatically reduces CGI build time in most cases. It does so +using as little magic as possible. See L. 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 Template::Toolkit compatible processing engine. With a few limitations, +CGI::Ex::Template can be a drop in replacement for Template::Toolkit. + =item C A regular expression based form filler inner (accessed through B<-Efill> @@ -871,9 +736,14 @@ 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. +=item C + +A highly configurable web based authentication system. See L for +more information. + =back -=head1 METHODS +=head1 CGI::Ex METHODS =over 4 @@ -894,7 +764,7 @@ follows (and in order of position): Text should be a reference to a scalar string containing the html to be modified (actually it could be any reference or object reference -that can be modfied as a string). It will be modified in place. +that can be modified as a string). It will be modified in place. Another named argument B is available if you would like to copy rather than modify. @@ -904,11 +774,11 @@ 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 +expect the field name as an argument and should return a value. +Values returned by form may be undef, scalar, arrayref, or coderef (coderef values should expect an argument of field name and should return a value). The code ref options are available to delay or add -options to the bringing in of form informatin - without having to +options to the bringing in of form information - without having to tie the hash. Coderefs are not available in HTML::FillInForm. Also HTML::FillInForm only allows CGI objects if an arrayref is used. @@ -933,7 +803,7 @@ not available in CGI::Ex::Fill. =back -Other named arguments are available for compatiblity with HTML::FillInForm. +Other named arguments are available for compatibility with HTML::FillInForm. They may only be used as named arguments. =over 4 @@ -997,18 +867,37 @@ be read in depending upon file extension. =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 - +arrays. Not sure why CGI didn't do this anyway (well - yes - legacy Perl 4 - but at some point things need to be updated). + my $hash = $cgix->get_form; + my $hash = $cgix->get_form(CGI->new); + my $hash = get_form(); + my $hash = get_form(CGI->new); + =item C<-Eset_form> Allow for setting a custom form hash. Useful for testing, or other purposes. + $cgix->set_form(\%new_form); + =item C<-Eget_cookies> Returns a hash of all cookies. + my $hash = $cgix->get_cookies; + my $hash = $cgix->get_cookies(CGI->new); + my $hash = get_cookies(); + my $hash = get_cookies(CGI->new); + +=item C<-Eset_cookies> + +Allow for setting a custom cookies hash. Useful for testing, or other +purposes. + + $cgix->set_cookies(\%new_cookies); + =item C<-Emake_form> Takes a hash and returns a query_string. A second optional argument @@ -1114,7 +1003,7 @@ return the proper value. #$str eq "(bar)
# (wow)
# (wee) "; - + For further examples, please see the code contained in t/samples/cgi_ex_* of this distribution. @@ -1124,45 +1013,24 @@ 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. -See also L. - See also L. +See also L. + +See also L. + +See also L. + =head1 AUTHOR Paul Seamons diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index 552045a..a177c7f 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -1,50 +1,38 @@ package CGI::Ex::App; -### CGI Extended Application - ###----------------------------------------------------------------### -# Copyright 2004 - Paul Seamons # +# See the perldoc in CGI/Ex/App.pod +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - - use strict; -use vars qw($VERSION - $EXT_PRINT $EXT_VAL $BASE_DIR_REL $BASE_DIR_ABS $BASE_NAME_MODULE - $RECURSE_LIMIT - %CLEANUP_EXCLUDE); - -$VERSION = '1.14'; -use CGI::Ex::Dump qw(debug); +use vars qw($VERSION); BEGIN { - ### Default file locations - ### these are used for the provided stub functions - if you are not - ### using the stub functions - then you won't need to worry about these - $EXT_PRINT ||= 'html'; - $EXT_VAL ||= 'val'; - $BASE_DIR_REL ||= ''; # relative path - stub methods will look in $BASE_DIR_REL/dir/of/content.html - $BASE_DIR_ABS ||= ''; # content should be found at "$BASE_DIR_ABS/$BASE_DIR_REL/dir/of/content.html" - $BASE_NAME_MODULE ||= ''; # the cgi name + $VERSION = '2.00'; - ### list of modules to exclude during cleanup - ### this takes care of situations such as - ### template toolkits rules area which contains - ### a nested structure of rules and sub references. - $CLEANUP_EXCLUDE{'Template::Parser'} = 1; + Time::HiRes->import('time') if eval {require Time::HiRes}; } +sub croak { + my $msg = shift; + $msg = 'Something happened' if ! defined $msg; + die $msg if ref $msg || $msg =~ /\n\z/; + my ($pkg, $file, $line, $sub) = caller(1); + die "$msg in ${sub}() at $file line $line\n"; +} ###----------------------------------------------------------------### sub new { - my $class = shift || __PACKAGE__; - my $self = ref($_[0]) ? shift : {@_}; - bless $self, $class; - $self->init; - return $self; + my $class = shift || croak "Usage: Package->new"; + my $self = shift || {}; + bless $self, $class; + + $self->init; + + return $self; } sub init {} @@ -52,411 +40,414 @@ sub init {} ###----------------------------------------------------------------### sub navigate { - my $self = shift; - my $args = ref($_[0]) ? shift : {@_}; - $self = $self->new($args) if ! ref $self; + my ($self, $args) = @_; + $self = $self->new($args) if ! ref $self; - eval { + $self->{'_time'} = time; - ### a chance to do things at the very beginning - return $self if $self->pre_navigate; - - ### run the step loop eval { - local $self->{'__morph_lineage_start_index'} = $#{$self->{'__morph_lineage'} || []}; - $self->nav_loop; - }; - if ($@) { - ### rethrow the error unless we long jumped out of recursive nav_loop calls - die $@ if $@ ne "Long Jump\n"; - } + ### allow for authentication + my $ref = $self->require_auth; + if ($ref && ! ref $ref) { + return $self if ! $self->get_valid_auth; + } - ### one chance to do things at the very end - $self->post_navigate; + ### a chance to do things at the very beginning + return $self if ! $self->{'_no_pre_navigate'} && $self->pre_navigate; + + ### run the step loop + eval { + local $self->{'__morph_lineage_start_index'} = $#{$self->{'__morph_lineage'} || []}; + $self->nav_loop; + }; + if ($@) { + ### rethrow the error unless we long jumped out of recursive nav_loop calls + croak $@ if $@ ne "Long Jump\n"; + } + + ### one chance to do things at the very end + $self->post_navigate if ! $self->{'_no_post_navigate'}; - }; - ### catch errors - if any - if ($@) { - $self->handle_error($@); - } + }; + $self->handle_error($@) if $@; # catch any errors + + $self->{'_time'} = time; - return $self; + return $self; } sub nav_loop { - my $self = shift; + my $self = shift; - ### keep from an infinate nesting - local $self->{recurse} = $self->{recurse} || 0; - if ($self->{recurse} ++ >= $self->recurse_limit) { - my $err = "recurse_limit reached (".$self->recurse_limit.")"; - $err .= " number of jumps (".$self->{jumps}.")" if ($self->{jumps} || 0) > 1; - die $err; - } - - ### get the path (simple arrayref based thing) - my $path = $self->path; - - ### allow for an early return - return if $self->pre_loop($path); # a true value means to abort the navigate - - ### get a hash of valid paths (if any) - my $valid_steps = $self->valid_steps; - - ### iterate on each step of the path - foreach ($self->{path_i} ||= 0; - $self->{path_i} <= $#$path; - $self->{path_i} ++) { - my $step = $path->[$self->{path_i}]; - next if $step !~ /^[a-zA-Z_]\w*$/; # don't process the step if it contains odd characters - - ### check if this is an allowed step - if ($valid_steps) { - if (! $valid_steps->{$step} - && $step ne $self->default_step - && $step ne 'forbidden') { - $self->stash->{'forbidden_step'} = $step; - $self->replace_path('forbidden'); - next; - } + ### keep from an infinate nesting + local $self->{'recurse'} = $self->{'recurse'} || 0; + if ($self->{'recurse'} ++ >= $self->recurse_limit) { + my $err = "recurse_limit (".$self->recurse_limit.") reached"; + $err .= " number of jumps (".$self->{'jumps'}.")" if ($self->{'jumps'} || 0) > 1; + croak $err; } - ### allow for becoming another package (allows for some steps in external files) - $self->morph($step); - - ### run the guts of the step - my $status = $self->run_hook('run_step', $step); + my $path = $self->path; - $self->unmorph($step); + ### allow for an early return + return if $self->pre_loop($path); # a true value means to abort the navigate - ### Allow for the run_step to intercept. - ### A true status means the run_step took over navigation. - return if $status; - } + my $req_auth = ref($self->require_auth) ? $self->require_auth : undef; - ### allow for one exit point after the loop - return if $self->post_loop($path); # a true value means to abort the navigate - - ### run the default step as a last resort - $self->insert_path($self->default_step); - $self->nav_loop; # go recursive + ### iterate on each step of the path + foreach ($self->{'path_i'} ||= 0; + $self->{'path_i'} <= $#$path; + $self->{'path_i'} ++) { + my $step = $path->[$self->{'path_i'}]; + if ($step !~ /^([^\W0-9]\w*)$/) { # don't process the step if it contains odd characters + $self->stash->{'forbidden_step'} = $step; + $self->replace_path($self->forbidden_step); + next; + } + $step = $1; # untaint - return; -} + ### allow for per-step authentication + if ($req_auth + && $req_auth->{$step} + && ! $self->get_valid_auth) { + return; + } -sub pre_navigate {} + ### allow for becoming another package (allows for some steps in external files) + $self->morph($step); -sub post_navigate {} + ### run the guts of the step + my $status = $self->run_hook('run_step', $step); -sub recurse_limit { shift->{'recurse_limit'} || $RECURSE_LIMIT || 15 } + $self->unmorph($step); -sub run_step { - my $self = shift; - my $step = shift; + ### Allow for the run_step to intercept. + ### A true status means the run_step took over navigation. + return if $status; + } - ### if the pre_step exists and returns true, exit the nav_loop - return 1 if $self->run_hook('pre_step', $step); + ### allow for one exit point after the loop + return if $self->post_loop($path); # a true value means to abort the navigate - ### allow for skipping this step (but stay in the nav_loop) - return 0 if $self->run_hook('skip', $step); + ### run the default step as a last resort + $self->insert_path($self->default_step); + $self->nav_loop; # go recursive - ### see if we have complete valid information for this step - ### if so, do the next step - ### if not, get necessary info and print it out - if ( ! $self->run_hook('prepare', $step, 1) - || ! $self->run_hook('info_complete', $step) - || ! $self->run_hook('finalize', $step, 1)) { + return; +} - ### show the page requesting the information - $self->run_hook('prepared_print', $step); +sub pre_navigate { 0 } # true means to not enter nav_loop - ### a hook after the printing process - $self->run_hook('post_print', $step); +sub post_navigate {} - return 2; - } +sub pre_loop { 0 } # true value means to abort the nav_loop routine - ### a hook before end of loop - ### if the post_step exists and returns true, exit the nav_loop - return 1 if $self->run_hook('post_step', $step); +sub post_loop { 0 } # true value means to abort the nav_loop - don't recurse - ### let the nav_loop continue searching the path - return 0; -} +sub recurse_limit { shift->{'recurse_limit'} || 15 } -### standard functions for printing - gather information -sub prepared_print { +### default die handler - show what happened and die (so its in the error logs) +sub handle_error { my $self = shift; - my $step = shift; - - my $hash_base = $self->run_hook('hash_base', $step); - my $hash_comm = $self->run_hook('hash_common', $step); - my $hash_form = $self->run_hook('hash_form', $step); - my $hash_fill = $self->run_hook('hash_fill', $step); - my $hash_swap = $self->run_hook('hash_swap', $step); - my $hash_errs = $self->run_hook('hash_errors', $step); - $_ ||= {} foreach $hash_base, $hash_comm, $hash_form, $hash_fill, $hash_swap, $hash_errs; - - ### fix up errors - $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) - foreach keys %$hash_errs; - $hash_errs->{has_errors} = 1 if scalar keys %$hash_errs; - - ### layer hashes together - my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill}; - my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs}; - $fill = {} if $self->no_fill($step); + my $err = shift; - ### run the print hook - passing it the form and fill info - $self->run_hook('print', $step, undef, - $swap, $fill); + die $err; } -sub no_fill { shift->{'no_fill'} } - -sub exit_nav_loop { - my $self = shift; - - ### undo morphs - if (my $ref = $self->{'__morph_lineage'}) { - ### use the saved index - this allows for early "morphers" to only get rolled back so far - my $index = $self->{'__morph_lineage_start_index'}; - $index = -1 if ! defined $index; - $self->unmorph while $#$ref != $index; - } +###----------------------------------------------------------------### - ### long jump back - die "Long Jump\n"; -} +sub default_step { shift->{'default_step'} || 'main' } -sub jump { - my $self = shift; - my $i = ($#_ == -1) ? 1 : shift; - my $path = $self->path; - my $path_i = $self->{path_i}; - die "Can't jump if nav_loop not started" if ! defined $path_i; - - ### validate where we are jumping to - if ($i =~ /^\w+$/) { - if ($i eq 'FIRST') { - $i = - $path_i - 1; - } elsif ($i eq 'LAST') { - $i = $#$path - $path_i; - } elsif ($i eq 'NEXT') { - $i = 1; - } elsif ($i eq 'CURRENT') { - $i = 0; - } elsif ($i eq 'PREVIOUS') { - $i = -1; - } else { # look for a step by that name - for (my $j = $#$path; $j >= 0; $j --) { - if ($path->[$j] eq $i) { - $i = $j - $path_i; - last; - } - } - } - } - if ($i !~ /^-?\d+$/) { - require Carp; - Carp::croak("Invalid jump index ($i)"); - } - - ### manipulate the path to contain the new jump location - my @replace; - my $cut_i = $path_i + $i; - if ($cut_i > $#$path) { - push @replace, $self->default_step; - } elsif ($cut_i < 0) { - push @replace, @$path; - } else { - push @replace, @$path[$cut_i .. $#$path]; - } - $self->replace_path(@replace); - - ### record the number of jumps - $self->{jumps} ||= 0; - $self->{jumps} ++; - - ### run the newly fixed up path (recursively) - $self->{path_i} ++; # move along now that the path is updated - $self->nav_loop; - $self->exit_nav_loop; -} - -sub default_step { - my $self = shift; - return $self->{'default_step'} || 'main'; -} +sub js_step { shift->{'js_step'} || 'js' } -###----------------------------------------------------------------### +sub forbidden_step { shift->{'forbidden_step'} || '__forbidden' } -sub step_key { - my $self = shift; - return $self->{'step_key'} || 'step'; -} +sub step_key { shift->{'step_key'} || 'step' } -### determine the path to follow sub path { - my $self = shift; - return $self->{path} ||= do { - my @path = (); # default to empty path - my $step_key = $self->step_key; - - if (my $step = $self->form->{$step_key}) { - push @path, $step; - } elsif ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|) { - push @path, lc($1); + my $self = shift; + if (! $self->{'path'}) { + my $path = $self->{'path'} = []; # empty path + + my $step = $self->form->{ $self->step_key }; + $step = lc($1) if ! $step && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ m|^/(\w+)|; + + ### make sure the step is valid + if (defined $step) { + if ($step =~ /^_/) { # can't begin with _ + $self->stash->{'forbidden_step'} = $step; + push @$path, $self->forbidden_step; + } elsif ($self->valid_steps # must be in valid_steps if defined + && ! $self->valid_steps->{$step} + && $step ne $self->default_step + && $step ne $self->js_step) { + $self->stash->{'forbidden_step'} = $step; + push @$path, $self->forbidden_step; + } else { + push @$path, $step; + } + } } - \@path; # return of the do - }; + return $self->{'path'}; } -### really should only be used during initialization sub set_path { - my $self = shift; - my $path = $self->{path} ||= []; - die "Cannot call set_path after the navigation loop has begun" if $self->{path_i}; - splice @$path, 0, $#$path + 1, @_; # change entries in the ref + my $self = shift; + my $path = $self->{'path'} ||= []; + croak "Cannot call set_path after the navigation loop has begun" if $self->{'path_i'}; + splice @$path, 0, $#$path + 1, @_; # change entries in the ref (which updates other copies of the ref) } ### legacy - same as append_path sub add_to_path { - my $self = shift; - push @{ $self->path }, @_; + my $self = shift; + push @{ $self->path }, @_; } -### append entries onto the end sub append_path { - my $self = shift; - push @{ $self->path }, @_; + my $self = shift; + push @{ $self->path }, @_; } -### replace all entries that are left sub replace_path { - my $self = shift; - my $ref = $self->path; - my $i = $self->{path_i} || 0; - if ($i + 1 > $#$ref) { - push @$ref, @_; - } else { - splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries - } + my $self = shift; + my $ref = $self->path; + my $i = $self->{'path_i'} || 0; + if ($i + 1 > $#$ref) { + push @$ref, @_; + } else { + splice(@$ref, $i + 1, $#$ref - $i, @_); # replace remaining entries + } } -### insert more steps into the current path sub insert_path { - my $self = shift; - my $ref = $self->path; - my $i = $self->{path_i} || 0; - if ($i + 1 > $#$ref) { - push @$ref, @_; - } else { - splice(@$ref, $i + 1, 0, @_); # insert a path at the current location - } + my $self = shift; + my $ref = $self->path; + my $i = $self->{'path_i'} || 0; + if ($i + 1 > $#$ref) { + push @$ref, @_; + } else { + splice(@$ref, $i + 1, 0, @_); # insert a path at the current location + } } -### a hash of paths that are allowed, default undef is all +### a hash of paths that are allowed, default undef is all are allowed sub valid_steps {} ###----------------------------------------------------------------### -### allow for checking where we are in the path +### allow for checking where we are in the path and for jumping around + +sub exit_nav_loop { + my $self = shift; + + ### undo morphs + if (my $ref = $self->{'__morph_lineage'}) { + ### use the saved index - this allows for early "morphers" to only get rolled back so far + my $index = $self->{'__morph_lineage_start_index'}; + $index = -1 if ! defined $index; + $self->unmorph while $#$ref != $index; + } + + ### long jump back + die "Long Jump\n"; +} + +sub jump { + my $self = shift; + my $i = @_ == 1 ? shift : 1; + my $path = $self->path; + my $path_i = $self->{'path_i'}; + croak "Can't jump if nav_loop not started" if ! defined $path_i; + + ### validate where we are jumping to + if ($i =~ /^\w+$/) { + if ($i eq 'FIRST') { + $i = - $path_i - 1; + } elsif ($i eq 'LAST') { + $i = $#$path - $path_i; + } elsif ($i eq 'NEXT') { + $i = 1; + } elsif ($i eq 'CURRENT') { + $i = 0; + } elsif ($i eq 'PREVIOUS') { + $i = -1; + } else { # look for a step by that name + for (my $j = $#$path; $j >= 0; $j --) { + if ($path->[$j] eq $i) { + $i = $j - $path_i; + last; + } + } + } + } + if ($i !~ /^-?\d+$/) { + require Carp; + Carp::croak("Invalid jump index ($i)"); + } + + ### manipulate the path to contain the new jump location + my @replace; + my $cut_i = $path_i + $i; + if ($cut_i > $#$path) { + push @replace, $self->default_step; + } elsif ($cut_i < 0) { + push @replace, @$path; + } else { + push @replace, @$path[$cut_i .. $#$path]; + } + $self->replace_path(@replace); + + ### record the number of jumps + $self->{'jumps'} ||= 0; + $self->{'jumps'} ++; + + ### run the newly fixed up path (recursively) + $self->{'path_i'} ++; # move along now that the path is updated + $self->nav_loop; + $self->exit_nav_loop; +} sub step_by_path_index { - my $self = shift; - my $i = shift || 0; - my $ref = $self->path; - return '' if $i < 0; - return $self->default_step if $i > $#$ref; - return $ref->[$i]; + my $self = shift; + my $i = shift || 0; + my $ref = $self->path; + return '' if $i < 0; + return $self->default_step if $i > $#$ref; + return $ref->[$i]; } sub previous_step { - my $self = shift; - die "previous_step is readonly" if $#_ != -1; - return $self->step_by_path_index( ($self->{path_i} || 0) - 1 ); + my $self = shift; + croak "previous_step is readonly" if $#_ != -1; + return $self->step_by_path_index( ($self->{'path_i'} || 0) - 1 ); } sub current_step { - my $self = shift; - die "current_step is readonly" if $#_ != -1; - return $self->step_by_path_index( ($self->{path_i} || 0) ); + my $self = shift; + croak "current_step is readonly" if $#_ != -1; + return $self->step_by_path_index( ($self->{'path_i'} || 0) ); } sub next_step { - my $self = shift; - die "next_step is readonly" if $#_ != -1; - return $self->step_by_path_index( ($self->{path_i} || 0) + 1 ); + my $self = shift; + croak "next_step is readonly" if $#_ != -1; + return $self->step_by_path_index( ($self->{'path_i'} || 0) + 1 ); } sub last_step { - my $self = shift; - die "last_step is readonly" if $#_ != -1; - return $self->step_by_path_index( $#{ $self->path } ); + my $self = shift; + croak "last_step is readonly" if $#_ != -1; + return $self->step_by_path_index( $#{ $self->path } ); } sub first_step { - my $self = shift; - die "first_step is readonly" if $#_ != -1; - return $self->step_by_path_index( 0 ); + my $self = shift; + croak "first_step is readonly" if $#_ != -1; + return $self->step_by_path_index( 0 ); } ###----------------------------------------------------------------### +### hooks and history + +sub find_hook { + my $self = shift; + my $hook = shift || do { require Carp; Carp::confess("Missing hook name") }; + my $step = shift || ''; + my $code; + if ($step && ($code = $self->can("${step}_${hook}"))) { + return [$code, "${step}_${hook}"], + + } elsif ($code = $self->can($hook)) { + return [$code, $hook]; + + } else { + return []; + + } +} -sub pre_loop {} -sub post_loop {} - -### return the appropriate hook to call -sub hook { - my $self = shift; - my $hook = shift || do { require Carp; Carp::confess("Missing hook name") }; - my $step = shift || ''; - my $default = shift; - my $hist = $self->history; - my $code; - if ($step && ($code = $self->can("${step}_${hook}"))) { - push @$hist, "$step - $hook - ${step}_${hook}"; - return $code; - } elsif ($code = $self->can($hook)) { - push @$hist, "$step - $hook - $hook"; - return $code; - } elsif (UNIVERSAL::isa($default, 'CODE')) { - push @$hist, "$step - $hook - DEFAULT CODE"; - return $default; - } elsif ($default) { - push @$hist, "$step - $hook - DEFAULT"; - return sub { return $default }; - } else { - return sub {}; - } -} - -### get and call the appropriate hook sub run_hook { - my $self = shift; - my $hook = shift; - my $step = shift; - my $default = shift; - my $code = $self->hook($hook, $step, $default); - return $self->$code($step, @_); + my $self = shift; + my $hook = shift; + my $step = shift; + + my ($code, $found) = @{ $self->find_hook($hook, $step) }; + if (! $code) { + croak "Could not find a method named ${step}_${hook} or ${hook}"; + } + + + ### record history + my $hist = { + step => $step, + meth => $hook, + found => $found, + time => time, + }; + + push @{ $self->history }, $hist; + + $hist->{'level'} = $self->{'_level'}; + local $self->{'_level'} = 1 + ($self->{'_level'} || 0); + + $hist->{'elapsed'} = time - $hist->{'time'}; + + my $resp = $self->$code($step, @_); + + $hist->{'elapsed'} = time - $hist->{'time'}; + $hist->{'response'} = $resp; + + return $resp; } sub history { return shift->{'history'} ||= []; } -### default die handler - show what happened and die (so its in the error logs) -sub handle_error { - my $self = shift; - my $err = shift; - debug $err, $self->path, $self->history; - die $err; +sub dump_history { + my $self = shift; + my $all = shift || 0; + my $hist = $self->history; + my $dump = []; + push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'}); + + ### show terse - yet informative info + foreach my $row (@$hist) { + if (! ref($row) + || ref($row) ne 'HASH' + || ! exists $row->{'elapsed'}) { + push @$dump, $row; + } else { + my $note = (' ' x ($row->{'level'} || 0)) + . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'})); + my $resp = $row->{'response'}; + if (ref($resp) eq 'HASH' && ! scalar keys %$resp) { + $note .= ' - {}'; + } elsif (ref($resp) eq 'ARRAY' && ! @$resp) { + $note .= ' - []'; + } elsif (! ref $resp || ! $all) { + my $max = $self->{'history_max'} || 30; + if (length($resp) > $max) { + $resp = substr($resp, 0, $max); + $resp =~ s/\n.+//s; + $resp = "$resp ..."; + } + $note .= " - $resp"; + } else { + $note = [$note, $resp]; + } + + push @$dump, $note; + } + } + + return $dump; } ###----------------------------------------------------------------### -### utility modules for jeckyl/hyde on self +### utility methods to allow for storing separate steps in other modules sub allow_morph { my $self = shift; @@ -469,486 +460,498 @@ sub allow_nested_morph { } sub morph { - my $self = shift; - my $step = shift || return; - return if ! (my $allow = $self->allow_morph); # not true - - ### place to store the lineage - my $lin = $self->{'__morph_lineage'} ||= []; - my $cur = ref $self; # what are we currently - push @$lin, $cur; # store so subsequent unmorph calls can do the right thing - my $hist = $self->history; - push @$hist, "$step - morph - morph"; - my $sref = \$hist->[-1]; # get ref so we can add more info in a moment - - if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless - $$sref .= " - not allowed to morph to that step"; - return; - } - - ### make sure we haven't already been reblessed - if ($#$lin != 0 # is this the second morph call - && (! ($allow = $self->allow_nested_morph) # not true - || (ref($allow) && ! $allow->{$step}) # hash - but no step - )) { - $$sref .= $allow ? " - not allowed to nested_morph to that step" : " - nested_morph disabled"; - return; # just return - don't die so that we can morph early - } - - ### if we are not already that package - bless us there - my $new = $self->run_hook('morph_package', $step); - if ($cur ne $new) { - my $file = $new .'.pm'; - $file =~ s|::|/|g; - if (UNIVERSAL::can($new, 'can') # check if the package space exists - || eval { require $file }) { # check for a file that holds this package - ### become that package - bless $self, $new; - $$sref .= " - changed $cur to $new"; - if (my $method = $self->can('fixup_after_morph')) { - $self->$method($step); - } - } else { - if ($@) { - if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened - $$sref .= " - failed from $cur to $new: $1"; + my $self = shift; + my $step = shift || return; + return if ! (my $allow = $self->allow_morph($step)); + + ### place to store the lineage + my $lin = $self->{'__morph_lineage'} ||= []; + my $cur = ref $self; # what are we currently + push @$lin, $cur; # store so subsequent unmorph calls can do the right thing + + my $hist = { + step => $step, + meth => 'morph', + found => 'morph', + time => time, + elapsed => 0, + }; + push @{ $self->history }, $hist; + + if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless + $hist->{'found'} .= " (not allowed to morph to that step)"; + return; + } + + ### make sure we haven't already been reblessed + if ($#$lin != 0 # is this the second morph call + && (! ($allow = $self->allow_nested_morph($step)) # not true + || (ref($allow) && ! $allow->{$step}) # hash - but no step + )) { + $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)"; + return; # just return - don't die so that we can morph early + } + + ### if we are not already that package - bless us there + my $new = $self->run_hook('morph_package', $step); + if ($cur ne $new) { + my $file = $new .'.pm'; + $file =~ s|::|/|g; + if (UNIVERSAL::can($new, 'can') # check if the package space exists + || eval { require $file }) { # check for a file that holds this package + ### become that package + bless $self, $new; + $hist->{'found'} .= " (changed $cur to $new)"; + $self->fixup_after_morph($step); } else { - $$sref .= " - failed from $cur to $new: $@"; - my $err = "Trouble while morphing to $file: $@"; - debug $err; - warn $err; + if ($@) { + if ($@ =~ /^\s*(Can\'t locate \S+ in \@INC)/) { # let us know what happened + $hist->{'found'} .= " (failed from $cur to $new: $1)"; + } else { + $hist->{'found'} .= " (failed from $cur to $new: $@)"; + my $err = "Trouble while morphing to $file: $@"; + warn $err; + } + } } - } } - } } sub unmorph { - my $self = shift; - my $step = shift || '__no_step'; - my $lin = $self->{'__morph_lineage'} || return; - my $cur = ref $self; - my $prev = pop(@$lin) || die "unmorph called more times than morph - current ($cur)"; - - ### if we are not already that package - bless us there - my $hist = $self->history; - if ($cur ne $prev) { - if (my $method = $self->can('fixup_before_unmorph')) { - $self->$method($step); + my $self = shift; + my $step = shift || '__no_step'; + my $lin = $self->{'__morph_lineage'} || return; + my $cur = ref $self; + + my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)"; + delete $self->{'__morph_lineage'} if ! @$lin; + + ### if we are not already that package - bless us there + my $hist = { + step => $step, + meth => 'unmorph', + found => 'unmorph', + time => time, + elapsed => 0, + }; + push @{ $self->history }, $hist; + + if ($cur ne $prev) { + $self->fixup_before_unmorph($step); + bless $self, $prev; + $hist->{'found'} .= " (changed from $cur to $prev)"; + } else { + $hist->{'found'} .= " (already isa $cur)"; } - bless $self, $prev; - push @$hist, "$step - unmorph - unmorph - changed from $cur to $prev"; - } else { - push @$hist, "$step - unmorph - unmorph - already isa $cur"; - } - return $self; + return $self; } +sub fixup_after_morph {} + +sub fixup_before_unmorph {} + ###----------------------------------------------------------------### -### allow for cleanup including deep nested objects +### allow for authentication -sub cleanup { - my $self = shift; - ref($self)->cleanup_cross_references($self); -} - -sub cleanup_cross_references { - my $class = shift; - my $self = shift; - my $seen = shift || {}; - return if $seen->{$self}; # prevent recursive checking - $seen->{$self} = 1; - return if $CLEANUP_EXCLUDE{ ref($self) }; - if (UNIVERSAL::isa($self, 'HASH')) { - require Scalar::Util; # first self will always be hash - foreach my $key (keys %$self) { - next if ! $self->{$key}; - $class->cleanup_cross_references($self->{$key}, $seen); - # weaken and remove blessed objects - # this will clober objects in global caches that are referenced in the structure - # so beware (that means weaken your cached references) - if (Scalar::Util::blessed($self->{$key}) - && ! Scalar::Util::isweak($self->{$key})) { - Scalar::Util::weaken($self->{$key}); - $self->{$key} = undef; - } elsif (UNIVERSAL::isa($self->{$key}, 'CODE')) { - $self->{$key} = undef; - } - } - } elsif (UNIVERSAL::isa($self, 'ARRAY')) { - for my $key (0 .. $#$self) { - next if ! $self->[$key]; - $class->cleanup_cross_references($self->[$key], $seen); - if (Scalar::Util::blessed($self->[$key]) - && ! Scalar::Util::isweak($self->[$key])) { - Scalar::Util::weaken($self->[$key]); - $self->[$key] = undef; - } elsif (UNIVERSAL::isa($self->[$key], 'CODE')) { - $self->[$key] = undef; - } - } - } +sub navigate_authenticated { + my ($self, $args) = @_; + $self = $self->new($args) if ! ref $self; + + $self->require_auth(1); + + return $self->navigate; } +sub require_auth { + my $self = shift; + $self->{'require_auth'} = shift if @_ == 1; + return $self->{'require_auth'}; +} + +sub is_authed { shift->auth_data } + +sub auth_data { + my $self = shift; + $self->{'auth_data'} = shift if @_ == 1; + return $self->{'auth_data'}; +} + +sub get_valid_auth { + my $self = shift; + return 1 if $self->is_authed; + + ### augment the args with sensible defaults + my $args = $self->auth_args; + $args->{'cgix'} ||= $self->cgix; + $args->{'form'} ||= $self->form; + $args->{'cookies'} ||= $self->cookies; + $args->{'js_uri_path'} ||= $self->js_uri_path; + $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) }; + $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) }; + $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) }; + $args->{'login_print'} ||= sub { + my ($auth, $template, $hash) = @_; + my $out = $self->run_hook('swap_template', '__login', $template, $hash); + $self->run_hook('fill_template', '__login', \$out, $hash); + $self->run_hook('print_out', '__login', $out); + }; + + require CGI::Ex::Auth; + my $obj = CGI::Ex::Auth->new($args); + my $resp = $obj->get_valid_auth; + + my $data = $obj->last_auth_data; + delete $data->{'real_pass'} if defined $data; # data may be defined but false + $self->auth_data($data); # failed authentication may still have auth_data + + return ($resp && $data) ? 1 : 0; +} + +sub auth_args { {} } + +sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" } +sub cleanup_user { my ($self, $user) = @_; $user } +sub verify_user { 1 } + ###----------------------------------------------------------------### ### a few standard base accessors sub form { - my $self = shift; - if ($#_ != -1) { - $self->{form} = shift || die "Invalid form"; - } - return $self->{form} ||= $self->cgix->get_form; + my $self = shift; + $self->{'form'} = shift if @_ == 1; + return $self->{'form'} ||= $self->cgix->get_form; } sub cookies { - my $self = shift; - if ($#_ != -1) { - $self->{cookies} = shift || die "Invalid cookies"; - } - return $self->{cookies} ||= $self->cgix->get_cookies; + my $self = shift; + $self->{'cookies'} = shift if @_ == 1; + return $self->{'cookies'} ||= $self->cgix->get_cookies; } sub cgix { - my $self = shift; - return $self->{cgix} ||= do { - my $args = shift || {}; - require CGI::Ex; - CGI::Ex->new($args); # return of the do - }; -} - -sub set_cgix { - my $self = shift; - $self->{cgix} = shift; + my $self = shift; + $self->{'cgix'} = shift if @_ == 1; + return $self->{'cgix'} ||= do { + require CGI::Ex; + CGI::Ex->new; # return of the do + }; } sub vob { - my $self = shift; - return $self->{vob} ||= do { - my $args = shift || {}; - $args->{cgix} ||= $self->cgix; - require CGI::Ex::Validate; - CGI::Ex::Validate->new($args); # return of the do - }; -} - -sub set_vob { - my $self = shift; - $self->{vob} = shift; -} - -sub auth { - my $self = shift; - return $self->{auth} ||= do { - my $args = shift || {}; - $args->{cgix} ||= $self->cgix, - $args->{form} ||= $self->form, - $args->{cookies} ||= $self->cookies, - require CGI::Ex::Auth; - CGI::Ex::Auth->new($args); # return of the do - }; + my $self = shift; + $self->{'vob'} = shift if @_ == 1; + return $self->{'vob'} ||= do { + require CGI::Ex::Validate; + CGI::Ex::Validate->new($self->vob_args); # return of the do + }; } -sub set_auth { - my $self = shift; - $self->{auth} = shift; +sub vob_args { + my $self = shift; + return { + cgix => $self->cgix, + }; } ### provide a place for placing variables sub stash { - my $self = shift; - return $self->{'stash'} ||= {}; -} - -### allow for adding arbitrary values to self -sub add_property { - my $self = shift; - my $prop = shift; - my $key = '__prop_'. $prop; - my $name = __PACKAGE__ ."::". $prop; - no strict 'refs'; - *$name = sub : lvalue { my $self = shift; - $self->{$key} = shift() if $#_ != -1; - $self->{$key}; - } if ! defined &$name; - $self->$prop(shift()) if $#_ != -1; + return $self->{'stash'} ||= {}; } ###----------------------------------------------------------------### -### js_validation items +### default hook implementations -### creates javascript suitable for validating the form -sub js_validation { - my $self = shift; - my $step = shift; - return '' if $self->ext_val eq 'htm'; # let htm validation do it itself +sub run_step { + my $self = shift; + my $step = shift; - my $form_name = shift || $self->run_hook('form_name', $step); - my $hash_val = shift || $self->run_hook('hash_validation', $step, {}); - my $js_uri = $self->js_uri_path; - return '' if UNIVERSAL::isa($hash_val, 'HASH') && ! scalar keys %$hash_val - || UNIVERSAL::isa($hash_val, 'ARRAY') && $#$hash_val == -1; + ### if the pre_step exists and returns true, exit the nav_loop + return 1 if $self->run_hook('pre_step', $step); - return $self->vob->generate_js($hash_val, $form_name, $js_uri); -} + ### allow for skipping this step (but stay in the nav_loop) + return 0 if $self->run_hook('skip', $step); -### where to find the javascript files -### default to using this script as a handler -sub js_uri_path { - my $self = shift; - my $script = $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME"; - return ($self->can('path') == \&CGI::Ex::App::path) - ? $script . '/js' # try to use a cache friendly URI (if path is our own) - : $script . '?'.$self->step_key.'=js&js='; # use one that works with more paths -} + ### see if we have complete valid information for this step + ### if so, do the next step + ### if not, get necessary info and print it out + if ( ! $self->run_hook('prepare', $step) + || ! $self->run_hook('info_complete', $step) + || ! $self->run_hook('finalize', $step)) { -### name to attach js validation to -sub form_name { 'theform' } + ### show the page requesting the information + $self->run_hook('prepared_print', $step); -### provide some rudimentary javascript support -### if valid_steps is defined - it should include "js" -sub js_run_step { - my $self = shift; + ### a hook after the printing process + $self->run_hook('post_print', $step); - ### make sure path info looks like /js/CGI/Ex/foo.js - my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || ''; - $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; + return 1; + } - $self->cgix->print_js($file); - return 1; # intercepted + ### a hook before end of loop + ### if the post_step exists and returns true, exit the nav_loop + return 1 if $self->run_hook('post_step', $step); + + ### let the nav_loop continue searching the path + return 0; } -###----------------------------------------------------------------### -### implementation specific subs +sub prepared_print { + my $self = shift; + my $step = shift; -sub template_args { - my $self = shift; - my $step = shift; - return { - INCLUDE_PATH => $self->base_dir_abs, - }; + my $hash_base = $self->run_hook('hash_base', $step) || {}; + my $hash_comm = $self->run_hook('hash_common', $step) || {}; + my $hash_form = $self->run_hook('hash_form', $step) || {}; + my $hash_fill = $self->run_hook('hash_fill', $step) || {}; + my $hash_swap = $self->run_hook('hash_swap', $step) || {}; + my $hash_errs = $self->run_hook('hash_errors', $step) || {}; + + ### fix up errors + $hash_errs->{$_} = $self->format_error($hash_errs->{$_}) + foreach keys %$hash_errs; + $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs; + + ### layer hashes together + my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill}; + my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs}; + + ### run the print hook - passing it the form and fill info + $self->run_hook('print', $step, $swap, $fill); } sub print { - my $self = shift; - my $step = shift; - my $swap = shift; - my $fill = shift; + my ($self, $step, $swap, $fill) = @_; - ### get a filename relative to base_dir_abs - my $file = $self->run_hook('file_print', $step); + my $file = $self->run_hook('file_print', $step); # get a filename relative to base_dir_abs - require Template; - my $t = Template->new($self->template_args($step)); + my $out = $self->run_hook('swap_template', $step, $file, $swap); - ### process the document - my $out = ''; - my $status = $t->process($file, $swap, \$out) || die $Template::ERROR; + $self->run_hook('fill_template', $step, \$out, $fill); - ### fill in any forms - $self->cgix->fill(\$out, $fill) if $fill && ! $self->{no_fill}; - - ### now print - $self->cgix->print_content_type(); - print $out; + $self->run_hook('print_out', $step, $out); } -sub base_dir_rel { - my $self = shift; - $self->{base_dir_rel} = shift if $#_ != -1; - return $self->{base_dir_rel} ||= $BASE_DIR_REL; -} +sub print_out { + my ($self, $step, $out) = @_; -sub base_dir_abs { - my $self = shift; - $self->{base_dir_abs} = shift if $#_ != -1; - return $self->{base_dir_abs} || $BASE_DIR_ABS - || die "\$BASE_DIR_ABS not set for use in stub functions"; + $self->cgix->print_content_type(); + print $out; } -sub ext_val { - my $self = shift; - $self->{ext_val} = shift if $#_ != -1; - return $self->{ext_val} || $EXT_VAL || die "\$EXT_VAL not set for use in stub functions"; -} +sub swap_template { + my ($self, $step, $file, $swap) = @_; -sub ext_print { - my $self = shift; - $self->{ext_print} = shift if $#_ != -1; - return $self->{ext_print} || $EXT_PRINT || die "\$EXT_PRINT not set for use in stub functions"; + require CGI::Ex::Template; + my $args = $self->run_hook('template_args', $step); + my $t = CGI::Ex::Template->new($args); + + my $out = ''; + $t->process($file, $swap, \$out) || die $t->error; + + return $out; } -sub has_errors { - my $self = shift; - return 1 if scalar keys %{ $self->hash_errors }; +sub template_args { + my $self = shift; + my $step = shift; + return { + INCLUDE_PATH => sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" }, + }; } -sub format_error { - my $self = shift; - my $error = shift; -# return $error if $error =~ /$error"; +sub fill_template { + my ($self, $step, $outref, $fill) = @_; + + return if ! $fill; + + my $args = $self->run_hook('fill_args', $step); + local $args->{'text'} = $outref; + local $args->{'form'} = $fill; + + require CGI::Ex::Fill; + CGI::Ex::Fill::fill($args); } -###----------------------------------------------------------------### -### default stub subs +sub fill_args { {} } -### used for looking up a module to morph into -sub morph_package { - my $self = shift; - my $step = shift || ''; - my $cur = ref $self; # default to using self as the base for morphed modules - my $new = $cur .'::'. $step; - $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName - return $new; +sub pre_step { 0 } # success indicates we handled step (don't continue step or loop) +sub skip { 0 } # success indicates to skip the step (and continue loop) +sub prepare { 1 } # failure means show step +sub finalize { 1 } # failure means show step +sub post_print { 0 } # success indicates we handled step (don't continue loop) +sub post_step { 0 } # success indicates we handled step (don't continue step or loop) + +sub name_step { + my ($self, $step) = @_; + return $step; } -sub base_name_module { - my $self = shift; - $self->{base_name_module} = shift if $#_ != -1; - return $self->{base_name_module} ||= $BASE_NAME_MODULE; +sub morph_package { + my $self = shift; + my $step = shift || ''; + my $cur = ref $self; # default to using self as the base for morphed modules + my $new = $cur .'::'. $step; + $new =~ s/(\b|_+)(\w)/\u$2/g; # turn Foo::my_step_name into Foo::MyStepName + return $new; } -### used for looking up template content sub name_module { - my $self = shift; - my $step = shift || ''; - my $name; - if ($name = $self->base_name_module) { - return $name; - } else { - return ($0 =~ m/(\w+)(\.\w+)?$/) ? $1 # allow for cgi-bin/foo or cgi-bin/foo.pl - : die "Couldn't determine module name from \"name_module\" lookup ($step)"; - } + my $self = shift; + my $step = shift || ''; + + return $self->{'name_module'} ||= do { + # allow for cgi-bin/foo or cgi-bin/foo.pl to resolve to "foo" + my $script = $ENV{'SCRIPT_NAME'} || $0; + $script =~ m/ (\w+) (?:\.\w+)? $/x || die "Couldn't determine module name from \"name_module\" lookup ($step)"; + $1; # return of the do + }; } -### which file is used for templating sub file_print { - my $self = shift; - my $step = shift; + my $self = shift; + my $step = shift; - my $base_dir_rel = $self->base_dir_rel; - my $module = $self->run_hook('name_module', $step); - my $_step = $self->run_hook('name_step', $step, $step); - my $ext = $self->ext_print; + my $base_dir = $self->base_dir_rel; + my $module = $self->run_hook('name_module', $step); + my $_step = $self->run_hook('name_step', $step) || die "Missing name_step"; + $_step .= '.'. $self->ext_print if $_step !~ /\.\w+$/; - return "$base_dir_rel/$module/$_step.$ext"; + foreach ($base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| } + + return $base_dir . $module . $_step; } -### which file is used for validation sub file_val { - my $self = shift; - my $step = shift; + my $self = shift; + my $step = shift; - my $base_dir = $self->base_dir_rel; - my $module = $self->run_hook('name_module', $step); - my $_step = $self->run_hook('name_step', $step, $step); - my $ext = $self->ext_val; + my $abs = $self->base_dir_abs || return {}; + my $base_dir = $self->base_dir_rel; + my $module = $self->run_hook('name_module', $step); + my $_step = $self->run_hook('name_step', $step); + $_step .= '.'. $self->ext_val if $_step !~ /\.\w+$/; - ### get absolute if necessary - if ($base_dir !~ m|^/|) { - $base_dir = $self->base_dir_abs . "/$base_dir"; - } + foreach ($abs, $base_dir, $module) { $_ .= '/' if length($_) && ! m|/$| } - return "$base_dir/$module/$_step.$ext"; + return $abs . $base_dir . $module . $_step; } - sub info_complete { - my $self = shift; - my $step = shift; - - return 0 if ! $self->run_hook('ready_validate', $step); + my $self = shift; + my $step = shift; - return $self->run_hook('validate', $step); + return 0 if ! $self->run_hook('ready_validate', $step); + return 0 if ! $self->run_hook('validate', $step); + return 1; } sub ready_validate { - my $self = shift; - my $step = shift; + my $self = shift; + my $step = shift; - ### could do a slightly more complex test - return 0 if ! $ENV{REQUEST_METHOD} || $ENV{REQUEST_METHOD} ne 'POST'; - return 1; + return ($ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'POST') ? 1 : 0; } sub set_ready_validate { - my $self = shift; - my $ready = shift; - $ENV{REQUEST_METHOD} = ($ready) ? 'POST' : 'GET'; + my ($self, $ready) = @_; + $ENV{'REQUEST_METHOD'} = ($ready) ? 'POST' : 'GET'; } sub validate { - my $self = shift; - my $step = shift; - my $form = shift || $self->form; - my $hash = $self->run_hook('hash_validation', $step, {}); - my $what_was_validated = []; - - my $eob = eval { $self->vob->validate($form, $hash, $what_was_validated) }; - if (! $eob && $@) { - die "Step $step: $@"; - } - - ### had an error - store the errors and return false - if ($eob) { - $self->add_errors($eob->as_hash({ - as_hash_join => "
\n", - as_hash_suffix => '_error', - })); - return 0; - } - - ### allow for the validation to give us some redirection - my $val; - OUTER: foreach my $ref (@$what_was_validated) { - foreach my $method (qw(append_path replace_path insert_path)) { - next if ! ($val = $ref->{$method}); - $self->$method(ref $val ? @$val : $val); - last OUTER; + my $self = shift; + my $step = shift; + my $form = shift || $self->form; + my $hash = $self->run_hook('hash_validation', $step); + my $what_was_validated = []; + + my $err_obj = eval { $self->vob->validate($form, $hash, $what_was_validated) }; + die "Step $step: $@" if $@ && ! $err_obj; + + ### had an error - store the errors and return false + if ($err_obj) { + $self->add_errors($err_obj->as_hash({ + as_hash_join => "
\n", + as_hash_suffix => '_error', + })); + return 0; } - } - return 1; + ### allow for the validation to give us some redirection + foreach my $ref (@$what_was_validated) { + foreach my $method (qw(append_path replace_path insert_path)) { + next if ! (my $val = $ref->{$method}); + $self->$method(ref $val ? @$val : $val); + } + } + + return 1; +} + +### creates javascript suitable for validating the form +sub js_validation { + my $self = shift; + my $step = shift; + return '' if $self->ext_val =~ /^html?$/; # let htm validation do it itself + + my $form_name = shift || $self->run_hook('form_name', $step); + my $hash_val = shift || $self->run_hook('hash_validation', $step); + my $js_uri = $self->js_uri_path; + return '' if UNIVERSAL::isa($hash_val, 'HASH') && ! scalar keys %$hash_val + || UNIVERSAL::isa($hash_val, 'ARRAY') && ! @$hash_val; + + return $self->vob->generate_js($hash_val, $form_name, $js_uri); } -### allow for using ConfUtil instead of yaml +sub form_name { 'theform' } + sub hash_validation { - my $self = shift; - my $step = shift; - return $self->{hash_validation}->{$step} ||= do { - my $hash; - my $file = $self->run_hook('file_val', $step); + my ($self, $step) = @_; - ### allow for returning the validation hash in the filename - ### a scalar ref means it is a yaml document to be read by get_validation - if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) { - $hash = $file; + return $self->{'hash_validation'}->{$step} ||= do { + my $hash; + my $file = $self->run_hook('file_val', $step); - ### read the file - it it fails - errors should shown in the error logs - } elsif ($file) { - $hash = eval { $self->vob->get_validation($file) } || {}; + ### allow for returning the validation hash in the filename + ### a scalar ref means it is a yaml document to be read by get_validation + if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) { + $hash = $file; - } else { - $hash = {}; - } + ### read the file - if it fails - errors should be in the webserver error logs + } elsif ($file) { + $hash = eval { $self->vob->get_validation($file) } || {}; + + } else { + $hash = {}; + } - $hash; # return of the do + $hash; # return of the do }; } sub hash_base { - my ($self, $step) = @_; - return $self->{hash_base} ||= { - script_name => $ENV{'SCRIPT_NAME'} || $0, - path_info => $ENV{'PATH_INFO'} || '', - js_validation => sub { $self->run_hook('js_validation', $step, shift) }, - form_name => sub { $self->run_hook('form_name', $step) }, - }; + my ($self, $step) = @_; + + return $self->{'hash_base'} ||= do { + ### create a weak copy of self to use in closures + my $copy; + if (eval {require Scalar::Util} && defined &Scalar::Util::weaken) { + $copy = $self; + Scalar::Util::weaken($copy); + } else { + $copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on older perls (pre 5.8) + } + + my $hash = { + script_name => $ENV{'SCRIPT_NAME'} || $0, + path_info => $ENV{'PATH_INFO'} || '', + js_validation => sub { $copy->run_hook('js_validation', $step, shift) }, + form_name => sub { $copy->run_hook('form_name', $step) }, + $self->step_key => $step, + }; # return of the do + }; } sub hash_common { shift->{'hash_common'} ||= {} } @@ -957,19 +960,29 @@ sub hash_fill { shift->{'hash_fill'} ||= {} } sub hash_swap { shift->{'hash_swap'} ||= {} } sub hash_errors { shift->{'hash_errors'} ||= {} } +###----------------------------------------------------------------### +### routines to support the base hooks + sub add_errors { - my $self = shift; - my $hash = $self->hash_errors; - my $args = ref($_[0]) ? shift : {@_}; - foreach my $key (keys %$args) { - my $_key = ($key =~ /error$/) ? $key : "${key}_error"; - if ($hash->{$_key}) { - $hash->{$_key} .= '
' . $args->{$key}; - } else { - $hash->{$_key} = $args->{$key}; + my $self = shift; + my $hash = $self->hash_errors; + my $args = ref($_[0]) ? shift : {@_}; + foreach my $key (keys %$args) { + my $_key = ($key =~ /error$/) ? $key : "${key}_error"; + if ($hash->{$_key}) { + $hash->{$_key} .= '
' . $args->{$key}; + } else { + $hash->{$_key} = $args->{$key}; + } } - } - $hash->{'has_errors'} = 1; + $hash->{'has_errors'} = 1; +} + +sub has_errors { scalar keys %{ shift->hash_errors } } + +sub format_error { + my ($self, $error) = @_; + return $error; } sub add_to_errors { shift->add_errors(@_) } @@ -980,961 +993,79 @@ 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; + my $self = shift; + my $old = shift; + my $new = shift; + $new = {$new, @_} if ! ref $new; # non-hashref + $old->{$_} = $new->{$_} foreach keys %$new; } -###----------------------------------------------------------------### - -sub forbidden_info_complete { 0 } -sub forbidden_file_print { - my $self = shift; - my $step = $self->stash->{'forbidden_step'}; - my $str = "You do not have access to \"$step\""; - return \$str; +sub base_dir_rel { + my $self = shift; + $self->{'base_dir_rel'} = shift if $#_ != -1; + return $self->{'base_dir_rel'} || ''; } -###----------------------------------------------------------------### - -1; - -__END__ - -=head1 NAME - -CGI::Ex::App - Full featured (within reason) application builder. - -=head1 DESCRIPTION - -Fill in the blanks and get a ready made CGI. This module is somewhat -similar in spirit to CGI::Application, CGI::Path, and CGI::Builder and any -other "CGI framework." As with the others, CGI::Ex::App tries to do as -much as possible, in a simple manner, without getting in the -developer's way. Your milage may vary. - -=head1 SYNOPSIS - -More examples will come with time. Here are the basics for now. - - #!/usr/bin/perl -w - - MyApp->navigate; - # OR you could do the following which cleans - # circular references - useful for a mod_perl situation - # MyApp->navigate->cleanup; - exit; - - package MyApp; - use strict; - use base qw(CGI::Ex::App); - use CGI::Ex::Dump qw(debug); - - sub valid_steps { return {success => 1, js => 1} } - # default_step (main) is a valid path - # note the inclusion of js step to allow the - # javascript scripts in js_validation to function properly. - - # base_dir_abs is only needed if default print is used - # template toolkit needs an INCLUDE_PATH - sub base_dir_abs { '/tmp' } - - sub main_file_print { - # reference to string means ref to content - # non-reference means filename - return \ "

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 { +sub base_dir_abs { my $self = shift; + $self->{'base_dir_abs'} = shift if $#_ != -1; + return $self->{'base_dir_abs'} || ''; +} - debug $self->form, "Do something useful with form here"; - - ### add success step - $self->add_to_swap({success_msg => "We did something"}); - $self->append_path('success'); - $self->set_ready_validate(0); - return 1; - } - - sub success_file_print { - \ "

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 { +sub ext_val { my $self = shift; - if ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ s|^/(\w+)||) { - my $step = $1; - $self->morph($step); - $ENV{'PATH_INFO'} = "/$step"; - $self->stash->{'base_morphed'} = 1; - } - return 0; - } + $self->{'ext_val'} = shift if $#_ != -1; + return $self->{'ext_val'} || 'val'; +} - sub post_navigate { +sub ext_print { my $self = shift; - $self->unmorph if $self->stash->{'base_morphed'}; - } - -If this code was in a module Base.pm and the cgi running was cgi/base -and called: - - Base->navigate; - # OR - for mod_perl resident programs - Base->navigate->cleanup; - # OR - sub post_navigate { shift->cleanup } - -and you created a sub module that inherited Base.pm called -Base/Ball.pm -- you could then access it using cgi/base/ball. You -would be able to pass it steps using either cgi/base/ball/step_name or -cgi/base/ball?step=step_name - Or Base/Ball.pm could implement its -own path. It should be noted that if you do an early morph, it is -suggested to provide a call to unmorph. And if you want to let your -early morphed object morph again - you will need to provide - - sub allow_nested_morph { 1 } - -With allow_nested_morph enabled you could create the file -Base/Ball/StepName.pm which inherits Base/Ball.pm. The Base.pm, with -the custom init and default path method, would automatically morph us -first into a Base::Ball object (during init) and then into a -Base::Ball::StepName object (during the navigation loop). - -=item Method C<-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'} } + $self->{'ext_print'} = shift if $#_ != -1; + return $self->{'ext_print'} || 'html'; +} -=item Method C<-Eset_ready_validate> +### where to find the javascript files +### default to using this script as a handler +sub js_uri_path { + my $self = shift; + my $script = $ENV{'SCRIPT_NAME'} || return ''; + my $js_step = $self->js_step; + return ($self->can('path') == \&CGI::Ex::App::path) + ? $script .'/'. $js_step # try to use a cache friendly URI (if path is our own) + : $script . '?'.$self->step_key.'='.$js_step.'&js='; # use one that works with more paths +} -Sets that the validation is ready to validate. Should set the value -checked by the hook ready_validate. The following would complement the -processing flag above: +###----------------------------------------------------------------### +### a simple step that allows for printing javascript libraries that +### are stored in perls @INC. Which ever step is in js_step should do something similar. - sub set_ready_validate { +sub js_run_step { my $self = shift; - if (shift) { - $self->form->{'processing'} = 1; - } else { - delete $self->form->{'processing'}; - } - } - -Note thate for this example the form key "processing" was deleted. This -is so that the call to fill in any html forms won't swap in a value of -zero for form elements named "processing." - -=item Hook C<-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. + ### make sure path info looks like /js/CGI/Ex/foo.js + my $file = $self->form->{'js'} || $ENV{'PATH_INFO'} || ''; + $file = ($file =~ m!^(?:/js/|/)?(\w+(?:/\w+)*\.js)$!) ? $1 : ''; -=item Hook C<-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> + $self->cgix->print_js($file); + $self->{'_no_post_navigate'} = 1; + return 1; +} -Take the information generated by prepared_print, format it, and print it out. -Default incarnation uses Template::Toolkit. Arguments are: step name, form hashref, -and fill hashref. +###----------------------------------------------------------------### +### a step that will be used if a valid_steps is defined +### and the current step of the path is not in valid_steps +### or if the step is a "hidden" step that begins with _ +### or if the step name contains \W -=item Hook C<-Eprepared_print> +sub __forbidden_info_complete { 0 } -Called when any of prepare, info_complete, or finalize fail. Prepares -a form hash and a fill hash to pass to print. The form hash is primarily -intended for use by the templating system. The fill hash is intended -to be used to fill in any html forms. +sub __forbidden_hash_swap { {forbidden_step => shift->stash->{'forbidden_step'}} } -=item Hook C<-Epost_print> +sub __forbidden_file_print { \ "

Denied

You do not have access to the step \"[% forbidden_step %]\"" } -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> +1; -Ran after all of the steps in the loop have been processed (if -prepare, info_complete, and finalize were true for each of the steps). -If it returns a true value the navigation loop will be aborted. If it -does not return true, navigation continues by then inserting the step -$self->default_step and running $self->nav_loop again (recurses) to -fall back to the default step. - -=item Method C<-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 +### See the perldoc in CGI/Ex/App.pod diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod new file mode 100644 index 0000000..7e6fe25 --- /dev/null +++ b/lib/CGI/Ex/App.pod @@ -0,0 +1,2146 @@ +=head1 NAME + +CGI::Ex::App - Anti-framework application framework. + +=head1 DESCRIPTION + +Fill in the blanks and get a ready made web application. This module +is somewhat similar in spirit to CGI::Application, CGI::Path, and +CGI::Builder and any other "CGI framework." As with the others, +CGI::Ex::App tries to do as much of the mundane things, in a simple +manner, without getting in the developer's way. Your mileage may vary. + +If you build applications that submit user information, validate it, +re-display it, fill in forms, or separate logic into separate modules, +then this module may be for you. If all you need is a dispatch +engine, then this still may be for you. If all want is to look at +user passed information, then this may still be for you. If you like +writing bare metal code, this could still be for you. If you don't want +to write any code, this module will help - but you still need to +provide you key actions. + + +=head1 SYNOPSIS (A LONG "SYNOPSIS") + +More examples will come with time. Here are the basics for now. +This example script would most likely be in the form of a cgi, accessible via +the path http://yourhost.com/cgi-bin/my_app (or however you do CGIs on +your system. About the best way to get started is to paste the following +code into a cgi script (such as cgi-bin/my_app) and try it out. A detailed +walk-through follows in the next section. There is also a longer recipe +database example at the end of this document that covers other topics including +making your module a mod_perl handler. + + ### File: /var/www/cgi-bin/my_app (depending upon Apache configuration) + ### -------------------------------------------- + #!/usr/bin/perl -w + + use strict; + use base qw(CGI::Ex::App); + use CGI::Ex::Dump qw(debug); + + __PACKAGE__->navigate; + # OR + # my $obj = __PACKAGE__->new; + # $obj->navigate; + + exit; + + ###------------------------------------------### + + sub post_navigate { + # show what happened + debug shift->dump_history; + } + + sub main_hash_validation { + return { + 'general no_alert' => 1, + 'general no_confirm' => 1, + 'group order' => [qw(username password password2)], + username => { + required => 1, + min_len => 3, + max_len => 30, + match => 'm/^\w+$/', + match_error => 'You may only use letters and numbers.', + }, + password => { + required => 1, + min_len => 6, + }, + password2 => { + equals => 'password', + }, + }; + } + + sub main_file_print { + # reference to string means ref to content + # non-reference means filename + return \ "

Main Step

+
+ + + + + + + + + + + + + +
Username:[% username_error %]
Password:[% password_error %]
Verify Password:[% password2_error %]
+
+ [% js_validation %] + "; + } + + sub main_finalize { + my $self = shift; + + if ($self->form->{'username'} eq 'bar') { + $self->add_errors(username => 'A trivial check to say the username cannot be "bar"'); + return 0; + } + + debug $self->form, "Do something useful with form here in the finalize hook."; + + ### add success step + $self->add_to_swap({success_msg => "We did something"}); + $self->append_path('success'); + $self->set_ready_validate(0); + return 1; + } + + sub success_file_print { + \ "
+

Success Step - [% success_msg %]

+ Username: [% username %]
+ Password: [% password %]
+
+ "; + } + + __END__ + +Note: This example would be considerably shorter if the html file +(file_print) and the validation file (file_val) had been placed in +separate files. Though CGI::Ex::App will work "out of the box" as +shown it is more probable that any platform using it will customize +the various hooks to their own tastes (for example, switching print to +use a templating system other than CGI::Ex::Template). + +=head1 SYNOPSIS STEP BY STEP + +This section goes step by step over the previous example. + +Well - we start out with the customary CGI introduction. + + #!/usr/bin/perl -w + + use strict; + use base qw(CGI::Ex::App); + use CGI::Ex::Dump qw(debug); + +Note: the "use base" is not normally used in the "main" portion of a script. +It does allow us to just do __PACKAGE__->navigate. + +Now we need to invoke the process: + + __PACKAGE__->navigate; + # OR + # my $obj = __PACKAGE__->new; + # $obj->navigate; + exit; + +Note: the "exit" isn't necessary - but it is kind of nice to infer +that program flow doesn't go beyond the ->navigate call. + +The navigate routine is now going to try and "run" through a series of +steps. Navigate will call the ->path method which should return an +arrayref containing the valid steps. By default, if path method has +not been overridden, the path method will default first to the step +found in form key named ->step_name, then it will fall to the contents +of $ENV{'PATH_INFO'}. If navigation runs out of steps to run it will +run the step found in ->default_step which defaults to 'main'. So the +URI '/cgi-bin/my_app' would run the step 'main' first by default. The +URI '/cgi-bin/my_app?step=foo' would run the step 'foo' first. The +URI '/cgi-bin/my_app/bar' would run the step 'bar' first. + +CGI::Ex::App allows for running steps in a preset path. The navigate +method will go through a step of the path at a time and see if it is +completed (various methods determine the definition of "completed"). +This preset type of path can also be automated using the CGI::Path +module. Rather than using a preset path, CGI::Ex::App also has +methods that allow for dynamic changing of the path, so that each step +can determine which step to do next (see the jump, append_path, +insert_path, and replace_path methods). + +During development it would be nice to see what happened during the +course of our navigation. This is stored in the arrayref contained in +->history. There is a method that is called after all of the navigation +has taken place called "post_navigate". This chunk will display history after we +have printed the content. + + sub post_navigate { + debug shift->dump_history; + } # show what happened + +Ok. Finally we are looking at the methods used by each step of the path. The +hook mechanism of CGI::Ex::App will look first for a method ${step}_${hook_name} +called before falling back to the method named $hook_name. Internally in the +code there is a call that looks like $self->run_hook('hash_validation', $step). In +this case the step is main. The dispatch mechanism finds our method at the following +chunk of code. + + sub main_hash_validation { ... } + +The process flow will see if the data is ready to validate. Once it is ready +(usually when the user presses the submit button) the data will be validated. The +hash_validation hook is intended to describe the data and will be tested +using CGI::Ex::Validate. See the CGI::Ex::Validate perldoc for more +information about the many types of validation available. + + sub main_file_print { ... } + +The navigation process will see if user submitted information (the form) +is ready for validation. If not, or if validation fails, the step needs to +be printed. Eventually the file_print hook is called. This hook should +return either the filename of the template to be printed, or a reference +to the actual template content. In this example we return a reference +to the content to be printed (this is useful for prototyping applications +and is also fine in real world use - but generally production applications +use external html templates). + +A few things to note about the template: + +First, we add a hidden form field called step. This will be filled in +at a later point with the current step we are on. + +We provide locations to swap in inline errors. + + [% username_error %] + +As part of the error html we name each span with the name of the error. This +will allow for us to have Javascript update the error spots when the javascript +finds an error. + +At the very end we add the TT variable [% js_validation %]. This swap in is +provided by the default hash_base hook and will provide for form data to be +validated using javascript. + +Once the process flow has deemed that the data is validated, it then calls +the finalize hook. Finalize is where the bulk of operations should go. +We'll look at it more in depth. + + sub main_finalize { + my $self = shift; + my $form = $self->form; + +At this point, all of the validated data is in the $form hashref. + + if ($form->{'username'} eq 'bar') { + $self->add_errors(username => 'A trivial check to say the username cannot be "bar"'); + return 0; + } + +It is most likely that though the data is of the correct type and formatting, +it still isn't completely correct. This previous section shows a hard coded +test to see if the username was 'bar'. If it was then an appropriate error will +be set, the routine returns 0 and the run_step process knows that it needs to +redisplay the form page for this step. The username_error will be shown inline. +The program could do more complex things such as checking to see if the username +was already taken in a database. + + debug $form, "Do something useful with form here in the finalize hook."; + +This debug $form piece is simply a place holder. It is here that the program would +do something useful such as add the information to a database. + + ### add success step + $self->add_to_swap({success_msg => "We did something"}); + +Now that we have finished finalize, we add a message that will be passed to the template +engine. + + $self->append_path('success'); + $self->set_ready_validate(0); + +The program now needs to move on to the next step. In this case we want to +follow with a page that informs us we succeeded. So, we append a step named "success". +We also call set_ready_validate(0) to inform the navigation control that the +form is no longer ready to validate - which will cause the success page to +print without trying to validate the data. It is normally a good idea +to set this as leaving the engine in a "ready to validate" state can result +in an recursive loop (that will be caught). + + return 1; + } + +We then return 1 which tells the engine that we completed this step successfully +and it needs to move on to the next step. + +Finally we run the "success" step because we told it to. That step isn't +ready to validate so it prints out the template page. + +For more of a real world example, it would be good to read the sample recipe db +application included at the end of this document. + +=head1 DEFAULT PROGRAM FLOW + +The following pseudo-code describes the process flow +of the CGI::Ex::App framework. Several portions of the flow +are encapsulated in hooks which may be completely overridden to give +different flow. All of the default actions are shown. It may look +like a lot to follow, but if the process is broken down into the +discrete operations of step iteration, data validation, and template +printing the flow feels more natural. + +The process starts off by calling ->navigate. + + navigate { + eval { + ->pre_navigate + ->nav_loop + ->post_navigate + } + # dying errors will run the ->handle_error method + } + +The nav_loop method will run as follows: + + nav_loop { + ->path (get the array of path steps) + # look in $ENV{'PATH_INFO'} + # look in ->form for ->step_key + # make sure step is in ->valid_steps (if defined) + + ->pre_loop($path) + # navigation stops if true + + foreach step of path { + + ->morph + # check ->allow_morph + # check ->allow_nested_morph + # ->morph_package (hook - get the package to bless into) + # ->fixup_after_morph if morph_package exists + # if no package is found, process continues in current file + + ->run_step (hook) + + ->unmorph + # only called if morph worked + # ->fixup_before_unmorph if blessed to current package + + # exit loop if ->run_step returned true (page printed) + + } end of foreach step + + ->post_loop + # navigation stops if true + + ->default_step + ->insert_path (puts the default step into the path) + ->nav_loop (called again recursively) + + } end of nav_loop + +For each step of the path the following methods will be run +during the run_step hook. + + run_step { + ->pre_step (hook) + # exits nav_loop if true + + ->skip (hook) + # skips this step if true (stays in nav_loop) + + ->prepare (hook - defaults to true) + + ->info_complete (hook - ran if prepare was true) + ->ready_validate (hook) + return false if ! ready_validate + ->validate (hook - uses CGI::Ex::Validate to validate form info) + ->hash_validation (hook) + ->file_val (hook) + ->base_dir_abs + ->base_dir_rel + ->name_module + ->name_step + ->ext_val + returns true if validate is true or if nothing to validate + + ->finalize (hook - defaults to true - ran if prepare and info_complete were true) + + if ! ->prepare || ! ->info_complete || ! ->finalize { + ->prepared_print + ->hash_base (hook) + ->hash_common (hook) + ->hash_form (hook) + ->hash_fill (hook) + ->hash_swap (hook) + ->hash_errors (hook) + # merge form, base, common, and fill into merged fill + # merge form, base, common, swap, and errors into merged swap + ->print (hook - passed current step, merged swap hash, and merged fill) + ->file_print (hook - uses base_dir_rel, name_module, name_step, ext_print) + ->swap_template (hook - processes the file with CGI::Ex::Template) + ->template_args (hook - passed to CGI::Ex::Template->new) + ->fill_template (hook - fills the any forms with CGI::Ex::Fill) + ->fill_args (hook - passed to CGI::Ex::Fill::fill) + ->print_out (hook - print headers and the content to STDOUT) + + ->post_print (hook - used for anything after the print process) + + # return true to exit from nav_loop + } + + ->post_step (hook) + # exits nav_loop if true + + } end of run_step + +It is important to learn the function and placement of each of the +hooks in the process flow in order to make the most of CGI::Ex::App. +It is enough to begin by learning a few common hooks - such as +hash_validation, hash_swap, and finalize, and then learn about other +hooks as needs arise. Sometimes, it is enough to simply override the +run_step hook and take care of processing the entire step yourself. + +Because of the hook based system, and because CGI::Ex::App uses +sensible defaults, it is very easy to override a little or a lot which +ends up giving the developer a lot of flexibility. + +Consequently, it should be possible to use CGI::Ex::App with the other +frameworks such as CGI::Application or CGI::Prototype. For these you +could simple let each "runmode" call the run_step hook of CGI::Ex::App +and you will instantly get all of the common process flow for free. + +=head1 AVAILABLE METHODS / HOOKS + +CGI::Ex::App's dispatch system works on the principles of hooks (which +are essentially glorified method lookups). When the run_hook method +is called, CGI::Ex::App will look for a corresponding method call for +that hook for the current step name. It is perhaps easier to show than +to explain. + +If we are calling the "print" hook for the step "edit" we would call +run_hook like this: + + $self->run_hook('print', 'edit', $template, \%swap, \%fill); + +This would first look for a method named "edit_print". If it is unable to +find a method by that name, it will look for a method named "print". If it +is unable to find this method - it will die. + +If allow_morph is set to true, the same methods are searched for but it becomes +possible to move some of those methods into an external package. + +See the discussions under the methods named "find_hook" and "run_hook" for more details. + +The following is the alphabetical list of methods and hooks. + +=over 4 + +=item allow_morph (method) + +Should return true if this step is allowed to "morph" the current App +object into another package. Default is false. It is passed a single +argument of the current step. For more granularity, if true value is +a hash, the step being morphed to must be in the hash. + +To enable morphing for all steps, add the following: + + sub allow_morph { 1 } + +To enable morph on specific steps, do either of the following: + + sub allow_morph { + return { + edit => 1, + delete => 1, + }; + } + + # OR + + sub allow_morph { + my ($self, $step) = @_; + return $step =~ /^(edit|delete)$/; + } + +See the morph "hook" for more information. + +=item allow_nested_morph (method) + +Similar to the allow_morph hook, but allows for one more level of morphing. +This is useful in cases where the base class was morphed early on, or +if a step needs to call a sub-step but morph first. + +See the allow_morph and the morph method for more information. + +Should return a boolean value or hash of allowed steps - just as the +allow_morph method does. + +=item append_path (method) + +Arguments are the steps to append. Can be called any time. Adds more +steps to the end of the current path. + +=item auth_args (method) + +Should return a hashref that will be passed to the new method of CGI::Ex::Auth. +It is augmented with arguments that integrate it into CGI::Ex::App. + +See the get_valid_auth method and the CGI::Ex::Auth documentation. + + sub auth_args { + return { + login_header => '

My login header

', + login_footer => '[% TRY %][% INCLUDE login/login_footer.htm %][% CATCH %][% END %]', + secure_hash_keys => [qw(aaaaaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc 2222222222222)], + # use_blowfish => 'my_blowfish_key', + }; + } + +=item auth_data (method) + +Contains authentication data stored during the get_valid_auth method. +The data is normally blessed into the CGI::Ex::Auth::Data package which +evaluates to false if there was an error and true if the authentication +was successful - so this data can be defined but false. + +See the get_valid_auth method. + +=item cleanup_user (method) + +Installed as a hook during get_valid_auth. Allows for cleaning +up the username. See the get_valid_auth method. + + sub cleanup_user { + my ($self, $user) = @_; + return lc $user; + } + +=item current_step (method) + +Returns the current step that the nav_loop is functioning on. + +=item default_step (method) + +Step to show if the path runs out of steps. Default value is the +'default_step' property which defaults to 'main'. + +If nav_loop runs of the end of the path (runs out of steps), this +method is called, the step is added to the path, and nav_loop calls +itself recursively. + +=item dump_history (method) + +Show simplified trace information of which steps were called, the +order they were called in, the time they took to run, and a brief list +of the output (to see the full response returned by each hook, pass a +true value as the only argument to dump_history - +$self->dump_history(1)). Indentation is also applied to show which +hooks called other hooks. + + +The first line shows the amount of time elapsed for the entire +navigate execution. Subsequent lines contain: + + Step - the name of the current step. + Hook - the name of the hook being called. + Found - the name of the method that was found. + Time - the total elapsed seconds that method took to run. + Output - the response of the hook - shown in shortened form. + +Note - to get full output responses - pass a true value to +dump_history - or just call ->history. Times displayed are to 5 +decimal places - this accuracy can only be provided if the Time::HiRes +module is installed on your system (it will only be used if installed). + +It is usually best to print this history during the post_navigate +method as in the following: + + use CGI::Ex::Dump qw(debug); + sub post_navigate { debug shift->dump_history } + +The following is a sample output of dump_history called from the +sample recipe application at the end of this document. The step +called is "view". + + debug: admin/Recipe.pm line 14 + shift->dump_history = [ + "Elapsed: 0.00562", + "view - run_step - run_step - 0.00488 - 1", + " view - pre_step - pre_step - 0.00003 - 0", + " view - skip - view_skip - 0.00004 - 0", + " view - prepare - prepare - 0.00003 - 1", + " view - info_complete - info_complete - 0.00010 - 0", + " view - ready_validate - ready_validate - 0.00004 - 0", + " view - prepared_print - prepared_print - 0.00441 - 1", + " view - hash_base - hash_base - 0.00009 - HASH(0x84ea6ac)", + " view - hash_common - view_hash_common - 0.00148 - HASH(0x8310a20)", + " view - hash_form - hash_form - 0.00004 - HASH(0x84eaa78)", + " view - hash_fill - hash_fill - 0.00003 - {}", + " view - hash_swap - hash_swap - 0.00003 - {}", + " view - hash_errors - hash_errors - 0.00003 - {}", + " view - print - print - 0.00236 - 1", + " view - file_print - file_print - 0.00024 - recipe/view.html", + " view - name_module - name_module - 0.00007 - recipe", + " view - name_step - name_step - 0.00004 - view", + " view - swap_template - swap_template - 0.00161 - ...", + " view - template_args - template_args - 0.00008 - HASH(0x865abf8)", + " view - fill_template - fill_template - 0.00018 - 1", + " view - fill_args - fill_args - 0.00003 - {}", + " view - print_out - print_out - 0.00015 - 1", + " view - post_print - post_print - 0.00003 - 0" + ]; + +=item exit_nav_loop (method) + +This method should not normally used but there is no problem with +using it on a regular basis. Essentially it is a "goto" that allows +for a long jump to the end of all nav_loops (even if they are +recursively nested). This effectively short circuits all remaining +hooks for the current and remaining steps. It is used to allow the +->jump functionality. If the application has morphed, it will be +unmorphed before returning. Also - the post_navigate method will +still be called. + +=item first_step (method) + +Returns the first step of the path. Note that first_step may not be the same +thing as default_step if the path was overridden. + +=item form (method) + +Returns a hashref of the items passed to the CGI. Returns +$self->{form} which defaults to CGI::Ex::get_form. + +=item handle_error (method) + +If anything dies during execution, handle_error will be called with +the error that had happened. Default action is to die with that error. + +=item history (method) + +Returns an arrayref which contains trace history of which hooks of +which steps were ran. Useful for seeing what happened. In general - +each line of the history will show the current step, the hook +requested, and which hook was actually called. + +The dump_history method shows a short condensed version of this +history which makes it easier to see what path was followed. + +In general, the arrayref is free for anything to push onto which will +help in tracking other occurrences in the program as well. + +=item init (method) + +Called by the default new method. Allows for any object +initilizations that may need to take place. Default action does +nothing. + +=item fill_args (hook) + +Returns a hashref of args that will be passed to the CGI::Ex::Fill::fill. +It is augmented with the template to swap and the fill hash. This +could be useful if you needed to only swap a particular form on the template +page. Arguments are passed directly to the fill function. + + sub fill_args { {target => 'my_form'} } + +=item fill_template (hook) + +Arguments are a template and a hashref. Takes the template that was +prepared using swap_template, and swaps html form fields using the +passed hashref. Overriding this method can control the fill behavior. + +Calls the fill_args hook prior to calling CGI::Ex::Fill::fill + +=item file_print (hook) + +Returns a filename of the content to be used in the default print +hook. Adds method base_dir_rel to hook name_module, and name_step and +adds on the default file extension found in $self->ext_print which +defaults to the property $self->{ext_print} which will default to +".html". Should return a filename relative to base_dir_abs that can be +swapped using CGI::Ex::Template, or should be a scalar reference to +the template content that can be swapped. This will be used by the +hook print. + + sub base_dir_abs { '/var/www/templates' } + sub base_dir_rel { 'content' } + sub name_module { 'recipe' } + sub ext_print { 'html' } # default + + # ->file_print('this_step') + # would return 'content/recipe/this_step.html' + # the template engine would look in '/var/www/templates' + # for a file by that name + +It may also return a reference to a string containing the html template. +This is useful for prototyping applications and/or keeping all of +the data for the application in a single location. + +=item file_val (hook) + +Returns a filename containing the validation. Performs the same +as file_print, but uses ext_val to get the extension, and it adds +base_dir_abs onto the returned value (file_print is relative to +base_dir_abs, while file_val is fully qualified with base_dir_abs) + +The file should be readable by CGI::Ex::Validate::get_validation. + +This hook is only necessary if the hash_validation hook has not been +overridden. + +This method an also return a hashref containing the validation - but +then you may have wanted to override the hash_validation hook. + +=item finalize (hook) + +Defaults to true. Used to do whatever needs to be done with the data once +prepare has returned true and info_complete has returned true. On failure +the print operations are ran. On success navigation moves on to the next +step. + +This is normally were there core logic of a script will occur (such as +adding to a database, or updating a record). At this point, the data +should be validated. It is possible to do additional validation +and return errors using code such as the following. + + if (! $user_is_unique) { + $self->add_errors(username => 'The username was already used'); + return 0; + } + +=item find_hook (method) + +Called by run_hook. Arguments are a hook name, a step name. It +should return an arrayref containing the code_ref to run, and the +name of the method looked for. It uses ->can to find the appropriate +hook. + + my $code = $self->hook('finalize', 'main'); + ### will look first for $self->main_finalize; + ### will then look for $self->finalize; + +This system is used to allow for multiple steps to be in the same +file and still allow for moving some steps out to external sub classed +packages (if desired). + +If the application has successfully morphed via the morph method and +allow_morph then it is not necessary to add the step name to the +beginning of the method name as the morphed packages method will +override the base package (it is still OK to use the full method name +"${step}_hookname"). + +See the run_hook method and the morph method for more details. + +=item forbidden_step (method) + +Defaults to "__forbidden". The name of a step to run should the current +step name be invalid, or if a step found by the default path method +is invalid. See the path method. + +=item form_name (hook) + +Return the name of the form to attach the js validation to. Used by +js_validation. + +=item get_pass_by_user (method) + +This method is passed a username and the authentication object. It +should return the password for the given user. See the get_pass_by_user +method of CGI::Ex::Auth for more information. Installed as a hook +to the authentication object during the get_valid_auth method. + +=item get_valid_auth (method) + +If require_auth is true at either the application level or at the +step level, get_valid_auth will be called. + +It will call auth_args to get some default args to pass to +CGI::Ex::Auth->new. It augments the args with sensible defaults that +App already provides (such as form, cookies, and template facilities). +It also installs hooks for the get_pass_by_user, cleanup_user, and verify_user +hooks of CGI::Ex::Auth. + +It stores the $auth->last_auth_data in $self->auth_data for later use. For +example, to get the authenticated user: + + sub require_auth { 1 } + + sub cleanup_user { + my ($self, $user) = @_; + return lc $user; + } + + sub get_pass_by_user { + my ($self, $user) = @_; + my $pass = $self->some_method_to_get_the_pass($user); + return $pass; + } + + sub auth_args { + return { + login_header => '

My login header

', + login_footer => '[% TRY %][% INCLUDE login/login_footer.htm %][% CATCH %][% END %]', + }; + } + + sub main_hash_swap { + my $self = shift; + my $user = $self->auth_data->{'user'}; + return {user => $user}; + } + +Successful authentication is cached for the duration of the +nav_loop so multiple steps will run the full authentication routine +only once. + +Full customization of the login process and the login template can +be done via the auth_args hash. See the auth_args method and +CGI::Ex::Auth perldoc for more information. + +=item hash_base (hook) + +A hash of base items to be merged with hash_form - such as pulldown +menus, javascript validation, etc. It will now also be merged with +hash_fill, so it can contain default fillins as well. It can be +populated by passing a hash to ->add_to_base. By default a sub +similar to the following is what is used for hash_common. Note the +use of values that are code refs - so that the js_validation and +form_name hooks are only called if requested: + + sub hash_base { + my ($self, $step) = @_; + return $self->{hash_base} ||= { + script_name => $ENV{SCRIPT_NAME}, + js_validation => sub { $self->run_hook('js_validation', $step) }, + form_name => sub { $self->run_hook('form_name', $step) }, + }; + } + +=item hash_common (hook) + +Almost identical in function and purpose to hash_base. It is +intended that hash_base be used for common items used in various +scripts inheriting from a common CGI::Ex::App type parent. Hash_common +is more intended for step level populating of both swap and fill. + +=item hash_errors (hook) + +Called in preparation for print after failed prepare, info_complete, +or finalize. Should contain a hash of any errors that occurred. Will +be merged into hash_form before the pass to print. Each error that +occurred will be passed to method format_error before being added to +the hash. If an error has occurred, the default validate will +automatically add {has_errors =>1}. To the error hash at the time of +validation. has_errors will also be added during the merge in case the +default validate was not used. Can be populated by passing a hash to +->add_to_errors or ->add_errors. + +=item hash_fill (hook) + +Called in preparation for print after failed prepare, info_complete, +or finalize. Should contain a hash of any items needed to be filled +into the html form during print. Items from hash_form, hash_base, and +hash_common will be layered together. Can be populated by passing a +hash to ->add_to_fill. + +By default - forms are sticky and data from previous requests will try +and populate the form. You can use the fill_template hook to disable +templating on a single page or on all pages. + +This method can be used to pre-populate the form as well (such as on an +edit step). If a form fails validation, hash_fill will also be called +and will only want the submitted form fields to be sticky. You can +use the ready_validate hook to prevent pre-population in these cases as +follows: + + sub edit_hash_fill { + my $self = shift; + my $step = shift; + return {} if $self->run_hook('ready_validate', $step); + + my %hash; + + ### get previous values from the database + + return \%hash; + } + +=item hash_form (hook) + +Called in preparation for print after failed prepare, info_complete, +or finalize. Defaults to ->form. Can be populated by passing a hash +to ->add_to_form. + +=item hash_swap (hook) + +Called in preparation for print after failed prepare, info_complete, +or finalize. Should contain a hash of any items needed to be swapped +into the html during print. Will be merged with hash_base, +hash_common, hash_form, and hash_errors. Can be populated by passing +a hash to ->add_to_swap. + +The hash will be passed as the second argument to swap_template. + +=item hash_validation (hook) + +Returns a hash of the validation information to check form against. +By default, will look for a filename using the hook file_val and will +pass it to CGI::Ex::Validate::get_validation. If no file_val is +returned or if the get_validation fails, an empty hash will be returned. +Validation is implemented by ->vob which loads a CGI::Ex::Validate object. + +=item info_complete (hook) + +Calls the ready_validate hook to see if data is ready to validate. If +so it calls the validate hook to validate the data. Should make +sure the data is ready and valid. Will not be run unless +prepare returns true (default). + +=item insert_path (method) + +Arguments are the steps to insert. Can be called any time. Inserts +the new steps at the current path location. + +=item is_authed (method) + +Returns true if the object has successful authentication data. It +returns false if the object has not been authenticated. + +=item js_uri_path (method) + +Return the URI path where the CGI/Ex/yaml_load.js and +CGI/Ex/validate.js files can be found. This will default to +"$ENV{SCRIPT_NAME}/js" if the path method has not been overridden, +otherwise it will default to "$ENV{SCRIPT_NAME}?step=js&js=" (the +latter is more friendly with overridden paths). A default handler for +the "js" step has been provided in "js_run_step" (this handler will +nicely print out the javascript found in the js files which are +included with this distribution. js_run_step will work properly with the +default "path" handler. + +=item js_validation (hook) + +Requires JSON or YAML. Will return Javascript that is capable of +validating the form. This is done using the capabilities of +CGI::Ex::Validate. This will call the hook hash_validation which will +then be encoded either json or into yaml and placed in a javascript +string. It will also call the hook form_name to determine which html +form to attach the validation to. The method js_uri_path is called to +determine the path to the appropriate validate.js files. If the +method ext_val is htm, then js_validation will return an empty string +as it assumes the htm file will take care of the validation itself. +In order to make use of js_validation, it must be added to the +variables returned by either the hash_base, hash_common, hash_swap or +hash_form hook (see examples of hash_base used in this doc). + +By default it will try and use JSON first and then fail to YAML and +then will fail to returning an html comment that does nothing. + +=item jump (method) + +This method should not normally be used but is fine to use it on a +regular basis. It provides for moving to the next step at any point +during the nav_loop. It effectively short circuits the remaining +hooks for the current step. It does increment the recursion counter +(which has a limit of ->recurse_limit - default 15). It is normally +better to allow the other hooks in the loop to carry on their normal +functions and avoid jumping. (Essentially, this hook behaves like a +goto method to bypass everything else and continue at a different +location in the path - there are times when it is necessary or useful +to do this). + +Jump takes a single argument which is the location in the path to jump +to. This argument may be either a step name, the special strings +"FIRST, LAST, CURRENT, PREVIOUS, OR NEXT" or the number of steps to +jump forward (or backward) in the path. The default value, 1, +indicates that CGI::Ex::App should jump to the next step (the default +action for jump). A value of 0 would repeat the current step (watch +out for recursion). A value of -1 would jump to the previous step. +The special value of "LAST" will jump to the last step. The special +value of "FIRST" will jump back to the first step. In each of these +cases, the path array returned by ->path is modified to allow for the +jumping (the path is modified so that the path history is not destroyed +- if we were on step 3 and jumped to one, that path would contain +1, 2, 3, *1, 2, 3, 4, etc and we would be at the *). + + ### goto previous step + $self->jump($self->previous_step); + $self->jump('PREVIOUS'); + $self->jump(-1); + + ### goto next step + $self->jump($self->next_step); + $self->jump('NEXT'); + $self->jump(1); + $self->jump; + + ### goto current step (repeat) + $self->jump($self->current_step); + $self->jump('CURRENT'); + $self->jump(0); + + ### goto last step + $self->jump($self->last_step); + $self->jump('LAST'); + + ### goto first step + $self->jump($self->first_step); + $self->jump('FIRST'); + +=item last_step (method) + +Returns the last step of the path. Can be used to jump to the last step. + +=item morph (method) + +Allows for temporarily "becoming" another object type for the +execution of the current step. This allows for separating some steps +out into their own packages. + +Morph will only run if the method allow_morph returns true. +Additionally if the allow_morph returns a hash ref, morph will only +run if the step being morphed to is in the hash. Morph also passes +the step name to allow_morph. + +The morph call occurs at the beginning of the step loop. A +corresponding unmorph call occurs before the loop is exited. An +object can morph several levels deep if allow_nested_morph returns +true. For example, an object running as Foo::Bar that is looping on +the step "my_step" that has allow_morph = 1, will do the following: + + Call the morph_package hook (which would default to returning + Foo::Bar::MyStep in this case) + + Translate this to a package filename (Foo/Bar/MyStep.pm) and try + and require it, if the file can be required, the object is blessed + into that package. + + Call the fixup_after_morph method. + + Continue on with the run_step for the current step. + +At any exit point of the loop, the unmorph call is made which +re-blesses the object into the original package. + +Samples of allowing morph: + + sub allow_morph { 1 } + + sub allow_morph { {edit => 1} } + + sub allow_morph { my ($self, $step) = @_; return $step eq 'edit' } + +It is possible to call morph earlier on in the program. An example of +a useful early use of morph would be as in the following code: + + sub allow_morph { 1 } + + sub pre_navigate { + my $self = shift; + if ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} =~ s|^/(\w+)||) { + my $step = $1; + $self->morph($step); + $ENV{'PATH_INFO'} = "/$step"; + $self->stash->{'base_morphed'} = 1; + } + return 0; + } + + sub post_navigate { + my $self = shift; + $self->unmorph if $self->stash->{'base_morphed'}; + } + +If this code was in a module Base.pm and the cgi running was cgi/base +and called: + + Base->navigate; + +and you created a sub module that inherited Base.pm called +Base/Ball.pm -- you could then access it using cgi/base/ball. You +would be able to pass it steps using either cgi/base/ball/step_name or +cgi/base/ball?step=step_name - Or Base/Ball.pm could implement its +own path. It should be noted that if you do an early morph, it is +suggested to provide a call to unmorph. And if you want to let your +early morphed object morph again - you will need to provide + + sub allow_nested_morph { 1 } + +With allow_nested_morph enabled you could create the file +Base/Ball/StepName.pm which inherits Base/Ball.pm. The Base.pm, with +the custom init and default path method, would automatically morph us +first into a Base::Ball object (during init) and then into a +Base::Ball::StepName object (during the navigation loop). + +Since it is complicated to explain - it may be a bit complicated to +those who will try to follow your code later. CGI::Ex::App provides +many ways to do things, but use the best one for your situation. + +=item morph_package (hook) + +Used by morph. Return the package name to morph into during a morph +call. Defaults to using the current object type as a base. For +example, if the current object running is a Foo::Bar object and the +step running is my_step, then morph_package will return +Foo::Bar::MyStep. + +Because of the way that run_hook works, it is possible that several +steps could be located in the same external file and overriding morph_package +could allow for this to happen. + +See the morph method. + +=item name_module (hook) + +Return the name (relative path) that should be pre-pended to name_step +during the default file_print and file_val lookups. Defaults to +the value in $self->{name_module} which in turn defaults to the name +of the current script. + + cgi-bin/my_app.pl => my_app + cgi/my_app => my_app + +This method is provided so that each cgi or mod_perl application can +have its own directory for storing html for its steps. + +See the file_print method for more information. + +=item name_step (hook) + +Return the step (appended to name_module) that should used when +looking up the file in file_print and file_val lookups. Defaults to +the current step. + +=item nav_loop (method) + +This is the main loop runner. It figures out the current path +and runs all of the appropriate hooks for each step of the path. If +nav_loop runs out of steps to run (which happens if no path is set, or if +all other steps run successfully), it will insert the ->default_step into +the path and run nav_loop again (recursively). This way a step is always +assured to run. There is a method ->recurse_limit (default 15) that +will catch logic errors (such as inadvertently running the same +step over and over and over because there is either no hash_validation, +or the data is valid but the set_ready_validate(0) method was not called). + +=item navigate (method) + +Takes a class name or a CGI::Ex::App object as arguments. If a class +name is given it will call the "new" method to instantiate an object +by that class (passing any extra arguments to the new method). All +returns from navigate will return the object. + +The method navigate is essentially a safe wrapper around the ->nav_loop +method. It will catch any dies and pass them to ->handle_error. + +This starts the process flow for the path and its steps. + +=item navigate_authenticated (method) + +Same as the method navigate but sets require_auth(1) before +running. See the require_auth method. + +=item new (class method) + +Object creator. Takes a hashref of arguments that will become the +initial properties of the object. Calls the init method once the +object has been blessed to allow for any other initilizations. + + my $app = MyApp->new({name_module => 'my_app'}); + +=item next_step (method) + +Returns the next step in the path. If there is no next step, it +returns the default_step. + +=item path (method) + +Return an arrayref (modifiable) of the steps in the path. For each +step the run_step hook and all of its remaining hooks will be run. + +Hook methods are looked up and ran using the method "run_hook" which +uses the method "find_hook" to lookup the hook. A history of ran +hooks is stored in the array ref returned by $self->history. + +If path has not been defined, the method will look first in the form +for a key by the name found in ->step_key. It will then look in +$ENV{'PATH_INFO'}. It will use this step to create a path with that +one step as its contents. If a step is passed in via either of these +ways, the method will call valid_steps to make sure that the step +is valid (by default valid_steps returns undef - which means that +any step is valid). Any step beginning with _ can not be passed in +and are intended for use on private paths. If a non-valid step is +found, then path will be set to contain a single step of ->forbidden_step. + +For the best functionality, the arrayref returned should be the same +reference returned for every call to path - this ensures that other +methods can add to the path (and will most likely break if the +arrayref is not the same). + +If navigation runs out of steps to run, the default step found in +default_step will be run. This is what allows for us to default +to the "main" step for many applications. + +=item post_loop (method) + +Ran after all of the steps in the loop have been processed (if +prepare, info_complete, and finalize were true for each of the steps). +If it returns a true value the navigation loop will be aborted. If it +does not return true, navigation continues by then inserting the step +$self->default_step and running $self->nav_loop again (recurses) to +fall back to the default step. + +=item post_navigate (method) + +Called from within navigate. Called after the nav_loop has finished +running but within the eval block to catch errors. Will only run if +there were no errors which died during the nav_loop process. + +It can be disabled from running by setting the _no_post_navigate +property. + +If per-step authentication is enabled and authentication fails, +the post_navigate method will still be called (the post_navigate +method can check the ->is_authed method to change behavior). If +application level authentication is enabled and authentication +fails, none of the pre_navigate, nav_loop, or post_navigate methods +will be called. + +=item post_print (hook) + +A hook which occurs after the printing has taken place. Is only run +if the information was not complete. Useful for cases such as +printing rows of a database query after displaying a query form. + +=item post_step (hook) + +Ran at the end of the step's loop if prepare, info_complete, and +finalize all returned true. Allows for cleanup. If a true value is +returned, execution of navigate is returned and no more steps are +processed. + +=item pre_loop (method) + +Called right before the navigation loop is started (at the beginning +of nav_loop). At this point the path is set (but could be modified). +The only argument is a reference to the path array. If it returns a +true value - the navigation routine is aborted. + +=item pre_navigate (method) + +Called at the very beginning of the navigate method, but within the +eval block to catch errors. Called before the nav_loop method is +started. If a true value is returned then navigation is skipped (the +nav_loop is never started). + +=item pre_step (hook) + +Ran at the beginning of the loop before prepare, info_compelete, and +finalize are called. If it returns true, execution of nav_loop is +returned and no more steps are processed.. + +=item prepare (hook) + +Defaults to true. A hook before checking if the info_complete is true. +Intended to be used to cleanup the form data. + +=item prepared_print (hook) + +Called when any of prepare, info_complete, or finalize fail. Prepares +a form hash and a fill hash to pass to print. The form hash is primarily +intended for use by the templating system. The fill hash is intended +to be used to fill in any html forms. + +=item previous_step (method) + +List the step previous to this one. Will return '' if there is no previous step. + +=item print (hook) + +Take the information generated by prepared_print, format it, and print it out. +Default incarnation uses CGI::Ex::Template which is compatible with +Template::Toolkit. Arguments are: step name (used to call the +file_print hook), swap hashref (passed to call swap_template), and +fill hashref (passed to fill_template). + +During the print call, the file_print hook is called which should +return a filename or a scalar reference to the template content is + +=item ready_validate (hook) + +Should return true if enough information is present to run validate. +Default is to look if $ENV{'REQUEST_METHOD'} is 'POST'. A common +usage is to pass a common flag in the form such as 'processing' => 1 +and check for its presence - such as the following: + + sub ready_validate { shift->form->{'processing'} } + +Changing the behavior of ready_validate can help in making wizard type +applications. + +=item recurse_limit (method) + +Default 15. Maximum number of times to allow nav_loop to call itself. +The recurse level will increase every time that ->jump is called, or if +the end of the nav_loop is reached and the process tries to add the +default_step and run it again. + +If ->jump is used often - the recurse_limit will be reached more +quickly. It is safe to raise this as high as is necessary - so long +as it is intentional. + +Often the limit is reached if a step did not have a validation hash, +or if the set_ready_validate(0) method was not called once the data +had been successfully validated and acted upon. + +=item replace_path (method) + +Arguments are the steps used to replace. Can be called any time. +Replaces the remaining steps (if any) of the current path. + +=item require_auth (method) + +Default undef. Can return either a true value or a hashref of step names. + +If a hashref of stepnames is returned, authentication will be turned on +at the step level. In this mode if any step is accessed, the get_valid_auth +method will be called. If it fails, then the nav_loop will be stopped +(the post_navigate method will be called - use the is_authed method to perform +different functions). Any step of the path not in the hash will not require +authentication. For example, to add authentication to add authentication +to the add, edit and delete steps you could do: + + sub require_auth { {add => 1, edit => 1, delete => 1} } + +If a non-hash true value is returned from the require_auth method then +authentication will take place before the pre_navigation or the nav_loop methods. +If authentication fails the navigation process is exited (the post_navigate +method will not be called). + + sub require_auth { 1 } + +Alternatively you can also could do either of the following: + + __PACKAGE__->navigate_authenticated; # instead of __PACKAGE__->navigate; + + # OR + + sub init { shift->require_auth(1) } + + # OR + + __PACKAGE__->new({require_auth => 1}->navigate; + +If get_valid_auth returns true, in either case, the is_authed method will +return true and the auth_data will contain the authenticated user's data. +If it returns false, auth_data may possibly contain a defined but false +data object with details as to why authentication failed. + +See the get_valid_auth method. + +=item run_hook (method) + +Arguments are a hook name and the step to find the hook for. Calls +the find_hook method to get a code ref which it then calls and returns +the result passing any extra arguments to run_hook as arguments to the +code ref. + +Each call to run_hook is logged in the arrayref returned by the +history method. This information is summarized in the dump_history +method and is useful for tracing the flow of the program. + +The run_hook method is part of the core of CGI::Ex::App. It allows +for an intermediate layer in normal method calls. Because of +run_hook, it is possible to logically override methods on a step by +step basis, or override a method for all of the steps, or even to +break code out into separate modules. + +=item run_step (hook) + +Runs all of the hooks specific to each step, beginning with pre_step +and ending with post_step (for a full listing of steps, see the +section on process flow). Called after ->morph($step) has been run. +If this hook returns true, the nav_loop is exited (meaning the +run_step hook displayed a printed page). If it returns false, the +nav_loop continues on to run the next step. + +This hook performs the same base functionality as a method defined in +CGI::Applications ->run_modes. The default run_step method provides +much more granular control over the flow of the CGI. + +=item set_path (method) + +Arguments are the steps to set. Should be called before navigation +begins. This will set the path arrayref to the passed steps. + +This method is not normally used. + +=item set_ready_validate (method) + +Sets that the validation is ready to validate. Should set the value +checked by the hook ready_validate. The following would complement the +processing flag above: + + sub set_ready_validate { + my $self = shift; + if (shift) { + $self->form->{'processing'} = 1; + } else { + delete $self->form->{'processing'}; + } + } + +Note that for this example the form key "processing" was deleted. This +is so that the call to fill in any html forms won't swap in a value of +zero for form elements named "processing." + +=item skip (hook) + +Ran at the beginning of the loop before prepare, info_complete, and +finalize are called. If it returns true, nav_loop moves on to the +next step (the current step is skipped). + +=item stash (method) + +Returns a hashref that can store arbitrary user space data without +worrying about overwriting the internals of the application. + +=item step_key (method) + +Should return the keyname that will be used by the default "path" +method to look for in the form. Default value is 'step'. + +=item swap_template (hook) + +Takes the template and hash of variables prepared in print, and processes them +through the current template engine (default engine is CGI::Ex::Template). + +Arguments are the template and the swap hashref. The template can be either a +scalar reference to the actual content, or the filename of the content. If the +filename is specified - it should be relative to base_dir_abs. + +=item template_args (hook) + +Returns a hashref of args that will be passed to the "new" method of CGI::Ex::Template. +By default this hashref contains INCLUDE_PATH which is set equal to base_dir_abs. +It can be augmented with any arguments that CGI::Ex::Template would understand. + + sub template_args { + return { + INCLUDE_PATH => '/my/own/include/path', + WRAPPER => 'wrappers/main_wrapper.html', + }; + } + +=item unmorph (method) + +Allows for returning an object back to its previous blessed state if +the "morph" method was successful in morphing the App object. This +only happens if the object was previously morphed into another object +type. Before the object is re-blessed the method fixup_before_unmorph +is called. + +See allow_morph and morph. + +=item valid_steps (method) + +Called by the default path method. Should return a hashref of path +steps that are allowed. If the current step is not found in the hash +(or is not the default_step or js_step) the path method will return a +single step of ->forbidden_step and run its hooks. If no hash or undef is +returned, all paths are allowed (default). A key "forbidden_step" +containing the step that was not valid will be placed in the stash. +Often the valid_steps method does not need to be defined as arbitrary +method calls are not possible with CGI::Ex::App. + +Any steps that begin with _ are also "not" valid for passing in via the form +or path info. See the path method. + +Also, the pre_step, skip, prepare, and info_complete hooks allow for validating +the data before running finalize. + +=item validate (hook) + +Runs validation on the information posted in $self->form. Uses +CGI::Ex::Validate for the default validation. Calls the hook +hash_validation to load validation information. Should return true if +the form passed validation and false otherwise. Errors are stored as +a hash in $self->{hash_errors} via method add_errors and can be +checked for at a later time with method has_errors (if the default +validate was used). + +There are many ways and types to validate the data. Please see the L +module. + +Upon success, it will look through all of the items which were +validated, if any of them contain the keys append_path, insert_path, +or replace_path, that method will be called with the value as +arguments. This allows for the validation to apply redirection to the +path. A validation item of: + + {field => 'foo', required => 1, append_path => ['bar', 'baz']} + +would append 'bar' and 'baz' to the path should all validation succeed. + +=item verify_user (method) + +Installed as a hook to CGI::Ex::App during get_valid_auth. Should return +true if the user is ok. Default is to always return true. This can be +used to abort early before the get_pass_by_user hook is called. + + sub verify_user { + my ($self, $user) = @_; + return 0 if $user eq 'paul'; # don't let paul in + return 1; # let anybody else in + } + +=back + +=head1 OTHER APPLICATION MODULES + +The concepts used in CGI::Ex::App are not novel or unique. However, they +are all commonly used and very useful. All application builders were +built because somebody observed that there are common design patterns +in CGI building. CGI::Ex::App differs in that it has found more common design +patterns of CGI's than some and tries to get in the way less than others. + +CGI::Ex::App is intended to be sub classed, and sub sub classed, and each step +can choose to be sub classed or not. CGI::Ex::App tries to remain simple +while still providing "more than one way to do it." It also tries to avoid +making any sub classes have to call ->SUPER:: (although that is fine too). + +There are certainly other modules for building CGI applications. The +following is a short list of other modules and how CGI::Ex::App is +different. + +=over 4 + +=item C + +Seemingly the most well know of application builders. +CGI::Ex::App is different in that it: + + * Uses Template::Toolkit compatible CGI::Ex::Template by default + CGI::Ex::App can easily use another toolkit by simply + overriding the ->swap_template method. + CGI::Application uses HTML::Template. + * Offers integrated data validation. + CGI::Application has had custom plugins created that + add some of this functionality. CGI::Ex::App has the benefit + that validation is automatically available in javascript as well. + * Allows the user to print at any time (so long as proper headers + are sent. CGI::Application requires data to be pipelined. + * Offers hooks into the various phases of each step ("mode" in + CGI::Application lingo). CGI::Application provides only ->runmode + which is only a dispatch. + * Support for easily jumping around in navigation steps. + * Support for storing some steps in another package. + +CGI::Ex::App and CGI::Application are similar in that they take care +of handling headers and they allow for calling other "runmodes" from +within any given runmode. CGI::Ex::App's ->run_step is essentially +equivalent to a method call defined in CGI::Application's ->run_modes. +The ->run method of CGI::Application starts the application in the same +manner as CGI::Ex::App's ->navigate call. Many of the hooks around +CGI::Ex::App's ->run_step call are similar in nature to those provided by +CGI::Application. + +=item C + +There are actually many similarities. One of the nicest things about +CGI::Prototype is that it is extremely short (very very short). The +->activate starts the application in the same manner as CGI::Ex::App's +->navigate call. Both use Template::Toolkit as the default template +system (CGI::Ex::App uses CGI::Ex::Template which is TT compatible). +CGI::Ex::App is differrent in that it: + + * Offers integrated data validation. + CGI::Application has had custom addons created that + add some of this functionality. CGI::Ex::App has the benefit + that once validation is created, + * Offers more hooks into the various phases of each step. + * Support for easily jumping around in navigation steps. + * Support for storing only some steps in another package. + +=back + + +=head1 SIMPLE EXTENDED EXAMPLE + +The following example shows the creation of a basic recipe +database. It requires the use of DBD::SQLite, but that is all. +Once you have configured the db_file and base_dir_abs methods +of the "recipe" file, you will have a working script that +does CRUD for the recipe table. The observant reader may ask - why +not use Catalyst or Ruby on Rails? The observant programmer will +reply that making a framework do something simple is easy, but making +it do something complex is complex and any framework that tries to +do the those complex things for you is too complex. CGI::Ex::App +lets you write the complex logic but gives you the ability to +not worry about the boring details such as template engines, +or sticky forms, or cgi parameters, or data validation. Once +you are setup and are running, you are only left with providing +the core logic of the application. + + ### File: /var/www/cgi-bin/recipe (depending upon Apache configuration) + ### -------------------------------------------- + #!/usr/bin/perl -w + + use lib qw(/var/www/lib); + use Recipe; + Recipe->navigate; + + + ### File: /var/www/lib/Recipe.pm + ### -------------------------------------------- + package Recipe; + + use strict; + use base qw(CGI::Ex::App); + use CGI::Ex::Dump qw(debug); + + use DBI; + use DBD::SQLite; + + ###------------------------------------------### + + sub post_navigate { + # show what happened + debug shift->dump_history; + } + + sub base_dir_abs { '/var/www/templates' } + + sub base_dir_rel { 'content' } + + sub db_file { '/var/www/recipe.sqlite' } + + sub dbh { + my $self = shift; + if (! $self->{'dbh'}) { + my $file = $self->db_file; + my $exists = -e $file; + $self->{'dbh'} = DBI->connect("dbi:SQLite:dbname=$file", '', '', + {RaiseError => 1}); + $self->create_tables if ! $exists; + } + return $self->{'dbh'}; + } + + sub create_tables { + my $self = shift; + + $self->dbh->do("CREATE TABLE recipe ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + title VARCHAR(50) NOT NULL, + ingredients VARCHAR(255) NOT NULL, + directions VARCHAR(255) NOT NULL, + date_added VARCHAR(20) NOT NULL + )"); + } + + ###----------------------------------------------------------------### + + sub main_info_complete { 0 } + + sub main_hash_swap { + my $self = shift; + + my $s = "SELECT id, title, date_added + FROM recipe + ORDER BY date_added"; + my $data = $self->dbh->selectall_arrayref($s); + my @data = map {my %h; @h{qw(id title date_added)} = @$_; \%h} @$data; + + return { + recipies => \@data, + }; + } + + ###----------------------------------------------------------------### + + sub add_name_step { 'edit' } + + sub add_hash_validation { + return { + 'group order' => [qw(title ingredients directions)], + title => { + required => 1, + max_len => 30, + }, + ingredients => { + required => 1, + max_len => 255, + }, + directions => { + required => 1, + max_len => 255, + }, + }; + } + + sub add_finalize { + my $self = shift; + my $form = $self->form; + + my $s = "SELECT COUNT(*) FROM recipe WHERE title = ?"; + my ($count) = $self->dbh->selectrow_array($s, {}, $form->{'title'}); + if ($count) { + $self->add_errors(title => 'A recipe by this title already exists'); + return 0; + } + + $s = "INSERT INTO recipe (title, ingredients, directions, date_added) + VALUES (?, ?, ?, ?)"; + $self->dbh->do($s, {}, $form->{'title'}, + $form->{'ingredients'}, + $form->{'directions'}, + scalar(localtime)); + + $self->add_to_form(success => "Recipe added to the database"); + + return 1; + } + + ###----------------------------------------------------------------### + + sub edit_skip { shift->form->{'id'} ? 0 : 1 } + + sub edit_hash_common { + my $self = shift; + return {} if $self->ready_validate; + + my $sth = $self->dbh->prepare("SELECT * FROM recipe WHERE id = ?"); + $sth->execute($self->form->{'id'}); + my $hash = $sth->fetchrow_hashref; + + return $hash; + } + + sub edit_hash_validation { shift->add_hash_validation(@_) } + + sub edit_finalize { + my $self = shift; + my $form = $self->form; + + my $s = "SELECT COUNT(*) FROM recipe WHERE title = ? AND id != ?"; + my ($count) = $self->dbh->selectrow_array($s, {}, $form->{'title'}, $form->{'id'}); + if ($count) { + $self->add_errors(title => 'A recipe by this title already exists'); + return 0; + } + + my $s = "UPDATE recipe SET title = ?, ingredients = ?, directions = ? WHERE id = ?"; + $self->dbh->do($s, {}, $form->{'title'}, + $form->{'ingredients'}, + $form->{'directions'}, + $form->{'id'}); + + $self->add_to_form(success => "Recipe updated in the database"); + + return 1; + } + + ###----------------------------------------------------------------### + + sub view_skip { shift->edit_skip(@_) } + + sub view_hash_common { shift->edit_hash_common(@_) } + + ###----------------------------------------------------------------### + + sub delete_skip { shift->edit_skip(@_) } + + sub delete_info_complete { 1 } + + sub delete_finalize { + my $self = shift; + $self->dbh->do("DELETE FROM recipe WHERE id = ?", {}, $self->form->{'id'}); + + $self->add_to_form(success => "Recipe deleted from the database"); + return 1; + } + + 1; + + __END__ + + + + File: /var/www/templates/content/recipe/main.html + ### -------------------------------------------- + + + Recipe DB + +

Recipe DB

+ + [% IF success %]

[% success %]

[% END %] + + + + + [% FOR row IN recipies %] + + + + + + [% END %] + + +
#TitleDate Added
[% loop.count %].[% row.title %] + (Edit) + [% row.date_added %]
Add new recipe
+ + + + + File: /var/www/templates/content/recipe/edit.html + ### -------------------------------------------- + + + [% step == 'add' ? "Add" : "Edit" %] Recipe + +

[% step == 'add' ? "Add" : "Edit" %] Recipe

+ +
+ + + + + [% IF step != 'add' ~%] + + + + + + + + [% END ~%] + + + + + + + + + + + + + + + + +
Id:[% id %]
Date Added:[% date_added %]
Title: + [% title_error %]
Ingredients: + [% ingredients_error %]
Directions: + [% directions_error %]
+
+
+ + (Main Menu) + [% IF step != 'add' ~%] + (Delete this recipe) + [%~ END %] + + [% js_validation %] + + + + + File: /var/www/templates/content/recipe/view.html + ### -------------------------------------------- + + + [% title %] - Recipe DB + +

[% title %]

+

Date Added: [% date_added %]

+ +

Ingredients

+ [% ingredients %] + +

Directions

+ [% directions %] + +
+ (Main Menu) + (Edit this recipe) + + + + ### -------------------------------------------- + +Notes: + +The dbh method returns an SQLite dbh handle and auto creates the +schema. You will normally want to use MySQL or Oracle, or Postgres +and you will want your schema to NOT be auto-created. + +This sample uses hand rolled SQL. Class::DBI or a similar module +might make this example shorter. However, more complex cases that +need to involve two or three or four tables would probably be better +off using the hand crafted SQL. + +This sample uses SQL. You could write the application to use whatever +storage you want - or even to do nothing with the submitted data. + +We had to write our own HTML (Catalyst and Ruby on Rails do this for +you). For most development work - the HTML should be in a static +location so that it can be worked on by designers. It is nice that +the other frameworks give you stub html - but that is all it is. It +is worth about as much as copying and pasting the above examples. All +worthwhile HTML will go through a non-automated design/finalization +process. + +The add step used the same template as the edit step. We did +this using the add_name_step hook which returned "edit". The template +contains IF conditions to show different information if we were in +add mode or edit mode. + +We reused code, validation, and templates. Code and data reuse is a +good thing. + +The edit_hash_common returns an empty hashref if the form was ready to +validate. When hash_common is called and the form is ready to +validate, that means the form failed validation and is now printing +out the page. To let us fall back and use the "sticky" form fields +that were just submitted, we need to not provide values in the +hash_common method. + +We use hash_common. Values from hash_common are used for both +template swapping and filling. We could have used hash_swap and +hash_fill independently. + +The hook main_info_complete is hard coded to 0. This basically says +that we will never try and validate or finalize the main step - which +is most often the case. + +=head1 SEPARATING STEPS INTO SEPARATE FILES + +It may be useful sometimes to separate some or all of the steps of an +application into separate files. This is the way that CGI::Prototype +works. This is useful in cases were some steps and their hooks are +overly large - or are seldom used. + +The following modifications can be made to the previous "recipe db" +example that would move the "delete" step into its own file. Similar +actions can be taken to break other steps into their own file as well. + + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add the following line: + ### -------------------------------------------- + + sub allow_morph { 1 } + + + ### File: /var/www/lib/Recipe/Delete.pm + ### Remove the delete_* subs from lib/Recipe.pm + ### -------------------------------------------- + package Recipe::Delete; + + use strict; + use base qw(Recipe); + + sub skip { shift->edit_skip(@_) } + + sub info_complete { 1 } + + sub finalize { + my $self = shift; + $self->dbh->do("DELETE FROM recipe WHERE id = ?", {}, $self->form->{'id'}); + + $self->add_to_form(success => "Recipe deleted from the database"); + return 1; + } + + +Notes: + +The hooks that are called (skip, info_complete, and finalize) do not +have to be prefixed with the step name because they are now in their +own individual package space. However, they could still be named +delete_skip, delete_info_complete, and delete_finalize and the +run_hook method will find them (this would allow several steps with +the same "morph_package" to still be stored in the same external +module). + +The method allow_morph is passed the step that we are attempting to +morph to. If allow_morph returns true every time, then it will try +and require the extra packages every time that step is ran. You could +limit the morphing process to run only on certain steps by using code +similar to the following: + + sub allow_morph { return {delete => 1} } + + # OR + + sub allow_morph { + my ($self, $step) = @_; + return ($step eq 'delete') ? 1 : 0; + } + +The CGI::Ex::App temporarily blesses the object into the +"morph_package" for the duration of the step and re-blesses it into the +original package upon exit. See the morph method and allow_morph for more +information. + +=head1 RUNNING UNDER MOD_PERL + +The previous samples are essentially suitable for running under flat CGI, +Fast CGI, or mod_perl Registry or mod_perl PerlRun type environments. It +is very easy to move the previous example to be a true mod_perl handler. + +To convert the previous recipe example, simply add the following: + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add the following lines: + ### -------------------------------------------- + + sub handler { + Recipe->navigate; + return; + } + + + ### File: apache2.conf - or whatever your apache conf file is. + ### -------------------------------------------- + + SetHandler perl-script + PerlHandler Recipe + + +Notes: + +Both the /cgi-bin/recipe version and the /recipe version can co-exist. +One of them will be a normal cgi and the other will correctly use +mod_perl hooks for headers. + +Setting the location to /recipe means that the $ENV{SCRIPT_NAME} will +also be set to /recipe. This means that name_module method will +resolve to "recipe". If a different URI location is desired such as +"/my_cool_recipe" but the program is to use the same template content +(in the /var/www/templates/content/recipe directory), then we would +need to explicitly set the "name_module" parameter. It could be done +in either of the following ways: + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add the following line: + ### -------------------------------------------- + + sub name_module { 'recipe' } + + # OR + + sub init { + my $self = shift; + $self->{'name_module'} = 'recipe'; + } + +In most use cases it isn't necessary to set name_module, but it also +doesn't hurt and in all cases it is more descriptive to anybody who is +going to maintain the code later. + +=head1 ADDING AUTHENTICATION TO THE ENTIRE APPLICATION + +Having authentication is sometimes a good thing. To force +the entire application to be authenticated (require a valid username +and password before doing anything) you could do the following. + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add + ### -------------------------------------------- + + sub get_pass_by_user { + my $self = shift; + my $user = shift; + my $pass = $self->lookup_and_cache_the_pass($user); + return $pass; + } + + + ### File: /var/www/cgi-bin/recipe (depending upon Apache configuration) + ### Change the line with ->navigate; to + ### -------------------------------------------- + + Recipe->navigate_authenticated; + + # OR + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add + ### -------------------------------------------- + + sub require_auth { 1 } + + # OR + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add + ### -------------------------------------------- + + sub init { shift->require_auth(1) } + +See the require_auth, get_valid_auth, and auth_args methods for more information. +Also see the L perldoc. + +=head1 ADDING AUTHENTICATION TO INDIVIDUAL STEPS + +Sometimes you may only want to have certain steps require +authentication. For example, in the previous recipe example we +might want to let the main and view steps be accessible to anybody, +but require authentication for the add, edit, and delete steps. + +To do this, we would do the following to the original example (the +navigation must start with ->navigate. Starting with ->navigate_authenticated +will cause all steps to require validation): + + ### File: /var/www/lib/Recipe.pm + ### Same as before but add + ### -------------------------------------------- + + sub get_pass_by_user { + my $self = shift; + my $user = shift; + my $pass = $self->lookup_and_cache_the_pass($user); + return $pass; + } + + sub require_auth { {add => 1, edit => 1, delete => 1} } + +That's it. The add, edit, and delete steps will now require authentication. +See the require_auth, get_valid_auth, and auth_args methods for more information. +Also see the L perldoc. + +=head1 THANKS + + Bizhosting.com - giving a problem that fit basic design patterns. + + Earl Cahill - pushing the idea of more generic frameworks. + + Adam Erickson - design feedback, bugfixing, feature suggestions. + + James Lance - design feedback, bugfixing, feature suggestions. + +=head1 AUTHOR + +Paul Seamons + +=cut diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index e564efd..49c9a19 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -1,578 +1,705 @@ package CGI::Ex::Auth; -### CGI Extended Application +=head1 NAME + +CGI::Ex::Auth - Handle logins nicely. + +=cut ###----------------------------------------------------------------### -# Copyright 2004 - Paul Seamons # +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - - use strict; -use vars qw($USE_PLAINTEXT - $CHECK_CRYPTED - $EXPIRE_LOGINS - $FAILED_SLEEP - $VERSION - ); - -use CGI::Ex::Dump qw(debug); +use vars qw($VERSION); + use MIME::Base64 qw(encode_base64 decode_base64); +use Digest::MD5 qw(md5_hex); +use CGI::Ex; -BEGIN { - $VERSION = '0.10'; - $CHECK_CRYPTED = 1 if ! defined $CHECK_CRYPTED; - $FAILED_SLEEP = 2 if ! defined $FAILED_SLEEP; - $EXPIRE_LOGINS = 6 * 3600 if ! defined $EXPIRE_LOGINS; - #if ($ENV{MOD_PERL}) { - # require Digest::SHA1; - # require Digest::MD5; - #} -} +$VERSION = '2.00'; ###----------------------------------------------------------------### sub new { - my $class = shift || __PACKAGE__; - my $self = ref($_[0]) ? shift : {@_}; - bless $self, $class; - $self->init(); - return $self; + my $class = shift || __PACKAGE__; + my $args = shift || {}; + return bless {%$args}, $class; } -sub init {} +sub get_valid_auth { + my $self = shift; + $self = $self->new(@_) if ! ref $self; -###----------------------------------------------------------------### + ### shortcut that will print a js file as needed (such as the md5.js) + if ($self->script_name . $self->path_info eq $self->js_uri_path . "/CGI/Ex/md5.js") { + $self->cgix->print_js('CGI/Ex/md5.js'); + eval { die "Printed Javascript" }; + return; + } -sub require_auth { - my $self = shift; - $self = __PACKAGE__->new($self) if ! UNIVERSAL::isa($self, __PACKAGE__); + my $form = $self->form; + my $cookies = $self->cookies; + my $key_l = $self->key_logout; + my $key_c = $self->key_cookie; + my $has_cookies = scalar %$cookies; + + ### allow for logout + if ($form->{$key_l}) { + $self->delete_cookie({key => $key_c});; + $self->location_bounce($self->logout_redirect); + eval { die "Logging out" }; + return; + } - ### shortcut that will print a js file as needed - if ($ENV{PATH_INFO} && $ENV{PATH_INFO} =~ m|^/js/(CGI/Ex/\w+\.js)$|) { - $self->cgix->print_js($1); - return 0; - } + my $had_form_info; + foreach ([$form, $self->key_user, 1], + [$cookies, $key_c, 0], + ) { + my ($hash, $key, $is_form) = @$_; + next if ! defined $hash->{$key}; + $had_form_info ++ if $is_form; + + ### if it looks like a bare username (as in they didn't have javascript)- add in other items + my $data; + if ($is_form + && $hash->{$key} !~ m|^[^/]+/| + && defined $hash->{ $self->key_pass }) { + $data = $self->verify_token({ + token => { + user => delete $hash->{$key}, + test_pass => delete $hash->{ $self->key_pass }, + expires_min => delete($hash->{ $self->key_save }) ? -1 : delete($hash->{ $self->key_expires_min }) || $self->expires_min, + payload => delete $hash->{ $self->key_payload } || '', + }, + from => 'form', + }) || next; + + } else { + $data = $self->verify_token({token => $hash->{$key}, from => ($is_form ? 'form' : 'cookie')}) || next; + delete $hash->{$key} if $is_form; + } - my $form = $self->form; - my $cookies = $self->cookies; - my $key_l = $self->key_logout; - my $key_c = $self->key_cookie; - my $key_u = $self->key_user; - my $key_p = $self->key_pass; - my $key_chk = $self->key_cookie_check; - my $had_form_info = 0; - - ### if they've passed us information - try and use it - if ($form->{$key_l}) { - $self->delete_cookie; - - } elsif (exists($form->{$key_u}) && exists($form->{$key_p})) { - if ($self->verify_userpass($form->{$key_u}, $form->{$key_p})) { - my $has_cookies = scalar keys %$cookies; - my $user = $form->{$key_u}; - my $str = encode_base64(join(":", delete($form->{$key_u}), delete($form->{$key_p})), ""); - my $key_s = $self->key_save; - $self->set_cookie($str, delete($form->{$key_s})); - #return $self->success($user); # assume that cookies will work - if not next page will cause login - #### this may actually be the nicer thing to do in the common case - except for the nasty looking - #### url - all things considered - should really get location boucing to work properly while being - #### able to set a cookie at the same time - - if ($has_cookies) { - return $self->success($user); # assuming if they have cookies - the one we set will work - } else { - $form->{$key_chk} = time(); - my $key_r = $self->key_redirect; - if (! $form->{$key_r}) { - my $script = $ENV{SCRIPT_NAME} || die "Missing SCRIPT_NAME"; - my $info = $ENV{PATH_INFO} || ''; - my $query = $self->cgix->make_form($form); - $form->{$key_r} = $script . $info . ($query ? "?$query" : ""); + ### generate a fresh cookie if they submitted info on plaintext types + if ($self->use_plaintext || ($data->{'type'} && $data->{'type'} eq 'crypt')) { + $self->set_cookie({ + key => $key_c, + val => $self->generate_token($data), + no_expires => ($data->{ $self->key_save } ? 0 : 1), # make it a session cookie unless they ask for saving + }) if $is_form; # only set the cookie if we found info in the form - the cookie will be a session cookie after that + + ### always generate a cookie on types that have expiration + } else { + $self->set_cookie({ + key => $key_c, + val => $self->generate_token($data), + no_expires => 0, + }); + } + + ### successful login + + ### bounce to redirect + if (my $redirect = $form->{ $self->key_redirect }) { + $self->location_bounce($redirect); + eval { die "Success login - bouncing to redirect" }; + return; + + ### if they have cookies we are done + } elsif ($has_cookies || $self->no_cookie_verify) { + return $self; + + ### need to verify cookies are set-able + } elsif ($is_form) { + $form->{$self->key_verify} = $self->server_time; + my $query = $self->cgix->make_form($form); + my $url = $self->script_name . $self->path_info . ($query ? "?$query" : ""); + + $self->location_bounce($url); + eval { die "Success login - bouncing to test cookie" }; + return; } - $self->location_bounce($form->{$key_r}); - return 0; - } - } else { - $had_form_info = 1; - $self->delete_cookie; } - ### otherwise look for an already set cookie - } elsif ($cookies->{$key_c}) { - my ($user, $pass) = split /:/, decode_base64($cookies->{$key_c}), 2; - return $self->success($user) if $self->verify_userpass($user, $pass); - $self->delete_cookie; - - ### cases to handle no cookies - } elsif ($form->{$key_chk}) { - my $value = delete $form->{$key_chk}; - if ($self->allow_htauth) { - die "allow_htauth is not implemented - yet"; - } elsif (abs(time() - $value) < 3600) { - # fail down to below where we ask for auth - # this is assuming that all webservers in the cluster are within 3600 of each other - } else { - $self->hook_print("no_cookies", $form); - return 0; + ### make sure the cookie is gone + $self->delete_cookie({key => $key_c}) if $cookies->{$key_c}; + + ### nothing found - see if they have cookies + if (my $value = delete $form->{$self->key_verify}) { + if (abs(time() - $value) < 15) { + $self->no_cookies_print; + return; + } } - } - ### oh - you're still here - well then - ask for login credentials - my $key_r = $self->key_redirect; - if (! $form->{$key_r}) { - my $script = $ENV{SCRIPT_NAME} || die "Missing SCRIPT_NAME"; - my $info = $ENV{PATH_INFO} || ''; - my $query = $self->cgix->make_form($form); - $form->{$key_r} = $script . $info . ($query ? "?$query" : ""); - } - $form->{login_error} = $had_form_info; - $self->hook_print("get_login_info", $form); - return 0; + ### oh - you're still here - well then - ask for login credentials + my $key_r = $self->key_redirect; + if (! $form->{$key_r}) { + my $query = $self->cgix->make_form($form); + $form->{$key_r} = $self->script_name . $self->path_info . ($query ? "?$query" : ""); + } + + $form->{'had_form_data'} = $had_form_info; + $self->login_print; + my $data = $self->last_auth_data; + eval { die defined($data) ? $data : "Requesting credentials" }; + return; } ###----------------------------------------------------------------### -sub hook_print { - my $self = shift; - my $page = shift; - my $form = shift; - - ### copy the form and add various pieces - my $FORM = {%$form}; - $FORM->{payload} = $self->payload; - $FORM->{error} = ($form->{login_error}) ? "Login Failed" : ""; - $FORM->{key_user} = $self->key_user; - $FORM->{key_pass} = $self->key_pass; - $FORM->{key_save} = $self->key_save; - $FORM->{key_redirect} = $self->key_redirect; - $FORM->{form_name} = $self->form_name; - $FORM->{script_name} = $ENV{SCRIPT_NAME}; - $FORM->{path_info} = $ENV{PATH_INFO} || ''; - $FORM->{login_script} = $self->login_script($FORM); - delete $FORM->{$FORM->{key_pass}}; - - ### allow for custom hook - if (my $meth = $self->{hook_print}) { - $self->$meth($page, $FORM); - return 0; - } +sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || die "Missing SCRIPT_NAME" } - ### no hook - give basic functionality - my $content; - if ($page eq 'no_cookies') { - $content = qq{
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\""; - } +sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' } - $self->cgix->print_content_type(); - print $content; - return 0; -} - -###----------------------------------------------------------------### +sub server_time { time } -sub success { - my $self = shift; - my $user = shift; - $self->{user} = $ENV{REMOTE_USER} = $user; - $self->hook_success($user); - return 1; +sub cgix { + my $self = shift; + $self->{'cgix'} = shift if $#_ != -1; + return $self->{'cgix'} ||= CGI::Ex->new; } -sub user { - my $self = shift; - return $self->{user}; +sub form { + my $self = shift; + $self->{'form'} = shift if $#_ != -1; + return $self->{'form'} ||= $self->cgix->get_form; } -sub hook_success { - my $self = shift; - my $user = shift; - my $meth; - if ($meth = $self->{hook_success}) { - $self->$meth($user); - } +sub cookies { + my $self = shift; + $self->{'cookies'} = shift if $#_ != -1; + return $self->{'cookies'} ||= $self->cgix->get_cookies; } -###----------------------------------------------------------------### - sub delete_cookie { - my $self = shift; - my $key_c = $self->key_cookie; - $self->cgix->set_cookie({ - -name => $key_c, - -value => '', - -expires => '-10y', - -path => '/', - }); -} + my $self = shift; + my $args = shift; + my $key = $args->{'key'}; + $self->cgix->set_cookie({ + -name => $key, + -value => '', + -expires => '-10y', + -path => '/', + }); + delete $self->cookies->{$key}; +} sub set_cookie { - my $self = shift; - my $key_c = $self->key_cookie; - my $value = shift || ''; - my $save_pass = shift; - $self->cgix->set_cookie({ - -name => $key_c, - -value => $value, - ($save_pass ? (-expires => '+10y') : ()), - -path => '/', - }); + my $self = shift; + my $args = shift; + my $key = $args->{'key'}; + my $val = $args->{'val'}; + $self->cgix->set_cookie({ + -name => $key, + -value => $val, + ($args->{'no_expires'} ? () : (-expires => '+20y')), # let the expires time take care of things for types that self expire + -path => '/', + }); + $self->cookies->{$key} = $val; } sub location_bounce { - my $self = shift; - my $url = shift; - return $self->cgix->location_bounce($url); + my $self = shift; + my $url = shift; + return $self->cgix->location_bounce($url); } ###----------------------------------------------------------------### -sub key_logout { - my $self = shift; - $self->{key_logout} = shift if $#_ != -1; - return $self->{key_logout} ||= 'logout'; +sub key_logout { shift->{'key_logout'} ||= 'cea_logout' } +sub key_cookie { shift->{'key_cookie'} ||= 'cea_user' } +sub key_user { shift->{'key_user'} ||= 'cea_user' } +sub key_pass { shift->{'key_pass'} ||= 'cea_pass' } +sub key_time { shift->{'key_time'} ||= 'cea_time' } +sub key_save { shift->{'key_save'} ||= 'cea_save' } +sub key_expires_min { shift->{'key_expires_min'} ||= 'cea_expires_min' } +sub form_name { shift->{'form_name'} ||= 'cea_form' } +sub key_verify { shift->{'key_verify'} ||= 'cea_verify' } +sub key_redirect { shift->{'key_redirect'} ||= 'cea_redirect' } +sub key_payload { shift->{'key_payload'} ||= 'cea_payload' } +sub secure_hash_keys { shift->{'secure_hash_keys'} ||= [] } +sub no_cookie_verify { shift->{'no_cookie_verify'} ||= 0 } +sub use_crypt { shift->{'use_crypt'} ||= 0 } +sub use_blowfish { shift->{'use_blowfish'} ||= '' } +sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} ||= 0) } +sub use_base64 { my $s = shift; $s->{'use_base64'} = 1 if ! defined $s->{'use_base64'}; $s->{'use_base64'} } +sub expires_min { my $s = shift; $s->{'expires_min'} = 6 * 60 if ! defined $s->{'expires_min'}; $s->{'expires_min'} } + +sub logout_redirect { + my $self = shift; + return $self->{'logout_redirect'} || $self->script_name ."?loggedout=1"; } -sub key_cookie { - my $self = shift; - $self->{key_cookie} = shift if $#_ != -1; - return $self->{key_cookie} ||= 'ce_auth'; +sub js_uri_path { + my $self = shift; + return $self->{'js_uri_path'} ||= $self->script_name ."/js"; } -sub key_cookie_check { - my $self = shift; - $self->{key_cookie_check} = shift if $#_ != -1; - return $self->{key_cookie_check} ||= 'ccheck'; -} +###----------------------------------------------------------------### -sub key_user { - my $self = shift; - $self->{key_user} = shift if $#_ != -1; - return $self->{key_user} ||= 'ce_user'; +sub no_cookies_print { + my $self = shift; + $self->cgix->print_content_type; + print qq{
You do not appear to have cookies enabled.
}; + return 1; } -sub key_pass { - my $self = shift; - $self->{key_pass} = shift if $#_ != -1; - return $self->{key_pass} ||= 'ce_pass'; -} +sub login_print { + my $self = shift; + my $hash = $self->login_hash_common; + my $template = $self->login_template; -sub key_save { - my $self = shift; - $self->{key_save} = shift if $#_ != -1; - return $self->{key_save} ||= 'ce_save'; -} + ### allow for a hooked override + if (my $meth = $self->{'login_print'}) { + $meth->($self, $template, $hash); + return 0; + } -sub key_redirect { - my $self = shift; - $self->{key_redirect} = shift if $#_ != -1; - return $self->{key_redirect} ||= 'redirect'; -} + ### process the document + require CGI::Ex::Template; + my $cet = CGI::Ex::Template->new($self->template_args); + my $out = ''; + $cet->process_simple($template, $hash, \$out) || die $cet->error; + + ### fill in form fields + require CGI::Ex::Fill; + CGI::Ex::Fill::fill({text => \$out, form => $hash}); + + ### print it + $self->cgix->print_content_type; + print $out; -sub form_name { - my $self = shift; - $self->{form_name} = shift if $#_ != -1; - return $self->{form_name} ||= 'ce_form'; + return 0; } -sub allow_htauth { - my $self = shift; - $self->{allow_htauth} = shift if $#_ != -1; - return $self->{allow_htauth} ||= 0; +sub template_args { + my $self = shift; + return $self->{'template_args'} ||= { + INCLUDE_PATH => $self->template_include_path, + }; } -sub payload { - my $self = shift; - my $user = shift; - my $time = shift || time(); - my $meth; - my @payload = ($time); - if ($meth = $self->{hook_payload}) { - push @payload, $self->$meth($user); - } - return join "/", @payload; +sub template_include_path { shift->{'template_include_path'} || '' } + +sub login_hash_common { + my $self = shift; + my $form = $self->form; + my $data = $self->last_auth_data; + $data = {} if ! defined $data; + + return { + %$form, + error => ($form->{'had_form_data'}) ? "Login Failed" : "", + login_data => $data, + key_user => $self->key_user, + key_pass => $self->key_pass, + key_time => $self->key_time, + key_save => $self->key_save, + key_expires_min => $self->key_expires_min, + key_payload => $self->key_payload, + key_redirect => $self->key_redirect, + form_name => $self->form_name, + script_name => $self->script_name, + path_info => $self->path_info, + md5_js_path => $self->js_uri_path ."/CGI/Ex/md5.js", + use_plaintext => $self->use_plaintext, + $self->key_user => $data->{'user'} || '', + $self->key_pass => '', # don't allow for this to get filled into the form + $self->key_time => $self->server_time, + $self->key_payload => $self->generate_payload({%$data, login_form => 1}), + $self->key_expires_min => $self->expires_min, + + }; } ###----------------------------------------------------------------### -sub verify_userpass { - my $self = shift; - my $user = shift; - my $pass = shift; - my $host = shift || $self->host; - my $meth; - if ($meth = $self->{hook_verify_userpass}) { - return $self->$meth($user, $pass, $host); - } else { - return $self->hook_verify_userpass($user, $pass, $host); - } -} +sub verify_token { + my $self = shift; + my $args = shift; + my $token = delete $args->{'token'} || die "Missing token"; + my $data = $self->{'_last_auth_data'} = $self->new_auth_data({token => $token, %$args}); + + ### token already parsed + if (ref $token) { + $data->add_data({%$token, armor => 'none'}); -sub hook_verify_userpass { - my $self = shift; - my $user = shift; - my $pass_test = shift; - my $host = shift || $self->host; - - return undef if ! defined $user; - return undef if ! defined $pass_test; - my $pass_real = $self->hook_get_pass_by_user($user, $host); - return undef if ! defined $pass_real; - - my $type_real = ($pass_real =~ m/^(md5|sha1)\((.+)\)$/) ? $1 : 'plainorcrypt'; - my $hash_real = $2; - my $type_test = ($pass_test =~ m/^(md5|sha1)\((.+)\)$/) ? $1 : 'plainorcrypt'; - my $hash_test = $2; - - ### if both types were plaintext - check if the equal - if ($type_real eq 'plainorcrypt' - && $type_test eq 'plainorcrypt') { - return 1 if $pass_real eq $pass_test; - if ($CHECK_CRYPTED && $pass_real =~ m|^([./0-9A-Za-z]{2})(.{,11})$|) { - return 1 if crypt($pass_test, $1) eq $pass_real; + ### parse token for info + } else { + my $found; + my $key; + for my $armor ('none', 'base64', 'blowfish') { # try with and without base64 encoding + my $copy = ($armor eq 'none') ? $token + : ($armor eq 'base64') ? decode_base64($token) + : ($key = $self->use_blowfish) ? decrypt_blowfish($token, $key) + : next; + if ($copy =~ m|^ ([^/]+) / (\d+) / (-?\d+) / (.*) / ([a-fA-F0-9]{32}) (?: / (sh\.\d+\.\d+))? $|x) { + $data->add_data({ + user => $1, + cram_time => $2, + expires_min => $3, + payload => $4, + test_pass => $5, + secure_hash => $6 || '', + armor => $armor, + }); + $found = 1; + last; + } elsif ($copy =~ m|^ ([^/]+) / (.*) $|x) { + $data->add_data({ + user => $1, + test_pass => $2, + armor => $armor, + }); + $found = 1; + last; + } + } + if (! $found) { + $data->error('Invalid token'); + return $data; + } } - return 0; - } else { - ### if test type is plaintext - then hash it and compare it alone - if ($type_test eq 'plainorcrypt') { - $pass_test = $self->enc_func($type_real, $pass_test); # encode same as real - $pass_test = "$type_real($pass_test)"; - return $pass_test eq $pass_real; - - ### if real type is plaintext - then hash it to get ready for test - } elsif ($type_real eq 'plainorcrypt') { - $pass_real = $self->enc_func($type_test, $pass_real); - $pass_real = "$type_test($pass_real)"; - $type_real = $type_test; + + ### verify the user and get the pass + my $pass; + if (! defined($data->{'user'})) { + $data->error('Missing user'); + + } elsif (! defined $data->{'test_pass'}) { + $data->error('Missing test_pass'); + + } elsif (! $self->verify_user($data->{'user'} = $self->cleanup_user($data->{'user'}))) { + $data->error('Invalid user'); + + } elsif (! defined($pass = eval { $self->get_pass_by_user($data->{'user'}) })) { + $data->add_data({details => $@}); + $data->error('Could not get pass'); } - - ### the types should be the same (unless a system stored sha1 and md5 passwords) - if ($type_real ne $type_test) { - warn "Test types for user \"$user\" are of two different types - very bad"; - return 0; + return $data if $data->error; + + + ### store - to allow generate_token to not need to relookup the pass + $data->add_data({real_pass => $pass}); + + + ### looks like a secure_hash cram + if ($data->{'secure_hash'}) { + $data->add_data(type => 'secure_hash_cram'); + my $array = eval {$self->secure_hash_keys }; + if (! $array) { + $data->error('secure_hash_keys not found'); + } elsif (! @$array) { + $data->error('secure_hash_keys empty'); + } elsif ($data->{'secure_hash'} !~ /^sh\.(\d+)\.(\d+)$/ || $1 > $#$array) { + $data->error('Invalid secure hash'); + } else { + my $rand1 = $1; + my $rand2 = $2; + my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}); + my $str = join("/", @{$data}{qw(user cram_time expires_min payload)}); + my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2)); + if ($data->{'expires_min'} > 0 + && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) { + $data->error('Login expired'); + } elsif (lc($data->{'test_pass'}) ne $sum) { + $data->error('Invalid login'); + } + } + + ### looks like a normal cram + } elsif ($data->{'cram_time'}) { + $data->add_data(type => 'cram'); + my $real = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}); + my $str = join("/", @{$data}{qw(user cram_time expires_min payload)}); + my $sum = md5_hex($str .'/'. $real); + if ($data->{'expires_min'} > 0 + && ($self->server_time - $data->{'cram_time'}) > $data->{'expires_min'} * 60) { + $data->error('Login expired'); + } elsif (lc($data->{'test_pass'}) ne $sum) { + $data->error('Invalid login'); + } + + ### plaintext_crypt + } elsif ($data->{'real_pass'} =~ m|^([./0-9A-Za-z]{2})([./0-9A-Za-z]{11})$| + && crypt($data->{'test_pass'}, $1) eq $data->{'real_pass'}) { + $data->add_data(type => 'crypt', was_plaintext => 1); + + ### failed plaintext crypt + } elsif ($self->use_crypt) { + $data->error('Invalid login'); + $data->add_data(type => 'crypt', was_plaintext => ($data->{'test_pass'} =~ /^[a-f0-9]{32}$/ ? 0 : 1)); + + ### plaintext and md5 + } else { + my $is_md5_t = $data->{'test_pass'} =~ /^[a-f0-9]{32}$/; + my $is_md5_r = $data->{'real_pass'} =~ /^[a-f0-9]{32}$/; + my $test = $is_md5_t ? lc($data->{'test_pass'}) : md5_hex($data->{'test_pass'}); + my $real = $is_md5_r ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'}); + $data->add_data(type => ($is_md5_r ? 'md5' : 'plaintext'), was_plaintext => ($is_md5_t ? 0 : 1)); + $data->error('Invalid login') + if $test ne $real; } - ### no payload - compare directly - if ($hash_test !~ m|^(.+)/([^/]+)$|) { - return lc($pass_test) eq lc($pass_real); + ### check the payload + if (! $data->error && ! $self->verify_payload($data->{'payload'})) { + $data->error('Invalid payload'); + } - ### and finally - check the payload (allows for expiring login) + return $data; +} + +sub new_auth_data { + my $self = shift; + return CGI::Ex::Auth::Data->new(@_); +} + +sub last_auth_data { shift->{'_last_auth_data'} } + +sub generate_token { + my $self = shift; + my $data = shift || $self->last_auth_data; + die "Can't generate a token off of a failed auth" if ! $data; + + my $token; + + ### do kinds that require staying plaintext + if ( (defined($data->{'use_plaintext'}) ? $data->{'use_plaintext'} : $self->use_plaintext) # ->use_plaintext is true if ->use_crypt is + || (defined($data->{'use_crypt'}) && $data->{'use_crypt'}) + || (defined($data->{'type'}) && $data->{'type'} eq 'crypt')) { + $token = $data->{'user'} .'/'. $data->{'real_pass'}; + + ### all other types go to cram - secure_hash_cram, cram, plaintext and md5 } else { - my $payload = $1; # payload can be anything - my $compare = $2; # a checksum which is the enc of the payload + '/' + enc of password - my @payload = split /\//, $payload; + my $user = $data->{'user'} || die "Missing user"; + my $real = defined($data->{'real_pass'}) ? ($data->{'real_pass'} =~ /^[a-f0-9]{32}$/ ? lc($data->{'real_pass'}) : md5_hex($data->{'real_pass'})) + : die "Missing real_pass"; + my $exp = defined($data->{'expires_min'}) ? $data->{'expires_min'} : $self->expires_min; + my $load = $self->generate_payload($data); + die "Payload can not contain a \"/\. Please escape it in generate_payload." if $load =~ m|/|; + die "User can not contain a \"/\." if $user =~ m|/|; + + my $array; + if (! $data->{'prefer_cram'} + && ($array = eval { $self->secure_hash_keys }) + && @$array) { + my $rand1 = int(rand @$array); + my $rand2 = int(rand 100000); + my $str = join("/", $user, $self->server_time, $exp, $load); + my $sum = md5_hex($str .'/'. $real .('/sh.'.$array->[$rand1].'.'.$rand2)); + $token = $str .'/'. $sum . '/sh.'.$rand1.'.'.$rand2; + } else { + my $str = join("/", $user, $self->server_time, $exp, $load); + my $sum = md5_hex($str .'/'. $real); + $token = $str .'/'. $sum; + } + } - return 0 if $self->enc_func($type_test, "$payload/$hash_real") ne $compare; + if (my $key = $data->{'use_blowfish'} || $self->use_blowfish) { + $token = encrypt_blowfish($token, $key); - ### if no save password && greater than expire time- expire - if ($EXPIRE_LOGINS && ! $payload[1] && $payload[0] =~ m/^(\d+)/) { - return 0 if time() > $1 + $EXPIRE_LOGINS; - } - return 1; + } elsif (defined($data->{'use_base64'}) ? $data->{'use_base64'} : $self->use_base64) { + $token = encode_base64($token, ''); } - } - return 0; # nothing should make it this far -} - -sub enc_func { - my $self = shift; - my $type = shift; - my $str = shift; - if ($type eq 'md5') { - require Digest::MD5; - return &Digest::MD5::md5_hex($str); - } elsif ($type eq 'sha1') { - require Digest::SHA1; - return &Digest::SHA1::sha1_hex($str); - } + + return $token; } -sub set_hook_get_pass_by_user { - my $self = shift; - $self->{hook_get_pass_by_user} = shift; +sub generate_payload { + my $self = shift; + my $args = shift; + return defined($args->{'payload'}) ? $args->{'payload'} : ''; } -sub hook_get_pass_by_user { - my $self = shift; - my $user = shift; - my $host = shift || $self->host; - my $meth; - if ($meth = $self->{hook_get_pass_by_user}) { - return $self->$meth($user, $host); - } - die "hook_get_pass_by_user is a virtual method - please override - or use set_hook_get_pass_by_user"; +sub verify_user { + my $self = shift; + my $user = shift; + if (my $meth = $self->{'verify_user'}) { + return $meth->($self, $user); + } + return 1; } -###----------------------------------------------------------------### +sub cleanup_user { + my $self = shift; + my $user = shift; + if (my $meth = $self->{'cleanup_user'}) { + return $meth->($self, $user); + } + return $user; +} -sub cgix { - my $self = shift; - $self->{cgix} = shift if $#_ != -1; - return $self->{cgix} ||= do { - require CGI::Ex; - CGI::Ex->new(); # return of the do - }; +sub get_pass_by_user { + my $self = shift; + my $user = shift; + if (my $meth = $self->{'get_pass_by_user'}) { + return $meth->($self, $user); + } + + die "Please override get_pass_by_user"; } -sub form { - my $self = shift; - if ($#_ != -1) { - $self->{form} = shift || die "Invalid form"; - } - return $self->{form} ||= $self->cgix->get_form; +sub verify_payload { + my $self = shift; + my $payload = shift; + if (my $meth = $self->{'verify_payload'}) { + return $meth->($self, $payload); + } + return 1; } -sub cookies { - my $self = shift; - if ($#_ != -1) { - $self->{cookies} = shift || die "Invalid cookies"; - } - return $self->{cookies} ||= $self->cgix->get_cookies; -} - -sub host { - my $self = shift; - return $self->{host} = shift if $#_ != -1; - return $self->{host} ||= do { - my $host = $ENV{HTTP_HOST} || die "Missing \$ENV{HTTP_HOST}"; - $host = lc($host); - $host =~ s/:\d*$//; # remove port number - $host =~ s/\.+$//; # remove qualified dot - $host =~ s/[^\w\.\-]//g; # remove odd characters - $host; # return of the do - }; +###----------------------------------------------------------------### + +sub encrypt_blowfish { + my ($str, $key) = @_; + + require Crypt::Blowfish; + my $cb = Crypt::Blowfish->new($key); + + $str .= (chr 0) x (8 - length($str) % 8); # pad to multiples of 8 + + my $enc = ''; + $enc .= unpack "H16", $cb->encrypt($1) while $str =~ /\G(.{8})/g; # 8 bytes at a time + + return $enc; +} + +sub decrypt_blowfish { + my ($enc, $key) = @_; + + require Crypt::Blowfish; + my $cb = Crypt::Blowfish->new($key); + + my $str = ''; + $str .= $cb->decrypt(pack "H16", $1) while $enc =~ /\G([A-Fa-f0-9]{16})/g; + $str =~ y/\00//d; + + return $str } ###----------------------------------------------------------------### -sub basic_login_page { - my $self = shift; - my $form = shift; +sub login_template { + my $self = shift; + return $self->{'login_template'} if $self->{'login_template'}; - my $text = $self->basic_login_template(); - $self->cgix->swap_template(\$text, $form); - $self->cgix->fill(\$text, $form); + my $text = "" + . $self->login_header + . $self->login_form + . $self->login_script + . $self->login_footer; + return \$text; +} + +sub login_header { + return shift->{'login_header'} || q { + [%~ TRY ; PROCESS 'login_header.tt' ; CATCH %][% END ~%] + }; +} - return $text; +sub login_footer { + return shift->{'login_footer'} || q { + [%~ TRY ; PROCESS 'login_footer.tt' ; CATCH %][% END ~%] + }; } -sub basic_login_template { - return qq{ - [% header %] -
- [% error %] -
- - +sub login_form { + return shift->{'login_form'} || q { + + - + - + - + - [% 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 q { + [%~ IF ! use_plaintext %] + + [% END ~%] }; } ###----------------------------------------------------------------### -### return arguments to add on to a url to allow login (for emails) -sub auth_string_sha1 { - my $self = shift; - my $user = shift; - my $pass = shift; - my $save = shift || 0; - my $time = shift || time; - my $payload = $self->payload($time); - - require Digest::SHA1; - - if ($pass =~ /^sha1\((.+)\)$/) { - $pass = $1; - } else { - $pass = &Digest::SHA1::sha1_hex($pass); - } - $pass = &Digest::SHA1::sha1_hex("$payload/$save/$pass"); +package CGI::Ex::Auth::Data; - return $self->cgix->make_form({ - $self->key_user => $user, - $self->key_pass => "sha1($payload/$save/$pass)", - $self->key_save => $save, - }); +use strict; +use overload + 'bool' => sub { ! shift->error }, + '0+' => sub { 1 }, + '""' => sub { shift->as_string }, + fallback => 1; + +sub new { + my ($class, $args) = @_; + return bless {%{ $args || {} }}, $class; +} + +sub add_data { + my $self = shift; + my $args = @_ == 1 ? shift : {@_}; + @{ $self }{keys %$args} = values %$args; +} + +sub error { + my $self = shift; + if (@_ == 1) { + $self->{'error'} = shift; + $self->{'error_caller'} = [caller]; + } + return $self->{'error'}; +} + +sub as_string { + my $self = shift; + return $self->error || ($self->{'user'} && $self->{'type'}) ? "Valid auth data" : "Unverified auth data"; } ###----------------------------------------------------------------### @@ -581,65 +708,39 @@ sub auth_string_sha1 { __END__ -=head1 NAME - -CGI::Ex::Auth - Handle logins nicely. - =head1 SYNOPSIS ### authorize the user - my $auth = $self->auth({ - hook_get_pass_by_user => \&get_pass_by_user, - hook_print => \&my_print, - login_type => 'sha1', + my $auth = $self->get_valid_auth({ + get_pass_by_user => \&get_pass_by_user, }); - ### login_type may be sha1, md5, or plaintext sub get_pass_by_user { my $auth = shift; - my $username = shift; - my $host = shift; - my $password = some_way_of_getting_password; - return $password; - } - - sub my_print { - my $auth = shift; - my $step = shift; - my $form = shift; # form includes login_script at this point - my $content = get_content_from_somewhere; - $auth->cgix->swap_template(\$content, $form); - $auth->cgix->print_content_type; - print $content; + my $user = shift; + my $pass = some_way_of_getting_password($user); + return $pass; } =head1 DESCRIPTION -CGI::Ex::Auth allows for autoexpiring, safe logins. Auth uses -javascript modules that perform SHA1 and MD5 encoding to encode -the password on the client side before passing them through the -internet. - -If SHA1 is used the storage of the password can be described by -the following code: +CGI::Ex::Auth allows for auto-expiring, safe and easy web based logins. Auth uses +javascript modules that perform MD5 hashing to cram the password on +the client side before passing them through the internet. - my $pass = "plaintextpassword"; - my $save = ($save_the_password) ? 1 : 0; - my $time = time; - my $store = sha1_hex("$time/$save/" . sha1_hex($pass)); +For the stored cookie you can choose to use cram mechanisms, +secure hash cram tokens, auto expiring logins (not cookie based), +and Crypt::Blowfish protection. You can also choose to keep +passwords plaintext and to use perl's crypt for testing +passwords. -This allows for passwords to be stored as sha1 in a database. -Passwords stored in the database this way are still susceptible to bruteforce -attack, but are much more secure than storing plain text. - -If MD5 is used, the above procedure is replaced with md5_hex. - -A downside to this module is that it does not use a session to preserve state -so authentication has to happen on every request. A plus is that you don't -need to use a session. With later releases, a method will be added to allow -authentication to look inside of a stored session somewhat similar to -CGI::Session::Auth. +A downside to this module is that it does not use a session to +preserve state so get_pass_by_user has to happen on every request (any +authenticated area has to verify authentication each time). A plus is +that you don't need to use a session if you don't want to. It is up +to the interested reader to add caching to the get_pass_by_user +method. =head1 METHODS @@ -647,116 +748,274 @@ CGI::Session::Auth. =item C -Constructor. Takes a hash or hashref of properties as arguments. - -=item C - -Called automatically near the end of new. - -=item C +Constructor. Takes a hashref of properties as arguments. + +Many of the methods which may be overridden in a subclass, +or may be passed as properties to the new constuctor such as in the following: + + CGI::Ex::Auth->new({ + get_pass_by_user => \&my_pass_sub, + key_user => 'my_user', + key_pass => 'my_pass', + login_template => \"
", + }); + +The following methods will look for properties of the same name. Each of these will be +defined separately. + + cgix + cleanup_user + cookies + expires_min + form + form_name + get_pass_by_user + js_uri_path + key_cookie + key_expires_min + key_logout + key_pass + key_payload + key_redirect + key_save + key_time + key_user + key_verify + login_footer + login_form + login_header + login_script + login_template + no_cookie_verify + path_info + script_name + secure_hash_keys + template_args + template_include_path + use_base64 + use_blowfish + use_crypt + use_plaintext + verify_payload + verify_user + +=item C + +Takes either an auth_data object from a auth_data returned by verify_token, +or a hashref of arguments. + +Possible arguments are: + + user - the username we are generating the token for + real_pass - the password of the user (if use_plaintext is false + and use_crypt is false, the password can be an md5sum + of the user's password) + use_blowfish - indicates that we should use Crypt::Blowfish to protect + the generated token. The value of this argument is used + as the key. Default is false. + use_base64 - indicates that we should use Base64 encoding to protect + the generated token. Default is true. Will not be + used if use_blowfish is true. + use_plaintext - indicates that we should keep the password in plaintext + use_crypt - also indicates that we should keep the password in plaintext + expires_min - says how many minutes until the generated token expires. + Values <= 0 indicate to not ever expire. Used only on cram + types. + payload - a payload that will be passed to generate_payload and then + will be added to cram type tokens. It cannot contain a /. + prefer_cram - If the secure_hash_keys method returns keys, and it is a non-plaintext + token, generate_token will create a secure_hash_cram. Set + this value to true to tell it to use a normal cram. This + is generally only useful in testing. + +The following are types of tokens that can be generated by generate_token. Each type includes +pseudocode and a sample of a generated that token. + + plaintext: + user := "paul" + real_pass := "123qwe" + token := join("/", user, real_pass); + + use_base64 := 0 + token == "paul/123qwe" + + use_base64 := 1 + token == "cGF1bC8xMjNxd2U=" + + use_blowfish := "foobarbaz" + token == "6da702975190f0fe98a746f0d6514683" + + Notes: This token will be used if either use_plaintext or use_crypt is set. + The real_pass can also be the md5_sum of the password. If real_pass is an md5_sum + of the password but the get_pass_by_user hook returns the crypt'ed password, the + token will not be able to be verified. + + cram: + user := "paul" + real_pass := "123qwe" + server_time := 1148512991 # a time in seconds since epoch + expires_min := 6 * 60 + payload := "something" + + md5_pass := md5_sum(real_pass) # if it isn't already a 32 digit md5 sum + str := join("/", user, server_time, expires_min, payload, md5_pass) + md5_str := md5(sum_str) + token := join("/", user, server_time, expires_min, payload, md5_str) + + use_base64 := 0 + token == "paul/1148512991/360/something/16d0ba369a4c9781b5981eb89224ce30" + + use_base64 := 1 + token == "cGF1bC8xMTQ4NTEyOTkxLzM2MC9zb21ldGhpbmcvMTZkMGJhMzY5YTRjOTc4MWI1OTgxZWI4OTIyNGNlMzA=" + + Notes: use_blowfish is available as well + + secure_hash_cram: + user := "paul" + real_pass := "123qwe" + server_time := 1148514034 # a time in seconds since epoch + expires_min := 6 * 60 + payload := "something" + secure_hash := ["aaaa", "bbbb", "cccc", "dddd"] + rand1 := 3 # int(rand(length(secure_hash))) + rand2 := 39163 # int(rand(100000)) + + md5_pass := md5_sum(real_pass) # if it isn't already a 32 digit md5 sum + + sh_str1 := join(".", "sh", secure_hash[rand1], rand2) + sh_str2 := join(".", "sh", rand1, rand2) + str := join("/", user, server_time, expires_min, payload, md5_pass, sh_str1) + md5_str := md5(sum_str) + token := join("/", user, server_time, expires_min, payload, md5_str, sh_str2) + + use_base64 := 0 + token == "paul/1148514034/360/something/06db2914c9fd4e11499e0652bcf67dae/sh.3.39163" + + Notes: use_blowfish is available as well. The secure_hash keys need to be set in the + "secure_hash_keys" property of the CGI::Ex::Auth object. + +=item C + +Performs the core logic. Returns an auth object on successful login. +Returns false on errored login (with the details of the error stored in +$@). If a false value is returned, execution of the CGI should be halted. +get_valid_auth WILL NOT automatically stop execution. + + $auth->get_valid_auth || exit; + +Optionally, the class and a list of arguments may be passed. This will create a +new object using the passed arguments, and then run get_valid_auth. + + CGI::Ex::Auth->get_valid_auth({key_user => 'my_user'}) || exit; + +=item C + +Called if login errored. Defaults to printing a very basic (but +adequate) page loaded from login_template.. -Performs the core logic. Returns true on successful login. -Returns false on failed login. If a false value is returned, -execution of the CGI should be halted. require_auth WILL -NOT automatically stop execution. - - $auth->require_auth || exit; - -=item C - -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 + +Passed to the template swapped during login_print. + + %$form, # any keys passed to the login script + error # The text "Login Failed" if a login occurred + login_data # A login data object if they failed authentication. + key_user # $self->key_user, # the username fieldname + key_pass # $self->key_pass, # the password fieldname + key_time # $self->key_time, # the server time field name + key_save # $self->key_save, # the save password checkbox field name + key_payload # $self->key_payload, # the payload fieldname + key_redirect # $self->key_redirect, # the redirect fieldname + form_name # $self->form_name, # the name of the form + script_name # $self->script_name, # where the server will post back to + path_info # $self->path_info, # $ENV{PATH_INFO} if any + md5_js_path # $self->js_uri_path ."/CGI/Ex/md5.js", # script for cramming + use_plaintext # $self->use_plaintext, # used to avoid cramming + $self->key_user # $data->{'user'}, # the username (if any) + $self->key_pass # '', # intentional blankout + $self->key_time # $self->server_time, # the server's time + $self->key_payload # $data->{'payload'} # the payload (if any) + $self->key_expires_min # $self->expires_min # how many minutes crams are valid =item C -If a key is passed the form hash that matches this key, the current user will -be logged out. Default is "logout". +If the form hash contains a true value in this field name, the current user will +be logged out. Default is "cea_logout". =item C -The name of the auth cookie. Default is "ce_auth". +The name of the auth cookie. Default is "cea_user". -=item C +=item C -A field name used during a bounce to see if cookies exist. Default is "ccheck". +A field name used during a bounce to see if cookies exist. Default is "cea_verify". =item C -The form field name used to pass the username. Default is "ce_user". +The form field name used to pass the username. Default is "cea_user". =item C -The form field name used to pass the password. Default is "ce_pass". +The form field name used to pass the password. Default is "cea_pass". =item C -The form field name used to pass whether they would like to save the cookie for -a longer period of time. Default is "ce_save". The value of this form field -should be 1 or 0. If it is zero, the cookie installed will be a session cookie -and will expire in $EXPIRE_LOGINS seconds (default of 6 hours). +Works in conjunction with key_expires_min. If key_save is true, then +the cookie will be set to be saved for longer than the current session +(If it is a plaintext variety it will be given a 20 year life rather +than being a session cookie. If it is a cram variety, the expires_min +portion of the cram will be set to -1). If it is set to false, the cookie +will be available only for the session (If it is a plaintext variety, the cookie +will be session based and will be removed on the next loggout. If it is +a cram variety then the cookie will only be good for expires_min minutes. -=item C +Default is "cea_save". -The name of the html login form to attach the javascript to. Default is "ce_form". +=item C -=item C +The name of the form field that contains how long cram type cookies will be valid +if key_save contains a false value. -Additional variables to store in the cookie. Can be used for anything. Should be -kept small. Default is time (should always use time as the first argument). Used -for autoexpiring the cookie and to prevent bruteforce attacks. +Default key name is "cea_expires_min". Default field value is 6 * 60 (six hours). -=item C +This value will have no effect when use_plaintext or use_crypt is set. -Called to verify the passed form information or the stored cookie. Calls hook_verify_userpass. +A value of -1 means no expiration. -=item C +=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. +The name of the html login form to attach the javascript to. Default is "cea_form". -=item C +=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. +This method verifies the token that was passed either via the form or via cookies. +It will accept plaintext or crammed tokens (A listing of the available algorithms +for creating tokes is listed below). It also allows for armoring the token with +base64 encoding, or using blowfish encryption. A listing of creating these tokens +can be found under generate_token. -=item C +=item C -Allows for setting the subref used by hook_get_pass_by_user.x +Called by verify_token. Default is to do no modification. Allows for usernames to +be lowercased, or canonized in some other way. Should return the cleaned username. + +=item C + +Called by verify_token. Single argument is the username. May or may not be an +initial check to see if the username is ok. The username will already be cleaned at +this point. Default return is true. + +=item C + +Called by verify_token. Given the cleaned, verified username, should return a +valid password for the user. It can always return plaintext. If use_crypt is +enabled, it should return the crypted password. If use_plaintext and use_crypt +are not enabled, it may return the md5 sum of the password. =item C @@ -770,59 +1029,45 @@ A hash of passed form info. Defaults to CGI::Ex::get_form. 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 -=item C +Should return either a template filename to use for the login template, or it +should return a reference to a string that contains the template. The contents +will be used in login_print and passed to the template engine. -Calls the basic_login_template, swaps in the form variables (including -form name, login_script, etc). Then prints content_type, the content, and -returns. +Default login_template is the values of login_header, login_form, login_script, and +login_script concatenated together. -=item C +Values from login_hash_common will be passed to the template engine, and will +also be used to fill in the form. -Returns a bare essentials form that will handle the login. Has place -holders for all of the form name, and login variables, and errors and -login javascript. Variable place holders are of the form -[% login_script %] which should work with Template::Toolkit or CGI::Ex::swap_template. +The basic values are capable of handling most needs so long as appropriate +headers and css styles are used. -=item C +=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. +Should return a header to use in the default login_template. The default +value will try to PROCESS a file called login_header.tt that should be +located in directory specified by the template_include_path method. -SHA1 comparison will work with passwords stored as plaintext password, -or stored as the string "sha1(".sha1_hex($password).")". +It should ideally supply css styles that format the login_form as desired. -MD5 comparison will work with passwords stored as plaintext password, -or stored as the string "md5(".md5_hex($password).")". +=item C -Plaintext comparison will work with passwords stored as sha1(string), -md5(string), plaintext password string, or crypted password. +Same as login_header - but for the footer. Will look for login_footer.tt by +default. -=item C - -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 +=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. +An html chunk that contains the necessary form fields to login the user. The +basic chunk has a username text entry, password text entry, save password checkbox, +and submit button, and any hidden fields necessary for logging in the user. - my $login = $self->auth->auth_string_sha1($user, $pass, 1); - my $url = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?$login"; - -=head1 TODO +=item C -Using plaintext allows for the password to be passed in the querystring. -It should at least be Base64 encoded. I'll add that soon - BUT - really -you should be using the SHA1 or MD5 login types. +Contains javascript that will attach to the form from login_form. This script +is capable of taking the login_fields and creating an md5 cram which prevents +the password from being passed plaintext. =head1 AUTHORS diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index c1d256f..9bd3a00 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -1,15 +1,19 @@ package CGI::Ex::Conf; -### CGI Extended Conf Reader +=head1 NAME + +CGI::Ex::Conf - Conf Reader/Writer for many different data format types + +=cut ###----------------------------------------------------------------### -# Copyright 2004 - Paul Seamons # +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - use strict; +use base qw(Exporter); +use Carp qw(croak); use vars qw($VERSION @DEFAULT_PATHS $DEFAULT_EXT @@ -20,16 +24,18 @@ use vars qw($VERSION $IMMUTABLE_KEY %CACHE $HTML_KEY - $DEBUG_ON_FAIL + @EXPORT_OK ); -use CGI::Ex::Dump qw(debug dex_warn); +@EXPORT_OK = qw(conf_read conf_write); -$VERSION = '0.03'; +$VERSION = '2.00'; $DEFAULT_EXT = 'conf'; %EXT_READERS = ('' => \&read_handler_yaml, 'conf' => \&read_handler_yaml, + 'json' => \&read_handler_json, + 'val_json' => \&read_handler_json, 'ini' => \&read_handler_ini, 'pl' => \&read_handler_pl, 'sto' => \&read_handler_storable, @@ -45,6 +51,8 @@ $DEFAULT_EXT = 'conf'; %EXT_WRITERS = ('' => \&write_handler_yaml, 'conf' => \&write_handler_yaml, 'ini' => \&write_handler_ini, + 'json' => \&write_handler_json, + 'val_json' => \&write_handler_json, 'pl' => \&write_handler_pl, 'sto' => \&write_handler_storable, 'storable' => \&write_handler_storable, @@ -71,9 +79,9 @@ $IMMUTABLE_KEY = 'immutable'; sub new { my $class = shift || __PACKAGE__; - my $self = (@_ && ref($_[0])) ? shift : {@_}; + my $args = shift || {}; - return bless $self, $class; + return bless {%$args}, $class; } sub paths { @@ -83,8 +91,7 @@ sub paths { ###----------------------------------------------------------------### -sub read_ref { - my $self = shift; +sub conf_read { my $file = shift; my $args = shift || {}; my $ext; @@ -93,17 +100,21 @@ sub read_ref { if (ref $file) { if (UNIVERSAL::isa($file, 'SCALAR')) { if ($$file =~ /^\s*{no_cache}) { + return $CACHE{$file}; + ### if contains a newline - treat it as a YAML string } elsif (index($file,"\n") != -1) { - return &yaml_load($file); + return yaml_load($file); ### otherwise base it off of the file extension } elsif ($args->{file_type}) { @@ -112,36 +123,27 @@ sub read_ref { $ext = $1; } else { $ext = defined($args->{default_ext}) ? $args->{default_ext} - : defined($self->{default_ext}) ? $self->{default_ext} - : defined($DEFAULT_EXT) ? $DEFAULT_EXT : ''; + : defined($DEFAULT_EXT) ? $DEFAULT_EXT + : ''; $file = length($ext) ? "$file.$ext" : $file; } - ### allow for a pre-cached reference - if (exists $CACHE{$file} && ! $self->{no_cache}) { - return $CACHE{$file}; - } - ### determine the handler - my $handler; - if ($args->{handler}) { - $handler = (UNIVERSAL::isa($args->{handler},'CODE')) - ? $args->{handler} : $args->{handler}->{$ext}; - } elsif ($self->{handler}) { - $handler = (UNIVERSAL::isa($self->{handler},'CODE')) - ? $self->{handler} : $self->{handler}->{$ext}; - } - if (! $handler) { - $handler = $EXT_READERS{$ext} || die "Unknown file extension: $ext"; - } + my $handler = $EXT_READERS{$ext} || croak "Unknown file extension: $ext"; - return eval { scalar &$handler($file, $self, $args) } || do { - debug "Couldn't read $file: $@" if $DEBUG_ON_FAIL; - dex_warn "Couldn't read $file: $@" if ! $self->{no_warn_on_fail}; + return eval { scalar $handler->($file, $args) } || do { + warn "Couldn't read $file: $@ " if ! $args->{no_warn_on_fail}; return undef; }; } +sub read_ref { + my $self = shift; + my $file = shift; + my $args = shift || {}; + return conf_read($file, {%$self, %$args}); +} + ### allow for different kinds of merging of arguments ### allow for key fallback on hashes ### allow for immutable values on hashes @@ -169,7 +171,7 @@ sub read { $directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE); $namespace =~ s|::|/|g; # allow perlish style namespace my $paths = $args->{paths} || $self->paths - || die "No paths found during read on $namespace"; + || croak "No paths found during read on $namespace"; $paths = [$paths] if ! ref $paths; if ($directive eq 'LAST') { # LAST shall be FIRST $directive = 'FIRST'; @@ -183,9 +185,9 @@ sub read { ### make sure we have at least one path if ($#paths == -1) { - die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths"; + croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths"; } - + ### now loop looking for a ref foreach my $path (@paths) { my $ref = $self->read_ref($path, $args) || next; @@ -195,10 +197,10 @@ sub read { } elsif (UNIVERSAL::isa($ref, 'HASH')) { $REF = {}; } else { - die "Unknown config type of \"".ref($ref)."\" for namespace $namespace"; + croak "Unknown config type of \"".ref($ref)."\" for namespace $namespace"; } } elsif (! UNIVERSAL::isa($ref, ref($REF))) { - die "Found different reference types for namespace $namespace" + croak "Found different reference types for namespace $namespace" . " - wanted a type ".ref($REF); } if (ref($REF) eq 'ARRAY') { @@ -238,7 +240,7 @@ sub read { sub read_handler_ini { my $file = shift; require Config::IniHash; - return &Config::IniHash::ReadINI($file); + return Config::IniHash::ReadINI($file); } sub read_handler_pl { @@ -249,10 +251,19 @@ sub read_handler_pl { return ($#ref != 0) ? {@ref} : $ref[0]; } +sub read_handler_json { + my $file = shift; + local *IN; + open (IN, $file) || die "Couldn't open $file: $!"; + CORE::read(IN, my $text, -s $file); + close IN; + return scalar JSON::jsonToObj($text); +} + sub read_handler_storable { my $file = shift; require Storable; - return &Storable::retrieve($file); + return Storable::retrieve($file); } sub read_handler_yaml { @@ -261,13 +272,13 @@ sub read_handler_yaml { open (IN, $file) || die "Couldn't open $file: $!"; CORE::read(IN, my $text, -s $file); close IN; - return &yaml_load($text); + return yaml_load($text); } sub yaml_load { my $text = shift; require YAML; - my @ret = eval { &YAML::Load($text) }; + my @ret = eval { YAML::Load($text) }; if ($@) { die "$@"; } @@ -287,9 +298,8 @@ sub read_handler_xml { ### is specified sub read_handler_html { my $file = shift; - my $self = shift; my $args = shift; - if (! eval {require YAML}) { + if (! eval { require YAML }) { my $err = $@; my $found = 0; my $i = 0; @@ -305,14 +315,13 @@ sub read_handler_html { CORE::read(IN, my $html, -s $file); close IN; - return &html_parse_yaml_load($html, $self, $args); + return html_parse_yaml_load($html, $args); } sub html_parse_yaml_load { my $html = shift; - my $self = shift || {}; my $args = shift || {}; - my $key = $args->{html_key} || $self->{html_key} || $HTML_KEY; + my $key = $args->{html_key} || $HTML_KEY; return undef if ! $key || $key !~ /^\w+$/; my $str = ''; @@ -353,7 +362,7 @@ sub html_parse_yaml_load { if $str && $#order != -1 && $key eq 'validation'; return undef if ! $str; - my $ref = eval {&yaml_load($str)}; + my $ref = eval { yaml_load($str) }; if ($@) { my $err = "$@"; if ($err =~ /line:\s+(\d+)/) { @@ -364,7 +373,6 @@ sub html_parse_yaml_load { last; } } - debug $err; die $err; } return $ref; @@ -372,13 +380,68 @@ sub html_parse_yaml_load { ###----------------------------------------------------------------### +sub conf_write { + my $file = shift; + my $conf = shift || croak "Missing conf"; + my $args = shift || {}; + my $ext; + + if (ref $file) { + croak "Invalid filename for write: $file"; + + } elsif (index($file,"\n") != -1) { + croak "Cannot use a yaml string as a filename during write"; + + ### allow for a pre-cached reference + } elsif (exists $CACHE{$file} && ! $args->{no_cache}) { + warn "Cannot write back to a file that is in the cache"; + return 0; + + ### otherwise base it off of the file extension + } elsif ($args->{file_type}) { + $ext = $args->{file_type}; + } elsif ($file =~ /\.(\w+)$/) { + $ext = $1; + } else { + $ext = defined($args->{default_ext}) ? $args->{default_ext} + : defined($DEFAULT_EXT) ? $DEFAULT_EXT + : ''; + $file = length($ext) ? "$file.$ext" : $file; + } + + ### determine the handler + my $handler; + if ($args->{handler}) { + $handler = (UNIVERSAL::isa($args->{handler},'CODE')) + ? $args->{handler} : $args->{handler}->{$ext}; + } + if (! $handler) { + $handler = $EXT_WRITERS{$ext} || croak "Unknown file extension: $ext"; + } + + return eval { scalar $handler->($file, $conf, $args) } || do { + warn "Couldn't write $file: $@ " if ! $args->{no_warn_on_fail}; + return 0; + }; + + return 1; +} + +sub write_ref { + my $self = shift; + my $file = shift; + my $conf = shift; + my $args = shift || {}; + conf_write($file, $conf, {%$self, %$args}); +} + ### Allow for writing out conf values ### Allow for writing out the correct filename (if there is a path array) ### Allow for not writing out immutable values on hashes sub write { my $self = shift; my $namespace = shift; - my $conf = shift || die "Must pass hashref to write out"; # the info to write + my $conf = shift || croak "Must pass hashref to write out"; # the info to write my $args = shift || {}; my $IMMUTABLE = $args->{immutable} || {}; # can pass existing immutable types @@ -394,14 +457,14 @@ sub write { $directive = 'FIRST'; } elsif (index($namespace,"\n") != -1) { # yaml string - can't write that - die "Cannot use a yaml string as a namespace for write"; + croak "Cannot use a yaml string as a namespace for write"; ### use the default directories } else { $directive = uc($args->{directive} || $self->{directive} || $DIRECTIVE); $namespace =~ s|::|/|g; # allow perlish style namespace my $paths = $args->{paths} || $self->paths - || die "No paths found during write on $namespace"; + || croak "No paths found during write on $namespace"; $paths = [$paths] if ! ref $paths; if ($directive eq 'LAST') { # LAST shall be FIRST $directive = 'FIRST'; @@ -415,7 +478,7 @@ sub write { ### make sure we have at least one path if ($#paths == -1) { - die "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths"; + croak "Couldn't find a path for namespace $namespace. Perhaps you need to pass paths => \@paths"; } my $path; @@ -424,7 +487,7 @@ sub write { } elsif ($directive eq 'LAST' || $directive eq 'MERGE') { $path = $paths[-1]; } else { - die "Unknown directive ($directive) during write of $namespace"; + croak "Unknown directive ($directive) during write of $namespace"; } ### remove immutable items (if any) @@ -442,66 +505,13 @@ sub write { return 1; } -sub write_ref { - my $self = shift; - my $file = shift; - my $conf = shift || die "Missing conf"; - my $args = shift || {}; - my $ext; - - if (ref $file) { - die "Invalid filename for write: $file"; - - } elsif (index($file,"\n") != -1) { - die "Cannot use a yaml string as a filename during write"; - - ### otherwise base it off of the file extension - } elsif ($args->{file_type}) { - $ext = $args->{file_type}; - } elsif ($file =~ /\.(\w+)$/) { - $ext = $1; - } else { - $ext = defined($args->{default_ext}) ? $args->{default_ext} - : defined($self->{default_ext}) ? $self->{default_ext} - : defined($DEFAULT_EXT) ? $DEFAULT_EXT : ''; - $file = length($ext) ? "$file.$ext" : $file; - } - - ### allow for a pre-cached reference - if (exists $CACHE{$file} && ! $self->{no_cache}) { - warn "Cannot write back to a file that is in the cache"; - return 0; - } - - ### determine the handler - my $handler; - if ($args->{handler}) { - $handler = (UNIVERSAL::isa($args->{handler},'CODE')) - ? $args->{handler} : $args->{handler}->{$ext}; - } elsif ($self->{handler}) { - $handler = (UNIVERSAL::isa($self->{handler},'CODE')) - ? $self->{handler} : $self->{handler}->{$ext}; - } - if (! $handler) { - $handler = $EXT_WRITERS{$ext} || die "Unknown file extension: $ext"; - } - - return eval { scalar &$handler($file, $conf, $args) } || do { - debug "Couldn't write $file: $@" if $DEBUG_ON_FAIL; - dex_warn "Couldn't write $file: $@" if ! $self->{no_warn_on_fail}; - return 0; - }; - - return 1; -} - ###----------------------------------------------------------------### sub write_handler_ini { my $file = shift; my $ref = shift; require Config::IniHash; - return &Config::IniHash::WriteINI($file, $ref); + return Config::IniHash::WriteINI($file, $ref); } sub write_handler_pl { @@ -524,6 +534,17 @@ sub write_handler_pl { die "Ref to be written contained circular references - can't write"; } + local *OUT; + open (OUT, ">$file") || die $!; + print OUT $str; + close OUT; +} + +sub write_handler_json { + my $file = shift; + my $ref = shift; + require JSON; + my $str = JSON::objToJson($ref, {pretty => 1, indent => 2}); local *OUT; open (OUT, ">$file") || die $!; print OUT $str; @@ -534,14 +555,14 @@ sub write_handler_storable { my $file = shift; my $ref = shift; require Storable; - return &Storable::store($ref, $file); + return Storable::store($ref, $file); } sub write_handler_yaml { my $file = shift; my $ref = shift; require YAML; - &YAML::DumpFile($file, $ref); + return YAML::DumpFile($file, $ref); } sub write_handler_xml { @@ -580,7 +601,7 @@ sub preload_files { } } return if ! keys %EXT; - + ### look in the paths for the files foreach my $path (ref($paths) ? @$paths : $paths) { $path =~ s|//+|/|g; @@ -592,7 +613,7 @@ sub preload_files { $CACHE{$path} = $self->read($path); } elsif (-d _) { $CACHE{$path} = 1; - &File::Find::find(sub { + File::Find::find(sub { return if exists $CACHE{$File::Find::name}; return if $File::Find::name =~ m|/CVS/|; return if ! -f; @@ -612,10 +633,6 @@ sub preload_files { __END__ -=head1 NAME - -CGI::Ex::Conf - CGI Extended Conf Reader - =head1 SYNOPSIS my $cob = CGI::Ex::Conf->new; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index a3787af..d9cfdb1 100644 --- a/lib/CGI/Ex/Die.pm +++ b/lib/CGI/Ex/Die.pm @@ -1,5 +1,16 @@ package CGI::Ex::Die; +=head1 NAME + +CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility. + +=cut + +###----------------------------------------------------------------### +# Copyright 2006 - Paul Seamons # +# Distributed under the Perl Artistic License without warranty # +###----------------------------------------------------------------### + use strict; use vars qw($no_recurse $EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL @@ -151,10 +162,6 @@ sub die_handler { __END__ -=head1 NAME - -CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility. - =head1 SYNOPSIS use CGI::Ex::Die; diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index fd76291..c886324 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -1,21 +1,26 @@ package CGI::Ex::Dump; -### CGI Extended Data::Dumper Extension +=head1 NAME + +CGI::Ex::Dump - A debug utility + +=cut ###----------------------------------------------------------------### -# Copyright 2004 - Paul Seamons # +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - -use vars qw(@ISA @EXPORT @EXPORT_OK $ON $SUB $QR1 $QR2 $full_filename); +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION + $CALL_LEVEL + $ON $SUB $QR1 $QR2 $full_filename); use strict; use Exporter; +$VERSION = '2.00'; @ISA = qw(Exporter); @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace); -@EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug what_is_this); +@EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug); ### is on or off sub on { $ON = 1 }; @@ -50,11 +55,10 @@ BEGIN { ### same as dumper but with more descriptive output and auto-formatting ### for cgi output -sub what_is_this { +sub _what_is_this { return if ! $ON; ### figure out which sub we called - my ($pkg, $file, $line_n, $called) = caller(0); - ($pkg, $file, $line_n, $called) = caller(1) if $pkg eq __PACKAGE__; + my ($pkg, $file, $line_n, $called) = caller(1 + ($CALL_LEVEL || 0)); substr($called, 0, length(__PACKAGE__) + 2, ''); ### get the actual line @@ -92,27 +96,27 @@ sub what_is_this { elsif ($called eq 'dex_warn') { warn $txt } else { print $txt } } else { - my $html = "
$called: $file line $line_n\n";
+    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;
+      $dump[$_] =~ s|\$VAR1|$var[$_]|g;
       $html .= $dump[$_];
     }
     $html .= "
\n"; return $html if $called eq 'dex_html'; require CGI::Ex; - &CGI::Ex::print_content_type(); + CGI::Ex::print_content_type(); print $html; } } ### some aliases -sub debug { &what_is_this } -sub dex { &what_is_this } -sub dex_warn { &what_is_this } -sub dex_text { &what_is_this } -sub dex_html { &what_is_this } +sub debug { &_what_is_this } +sub dex { &_what_is_this } +sub dex_warn { &_what_is_this } +sub dex_text { &_what_is_this } +sub dex_html { &_what_is_this } sub _html_quote { my $value = shift; @@ -135,7 +139,7 @@ sub ctrace { my $max1 = 0; my $max2 = 0; my $max3 = 0; - while (my %i = &Carp::caller_info(++$i)) { + while (my %i = Carp::caller_info(++$i)) { $i{sub_name} =~ s/\((.*)\)$//; $i{args} = $i{has_args} ? $1 : ""; $i{sub_name} =~ s/^.*?([^:]+)$/$1/; @@ -153,7 +157,7 @@ sub ctrace { } sub dex_trace { - &what_is_this(ctrace(1)); + _what_is_this(ctrace(1)); } ###----------------------------------------------------------------### @@ -162,10 +166,6 @@ sub dex_trace { __END__ -=head1 NAME - -CGI::Ex::Dump - A debug utility - =head1 SYNOPSIS use CGI::Ex::Dump; # auto imports dex, dex_warn, dex_text and others diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index e1094ef..662c0d9 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -1,41 +1,46 @@ package CGI::Ex::Fill; -### CGI Extended Form Filler +=head1 NAME + +CGI::Ex::Fill - Fast but compliant regex based form filler + +=cut ###----------------------------------------------------------------### -# Copyright 2003 - Paul Seamons # +# Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - use strict; use vars qw($VERSION - @ISA @EXPORT @EXPORT_OK + @EXPORT @EXPORT_OK $REMOVE_SCRIPT $REMOVE_COMMENT $MARKER_SCRIPT $MARKER_COMMENT $OBJECT_METHOD - $TEMP_TARGET + $_TEMP_TARGET ); -use Exporter; +use base qw(Exporter); -$VERSION = '1.3'; -@ISA = qw(Exporter); -@EXPORT = qw(form_fill); -@EXPORT_OK = qw(form_fill html_escape get_tagval_by_key swap_tagval_by_key); +BEGIN { + $VERSION = '2.00'; + @EXPORT = qw(form_fill); + @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); +}; ### These directives are used to determine whether or not to ### remove html comments and script sections while filling in ### a form. Default is on. This may give some trouble if you ### have a javascript section with form elements that you would ### like filled in. -$REMOVE_SCRIPT = 1; -$REMOVE_COMMENT = 1; -$MARKER_SCRIPT = "\0SCRIPT\0"; -$MARKER_COMMENT = "\0COMMENT\0"; -$OBJECT_METHOD = "param"; +BEGIN { + $REMOVE_SCRIPT = 1; + $REMOVE_COMMENT = 1; + $MARKER_SCRIPT = "\0SCRIPT\0"; + $MARKER_COMMENT = "\0COMMENT\0"; + $OBJECT_METHOD = "param"; +}; ###----------------------------------------------------------------### @@ -47,339 +52,366 @@ $OBJECT_METHOD = "param"; ### pos4 - boolean fill in password fields - default is true ### pos5 - hashref or arrayref of fields to ignore sub form_fill { - my $text = shift; - my $ref = ref($text) ? $text : \$text; - my $form = shift; - my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form]; - my $target = shift; - my $fill_password = shift; - my $ignore = shift || {}; - $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY'); - $fill_password = 1 if ! defined $fill_password; - - - ### allow for optionally removing comments and script - my @comment; - my @script; - if ($REMOVE_SCRIPT) { - $$ref =~ s|()|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; + my $text = shift; + my $ref = ref($text) ? $text : \$text; + my $form = shift; + my $target = shift; + my $fill_password = shift; + my $ignore = shift || {}; + + fill({ + text => $ref, + form => $form, + target => $target, + fill_password => $fill_password, + ignore_fields => $ignore, + }); - ### put scripts and comments back and return - $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1; - $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1; return ref($text) ? 1 : $$ref; - } +} - ### build a sub to get a value - my %indexes = (); # store indexes for multivalued elements - my $get_form_value = sub { - my $key = shift; - my $all = $_[0] && $_[0] eq 'all'; - if (! defined $key || ! length $key) { - return $all ? [] : undef; - } +sub fill { + my $args = shift; + my $ref = $args->{'text'}; + my $form = $args->{'form'}; + my $target = $args->{'target'}; + my $ignore = $args->{'ignore_fields'}; + my $fill_password = $args->{'fill_password'}; + + my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form]; + $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY'); + $fill_password = 1 if ! defined $fill_password; - my $val; - my $meth; - foreach my $form (@$forms) { - next if ! ref $form; - if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) { - $val = $form->{$key}; - last; - } elsif ($meth = UNIVERSAL::can($form, $OBJECT_METHOD)) { - $val = $form->$meth($key); - last if defined $val; - } elsif (UNIVERSAL::isa($form, 'CODE')) { - $val = &{ $form }($key, $TEMP_TARGET); - last if defined $val; - } - } - if (! defined $val) { - return $all ? [] : undef; - } - ### fix up the value some - if (UNIVERSAL::isa($val, 'CODE')) { - $val = &{ $val }($key, $TEMP_TARGET); + ### allow for optionally removing comments and script + my @comment; + my @script; + if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) { + $$ref =~ s|()|push(@script, $1);$MARKER_SCRIPT|egi; } - if (UNIVERSAL::isa($val, 'ARRAY')) { - $val = [@$val]; # copy the values - } elsif (ref $val) { - # die "Value for $key is not an array or a scalar"; - $val = "$val"; # stringify anything else + if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) { + $$ref =~ s|()|push(@comment, $1);$MARKER_COMMENT|eg; } - ### html escape them all - &html_escape(\$_) foreach (ref($val) ? @$val : $val); - - ### allow for returning all elements - ### or one at a time - if ($all) { - return ref($val) ? $val : [$val]; - } elsif (ref($val)) { - $indexes{$key} ||= 0; - my $ret = $val->[$indexes{$key}] || ''; - $indexes{$key} ++; # don't wrap - if we run out of values - we're done - return $ret; - } else { - return $val; + ### if there is a target - focus in on it + ### possible bug here - name won't be found if + ### there is nested html inside the form tag that comes before + ### the name field - if no close form tag - don't swap in anything + if ($target) { + local $_TEMP_TARGET = $target; + $$ref =~ s{(
]+ # some space + \bname=([\"\']?) # the name tag + $target # with the correct name (allows for regex) + \2 # closing quote + .+? # as much as there is + (?=
)) # then end + }{ + my $str = $1; + local $args->{'text'} = \$str; + local $args->{'remove_script'} = 0; + local $args->{'remove_comment'} = 0; + local $args->{'target'} = undef; + fill($args); + $str; # return of the s///; + }sigex; + + ### put scripts and comments back and return + $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1; + $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1; + return 1; } - }; - - - ###--------------------------------------------------------------### - - ### First pass - ### swap 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; - } - } + + ### build a sub to get a value from the passed forms on a request basis + my %indexes = (); # store indexes for multivalued elements + my $get_form_value = sub { + my $key = shift; + my $all = $_[0] && $_[0] eq 'all'; + if (! defined $key || ! length $key) { + return $all ? [] : undef; + } + + my $val; + my $meth; + foreach my $form (@$forms) { + next if ! ref $form; + if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) { + $val = $form->{$key}; + last; + } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) { + $val = $form->$meth($key); + last if defined $val; + } elsif (UNIVERSAL::isa($form, 'CODE')) { + $val = $form->($key, $_TEMP_TARGET); + last if defined $val; } - } } - } - $tag; # return of swap - }sigex; - - - ### Second pass - ### swap select boxes (must be done in such a way as to allow no closing tag) - my @start = (); - my @close = (); - push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig; - push @close, pos($$ref) - length($1) while $$ref =~ m|( $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{ - ( form elements if they have a name + $$ref =~ s{ + (] )* >) # nested html ok }{ - my ($tag2, $opt) = ($1, $2); - $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig; - - my $fvalues = &get_tagval_by_key(\$tag2, 'value', 'all'); - my $fvalue = @$fvalues ? $fvalues->[0] - : $opt =~ /^\s*(.*?)\s*$/ ? $1 : ""; - foreach (@$values) { - next if $_ ne $fvalue; - $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|; - last; - } - "$tag2$opt"; # return of the swap + ### get the type and name - intentionally exlude names with nested "' + my $tag = $1; + my $type = uc(get_tagval_by_key(\$tag, 'type') || ''); + my $name = get_tagval_by_key(\$tag, 'name'); + + if ($name && ! $ignore->{$name}) { + if (! $type + || $type eq 'HIDDEN' + || $type eq 'TEXT' + || $type eq 'FILE' + || ($type eq 'PASSWORD' && $fill_password)) { + + my $value = $get_form_value->($name, 'next'); + if (defined $value) { + swap_tagval_by_key(\$tag, 'value', $value); + } elsif (! defined get_tagval_by_key(\$tag, 'value')) { + swap_tagval_by_key(\$tag, 'value', ''); + } + + } elsif ($type eq 'CHECKBOX' + || $type eq 'RADIO') { + my $values = $get_form_value->($name, 'all'); + if (@$values) { + $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig; + + my $fvalue = get_tagval_by_key(\$tag, 'value'); + $fvalue = 'on' if ! defined $fvalue; + if (defined $fvalue) { + foreach (@$values) { + next if $_ ne $fvalue; + $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|; + last; + } + } + } + } + + } + $tag; # return of swap }sigex; - if ($n) { - substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts"); - } + + + ### Second pass + ### swap select boxes (must be done in such a way as to allow no closing tag) + my @start = (); + my @close = (); + push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig; + push @close, pos($$ref) - length($1) while $$ref =~ m|( $start[$i + 1]) { + $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select + } } - } - - - ### Third pass - ### swap textareas (must be done in such a way as to allow no closing tag) - @start = (); - @close = (); - push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig; - push @close, pos($$ref) - length($1) while $$ref =~ m|(= 0; $i --) { + my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]); + $opts =~ s{ + ( + + +
+
+ + + +
+
+ + + + + +}; + +my $form = { + foo => "bar", + pass => "word", + garbage => ['can','lid'], + Mighty => 'ducks', +}; + + +my $fif = HTML::FillInForm->new; +my $fo = CGI::Ex->new; +$fo->{remove_comments} = 1; + +my $x = $fo->fill(scalarref => \$t, + fdat => $form, + target => 'foo', + ); +#print $x; +#exit; + +cmpthese(-2, { + hfif => sub { + my $copy = $t; + my $new = $fif->fill(scalarref => \$copy, + fdat => $form, + target => 'foo', + ); + }, + cgix_meth => sub { + my $copy = $t; + $fo->fill(scalarref => \$copy, + fdat => $form, + target => 'foo', + ); + }, + cgix_func => sub { + my $copy = $t; + &CGI::Ex::Fill::form_fill(\$copy, $form, 'foo'); + }, +}); diff --git a/samples/benchmark/bench_conf_readers.pl b/samples/benchmark/bench_conf_readers.pl new file mode 100644 index 0000000..20f1b45 --- /dev/null +++ b/samples/benchmark/bench_conf_readers.pl @@ -0,0 +1,419 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw($PLACEHOLDER); +use Benchmark qw(cmpthese); +use CGI::Ex::Conf; +use POSIX qw(tmpnam); + +$PLACEHOLDER = chr(186).'~'.chr(186); + +my $n = -2; + +my $cob = CGI::Ex::Conf->new; +my %files = (); + +###----------------------------------------------------------------### + +# Rate yaml2 yaml xml ini g_conf pl sto sto2 yaml3 +#yaml2 159/s -- -1% -72% -80% -91% -95% -98% -98% -100% +#yaml 160/s 1% -- -72% -80% -91% -95% -98% -98% -100% +#xml 565/s 255% 253% -- -28% -68% -84% -93% -94% -100% +#ini 785/s 393% 391% 39% -- -55% -78% -90% -91% -99% +#g_conf 1756/s 1004% 998% 211% 124% -- -50% -78% -80% -98% +#pl 3524/s 2115% 2103% 524% 349% 101% -- -55% -61% -97% +#sto 7838/s 4826% 4799% 1288% 898% 346% 122% -- -12% -93% +#sto2 8924/s 5508% 5477% 1480% 1037% 408% 153% 14% -- -92% +#yaml3 113328/s 71115% 70730% 19961% 14336% 6353% 3116% 1346% 1170% -- #memory + +my $str = '{ + foo => {key1 => "bar", key2 => "ralph"}, + pass => {key1 => "word", key2 => "ralph"}, + garbage => {key1 => "can", key2 => "ralph"}, + mighty => {key1 => "ducks", key2 => "ralph"}, + quack => {key1 => "moo", key2 => "ralph"}, + one1 => {key1 => "val1", key2 => "ralph"}, + one2 => {key1 => "val2", key2 => "ralph"}, + one3 => {key1 => "val3", key2 => "ralph"}, + one4 => {key1 => "val4", key2 => "ralph"}, + one5 => {key1 => "val5", key2 => "ralph"}, + one6 => {key1 => "val6", key2 => "ralph"}, + one7 => {key1 => "val7", key2 => "ralph"}, + one8 => {key1 => "val8", key2 => "ralph"}, +}'; + +###----------------------------------------------------------------### + +# Rate yaml yaml2 xml g_conf pl sto sto2 yaml3 +#yaml 431/s -- -2% -61% -91% -94% -97% -98% -100% +#yaml2 438/s 2% -- -60% -91% -94% -97% -98% -100% +#xml 1099/s 155% 151% -- -78% -85% -92% -94% -99% +#g_conf 4990/s 1057% 1038% 354% -- -33% -64% -72% -96% +#pl 7492/s 1637% 1609% 582% 50% -- -46% -58% -93% +#sto 13937/s 3130% 3078% 1169% 179% 86% -- -22% -88% +#sto2 17925/s 4055% 3988% 1532% 259% 139% 29% -- -84% +#yaml3 114429/s 26423% 25996% 10316% 2193% 1427% 721% 538% -- # memory + +#$str = '{ +# foo => "bar", +# pass => "word", +# garbage => "can", +# mighty => "ducks", +# quack => "moo", +# one1 => "val1", +# one2 => "val2", +# one3 => "val3", +# one4 => "val4", +# one5 => "val5", +# one6 => "val6", +# one7 => "val7", +# one8 => "val8", +#}'; + +###----------------------------------------------------------------### + +my $conf = eval $str; + +my %TESTS = (); + +### do perl +my $file = tmpnam(). '.pl'; +open OUT, ">$file"; +print OUT $str; +close OUT; +$TESTS{pl} = sub { + my $hash = $cob->read_ref($file); +}; +$files{pl} = $file; + +### do a generic conf_write +my $file2 = tmpnam(). '.g_conf'; +&generic_conf_write($file2, $conf); +local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read; +$TESTS{g_conf} = sub { + my $hash = $cob->read_ref($file2); +}; +$files{g_conf} = $file2; + + +if (eval {require JSON}) { + my $_file = tmpnam(). '.json'; + my $str = JSON::objToJson($conf, {pretty => 1, indent => 2}); + open(my $fh, ">$_file"); + print $fh $str; + $TESTS{json} = sub { + my $hash = $cob->read_ref($_file); + }; + $TESTS{json2} = sub { + open(my $fh, "<$_file") || die "Couldn't open file: $!"; + read($fh, my $str, -s $_file); + my $hash = JSON::jsonToObj($str); + }; + $files{json} = $_file; +} + + +### load in the rest of the tests that we support +if (eval {require Storable}) { + my $_file = tmpnam(). '.sto'; + &Storable::store($conf, $_file); + $TESTS{sto} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{sto} = $_file; +} + +if (eval {require Storable}) { + my $_file = tmpnam(). '.sto2'; + &Storable::store($conf, $_file); + $TESTS{sto2} = sub { + my $hash = &Storable::retrieve($_file); + }; + $files{sto2} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml'; + &YAML::DumpFile($_file, $conf); + $TESTS{yaml} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{yaml} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml2'; + &YAML::DumpFile($_file, $conf); + $TESTS{yaml2} = sub { + my $hash = &YAML::LoadFile($_file); + }; + $files{yaml2} = $_file; +} + +if (eval {require YAML}) { + my $_file = tmpnam(). '.yaml'; + &YAML::DumpFile($_file, $conf); + $cob->preload_files($_file); + $TESTS{yaml3} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{yaml3} = $_file; +} + +if (eval {require Config::IniHash}) { + my $_file = tmpnam(). '.ini'; + &Config::IniHash::WriteINI($_file, $conf); + $TESTS{ini} = sub { + local $^W = 0; + my $hash = $cob->read_ref($_file); + }; + $files{ini} = $_file; +} + +if (eval {require XML::Simple}) { + my $_file = tmpnam(). '.xml'; + my $xml = XML::Simple->new->XMLout($conf); + open OUT, ">$_file" || die $!; + print OUT $xml; + close OUT; + $TESTS{xml} = sub { + my $hash = $cob->read_ref($_file); + }; + $files{xml} = $_file; +} + +### tell file locations +foreach my $key (sort keys %files) { + print "$key => $files{$key}\n"; +} + +cmpthese($n, \%TESTS); + +### comment out this line to inspect files +unlink $_ foreach values %files; + +###----------------------------------------------------------------### + +sub generic_conf_read { + my $_file = shift || die "No filename supplied"; + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### fh will now lose scope and close itself if necessary + my $FH = do { local *FH; *FH }; + open ($FH, $_file) || return {}; + + my $x = 0; + my $conf = {}; + my $key = ''; + my $val; + my $line; + my ($is_array,$is_hash,$is_multiline); + my $order; + $order = [] if wantarray; + + while( defined($line = <$FH>) ){ + last if ! defined $line; + last if $x++ > 10000; + + next if index($line,'#') == 0; + + if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){ + next if ! length($key); + $conf->{$key} .= $line; + $is_multiline = 1; + + }else{ + ### duplicate trim section + if( length($key) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + ($key,$val) = split(/\s+/,$line,2); + $is_array = 0; + $is_hash = 0; + $is_multiline = 0; + if (! length($key)) { + next; + } elsif (index($key,'array:') == 0) { + $is_array = $key =~ s/^array://i; + } elsif (index($key,'hash:') == 0) { + $is_hash = $key =~ s/^hash://i; + } + $key =~ y/+/ / if ! $sep_by_newlines; + $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + $conf->{$key} = $val; + push @$order, $key if $order; + } + } + + ### duplicate trim section + if( length($key) && defined($conf->{$key}) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + + close($FH); + return $order ? ($conf,$order) : $conf; +} + + +sub generic_conf_write{ + my $_file = shift || die "No filename supplied"; + + if (! @_) { + return; + } + + my $new_conf = shift || die "Missing update hashref"; + return if ! keys %$new_conf; + + + ### do we allow writing out hashes in a nice way + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### touch the file if necessary + if( ! -e $_file ){ + open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!"; + close(TOUCH); + } + + ### read old values + my $conf = &generic_conf_read($_file) || {}; + my $key; + my $val; + + ### remove duplicates and undefs + while (($key,$val) = each %$new_conf){ + $conf->{$key} = $new_conf->{$key}; + } + + ### prepare output + my $output = ''; + my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/; + foreach $key (sort keys %$conf){ + next if ! defined $conf->{$key}; + $val = delete $conf->{$key}; + $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg; + $key =~ tr/\ /+/; + my $ref = ref($val); + if( $ref ){ + if( $ref eq 'HASH' ){ + $output .= "hash:$key\n"; + foreach my $_key (sort keys %$val){ + my $_val = $val->{$_key}; + next if ! defined $_val; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/\ /%20/g; + } else { + $_val =~ tr/\ /+/; + $_key =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_key\t$_val\n"; + } + }elsif( $ref eq 'ARRAY' ){ + $output .= "array:$key\n"; + foreach (@$val){ + my $_val = $_; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + } else { + $_val =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_val\n"; + } + }else{ + $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref + } + }else{ + if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding + if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){ + if ($sep_by_newlines) { + $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg; + } else { + $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ y/ /+/; + } + } + }else{ + $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg; + $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg; + } + $output .= "$key\t$val\n"; + } + } + + open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]"; + print CONF $output; + truncate CONF, length($output); + close CONF; + + return 1; +} + +1; + diff --git a/samples/benchmark/bench_conf_writers.pl b/samples/benchmark/bench_conf_writers.pl new file mode 100644 index 0000000..37b1070 --- /dev/null +++ b/samples/benchmark/bench_conf_writers.pl @@ -0,0 +1,398 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw($PLACEHOLDER); +use Benchmark qw(cmpthese timethese); +use CGI::Ex::Conf; +use POSIX qw(tmpnam); + +$PLACEHOLDER = chr(186).'~'.chr(186); + +my $n = -2; + +my $cob = CGI::Ex::Conf->new; +my %files = (); + +###----------------------------------------------------------------### + +# Rate yaml yaml2 sto pl xml g_conf ini sto2 +#yaml 250/s -- -1% -14% -14% -61% -77% -95% -95% +#yaml2 254/s 1% -- -13% -13% -60% -77% -95% -95% +#sto 292/s 17% 15% -- -0% -54% -73% -94% -95% +#pl 292/s 17% 15% 0% -- -54% -73% -94% -95% +#xml 636/s 155% 151% 118% 118% -- -42% -88% -88% +#g_conf 1088/s 335% 329% 273% 272% 71% -- -79% -80% +#ini 5144/s 1958% 1929% 1662% 1660% 708% 373% -- -3% +#sto2 5321/s 2029% 1999% 1723% 1721% 736% 389% 3% -- + +my $str = { + foo => {key1 => "bar", key2 => "ralph"}, + pass => {key1 => "word", key2 => "ralph"}, + garbage => {key1 => "can", key2 => "ralph"}, + mighty => {key1 => "ducks", key2 => "ralph"}, + quack => {key1 => "moo", key2 => "ralph"}, + one1 => {key1 => "val1", key2 => "ralph"}, + one2 => {key1 => "val2", key2 => "ralph"}, + one3 => {key1 => "val3", key2 => "ralph"}, + one4 => {key1 => "val4", key2 => "ralph"}, + one5 => {key1 => "val5", key2 => "ralph"}, + one6 => {key1 => "val6", key2 => "ralph"}, + one7 => {key1 => "val7", key2 => "ralph"}, + one8 => {key1 => "val8", key2 => "ralph"}, +}; + +###----------------------------------------------------------------### + +# Rate yaml yaml2 pl sto xml g_conf sto2 +#yaml 736/s -- -3% -20% -21% -62% -72% -89% +#yaml2 755/s 3% -- -18% -19% -61% -71% -89% +#pl 923/s 25% 22% -- -1% -53% -65% -86% +#sto 928/s 26% 23% 1% -- -53% -65% -86% +#xml 1961/s 166% 160% 113% 111% -- -26% -71% +#g_conf 2635/s 258% 249% 185% 184% 34% -- -61% +#sto2 6824/s 827% 803% 639% 635% 248% 159% -- + +#$str = { +# foo => "bar", +# pass => "word", +# garbage => "can", +# mighty => "ducks", +# quack => "moo", +# one1 => "val1", +# one2 => "val2", +# one3 => "val3", +# one4 => "val4", +# one5 => "val5", +# one6 => "val6", +# one7 => "val7", +# one8 => "val8", +#}; + +###----------------------------------------------------------------### + +my $conf = eval $str; + +my %TESTS = (); + +### do perl +my $dir = tmpnam; +mkdir $dir, 0755; +my $tmpnam = "$dir/bench"; +my $file = $tmpnam. '.pl'; +$TESTS{pl} = sub { + $cob->write_ref($file, $str); +}; +$files{pl} = $file; + +### do a generic conf_write +my $file2 = $tmpnam. '.g_conf'; +local $CGI::Ex::Conf::EXT_WRITERS{g_conf} = \&generic_conf_write; +$TESTS{g_conf} = sub { + $cob->write_ref($file2, $str); +}; +$files{g_conf} = $file2; + + +### load in the rest of the tests that we support +if (eval {require JSON}) { + my $_file = tmpnam(). '.json'; + $TESTS{json} = sub { + $cob->write_ref($file, $str); + }; + $files{json} = $_file; +} + +if (eval {require Storable}) { + my $_file = $tmpnam. '.sto'; + $TESTS{sto} = sub { + $cob->write_ref($file, $str); + }; + $files{sto} = $_file; +} + +if (eval {require Storable}) { + my $_file = $tmpnam. '.sto2'; + $TESTS{sto2} = sub { + &Storable::store($str, $_file); + }; + $files{sto2} = $_file; +} + +if (eval {require YAML}) { + my $_file = $tmpnam. '.yaml'; + $TESTS{yaml} = sub { + $cob->write_ref($_file, $str); + }; + $files{yaml} = $_file; +} + +if (eval {require YAML}) { + my $_file = $tmpnam. '.yaml2'; + $TESTS{yaml2} = sub { + &YAML::DumpFile($_file, $str); + }; + $files{yaml2} = $_file; +} + +if (eval {require Config::IniHash}) { + my $_file = $tmpnam. '.ini'; + $TESTS{ini} = sub { + local $^W = 0; + $cob->write_ref($_file, $str); + }; + $files{ini} = $_file; +} + +if (eval {require XML::Simple}) { + my $_file = $tmpnam. '.xml'; + $TESTS{xml} = sub { + $cob->write_ref($_file, $str); + }; + $files{xml} = $_file; +} + +### tell file locations +foreach my $key (sort keys %files) { + print "$key => $files{$key}\n"; +} + +foreach my $key (keys %TESTS) { + eval { &{ $TESTS{$key} } }; + if ($@) { + warn "Test for $key failed - skipping"; + delete $TESTS{$key}; + } +} + + +cmpthese timethese ($n, \%TESTS); + +### comment out this line to inspect files +unlink $_ foreach values %files; +rmdir $dir; + +###----------------------------------------------------------------### + +sub generic_conf_read { + my $_file = shift || die "No filename supplied"; + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### fh will now lose scope and close itself if necessary + my $FH = do { local *FH; *FH }; + open ($FH, $_file) || return {}; + + my $x = 0; + my $conf = {}; + my $key = ''; + my $val; + my $line; + my ($is_array,$is_hash,$is_multiline); + my $order; + $order = [] if wantarray; + + while( defined($line = <$FH>) ){ + last if ! defined $line; + last if $x++ > 10000; + + next if index($line,'#') == 0; + + if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){ + next if ! length($key); + $conf->{$key} .= $line; + $is_multiline = 1; + + }else{ + ### duplicate trim section + if( length($key) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + ($key,$val) = split(/\s+/,$line,2); + $is_array = 0; + $is_hash = 0; + $is_multiline = 0; + if (! length($key)) { + next; + } elsif (index($key,'array:') == 0) { + $is_array = $key =~ s/^array://i; + } elsif (index($key,'hash:') == 0) { + $is_hash = $key =~ s/^hash://i; + } + $key =~ y/+/ / if ! $sep_by_newlines; + $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + $conf->{$key} = $val; + push @$order, $key if $order; + } + } + + ### duplicate trim section + if( length($key) && defined($conf->{$key}) ){ + $conf->{$key} =~ s/\s+$//; + if( $is_array || $is_hash ){ + $conf->{$key} =~ s/^\s+//; + my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1); + my @pieces; + if ($sep_by_newlines) { + @pieces = split(/\s*\n\s*/,$conf->{$key}); + @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash; + } else { + @pieces = split(/\s+/,$conf->{$key}); + } + if( $urldec ){ + foreach my $_val (@pieces){ + $_val =~ y/+/ / if ! $sep_by_newlines; + $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + if( $is_array ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + $conf->{$key} = \@pieces; + }elsif( $is_hash ){ + foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 } + shift(@pieces) if scalar(@pieces) % 2; + $conf->{$key} = {@pieces}; + } + }elsif( ! $is_multiline ){ + $conf->{$key} =~ y/+/ / if ! $sep_by_newlines; + $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi; + } + } + + + close($FH); + return $order ? ($conf,$order) : $conf; +} + + +sub generic_conf_write{ + my $_file = shift || die "No filename supplied"; + + if (! @_) { + return; + } + + my $new_conf = shift || die "Missing update hashref"; + return if ! keys %$new_conf; + + + ### do we allow writing out hashes in a nice way + my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0; + + ### touch the file if necessary + if( ! -e $_file ){ + open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!"; + close(TOUCH); + } + + ### read old values + my $conf = &generic_conf_read($_file) || {}; + my $key; + my $val; + + ### remove duplicates and undefs + while (($key,$val) = each %$new_conf){ + $conf->{$key} = $new_conf->{$key}; + } + + ### prepare output + my $output = ''; + my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/; + foreach $key (sort keys %$conf){ + next if ! defined $conf->{$key}; + $val = delete $conf->{$key}; + $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg; + $key =~ tr/\ /+/; + my $ref = ref($val); + if( $ref ){ + if( $ref eq 'HASH' ){ + $output .= "hash:$key\n"; + foreach my $_key (sort keys %$val){ + my $_val = $val->{$_key}; + next if ! defined $_val; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + $_key =~ s/\ /%20/g; + } else { + $_val =~ tr/\ /+/; + $_key =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_key\t$_val\n"; + } + }elsif( $ref eq 'ARRAY' ){ + $output .= "array:$key\n"; + foreach (@$val){ + my $_val = $_; + $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego; + if ($sep_by_newlines) { + $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego; + $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego; + } else { + $_val =~ tr/\ /+/; + } + $_val = $PLACEHOLDER if ! length($_val); + $output .= "\t$_val\n"; + } + }else{ + $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref + } + }else{ + if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding + if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){ + if ($sep_by_newlines) { + $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg; + } else { + $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ y/ /+/; + } + } + }else{ + $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg; + $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg; + $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg; + } + $output .= "$key\t$val\n"; + } + } + + open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]"; + print CONF $output; + truncate CONF, length($output); + close CONF; + + return 1; +} + +1; + diff --git a/samples/benchmark/bench_method_calling.pl b/samples/benchmark/bench_method_calling.pl new file mode 100755 index 0000000..a65afbc --- /dev/null +++ b/samples/benchmark/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/samples/benchmark/bench_optree.pl b/samples/benchmark/bench_optree.pl new file mode 100644 index 0000000..f255ffa --- /dev/null +++ b/samples/benchmark/bench_optree.pl @@ -0,0 +1,671 @@ +#!/usr/bin/perl -w + +=head1 NAME + +bench_optree.pl - Look at different ways of storing data that transform fast. + +=cut + +use strict; +use Benchmark qw(cmpthese timethese); +use CGI::Ex::Dump qw(debug); +use constant skip_execute => 1; + +#my $obj = bless [1, 2], __PACKAGE__; +#my $struct1 = \ [ '-', 1, 2 ]; +#my $struct2 = ['-', 1, 2]; +# +#sub call { $_[0]->[0] - $_[0]->[1] } +# +#sub obj_meth { $obj->call } +#sub ref_type { if (ref($struct1) eq 'REF') { if (${$struct1}->[0] eq '-') { ${$struct1}->[1] - ${$struct1}->[2] } } } +# +#print "(".obj_meth().")\n"; +#print "(".ref_type().")\n"; +#cmpthese timethese(-2, { +# obj_meth => \&obj_meth, +# ref_type => \&ref_type, +#}, 'auto'); + + +###----------------------------------------------------------------### +### setup a new way of storing and executing the variable tree + +sub get_var2 { ref($_[1]) ? $_[1]->call($_[0]) : $_[1] } + +{ + package Num; + sub new { my $c = shift; bless \@_, $c }; + sub call { $_[0]->[0] } + package A::B; + sub new { my $c = shift; bless \@_, $c } +# sub new { my $c = shift; bless [map{ref$_?$_:Num->new($_)} @_], $c } + package A::B::Minus; + our @ISA = qw(A::B); + sub call { $_[1]->get_var2($_[0]->[0]) - $_[1]->get_var2($_[0]->[1]) } + package A::B::Plus; + our @ISA = qw(A::B); + sub call { $_[1]->get_var2($_[0]->[0]) + $_[1]->get_var2($_[0]->[1]) } + package A::B::Mult; + our @ISA = qw(A::B); + sub call { $_[1]->get_var2($_[0]->[0]) * $_[1]->get_var2($_[0]->[1]) } + package A::B::Div; + our @ISA = qw(A::B); + sub call { $_[1]->get_var2($_[0]->[0]) / $_[1]->get_var2($_[0]->[1]) } + package A::B::Var; + our @ISA = qw(A::B); +use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC); +BEGIN { + $HASH_OPS = $CGI::Ex::Template::HASH_OPS; + $LIST_OPS = $CGI::Ex::Template::LIST_OPS; + $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; + $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; + $OP_FUNC = $CGI::Ex::Template::OP_FUNC; +} +use constant trace => 0; +sub call { + my $var = shift; + my $self = shift; + my $ARGS = shift || {}; + my $i = 0; + my $generated_list; + + ### determine the top level of this particular variable access + my $ref = $var->[$i++]; + my $args = $var->[$i++]; + warn "get_variable: begin \"$ref\"\n" if trace; + + if (defined $ref) { + if ($ARGS->{'is_namespace_during_compile'}) { + $ref = $self->{'NAMESPACE'}->{$ref}; + } else { + return if $ref =~ /^[_.]/; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$ref}; + } + } + + my %seen_filters; + while (defined $ref) { + + ### check at each point if the returned thing was a code + if (UNIVERSAL::isa($ref, 'CODE')) { + my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); + if (defined $results[0]) { + $ref = ($#results > 0) ? \@results : $results[0]; + } elsif (defined $results[1]) { + die $results[1]; # TT behavior - why not just throw ? + } else { + $ref = undef; + last; + } + } + + ### descend one chained level + last if $i >= $#$var; + my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; + my $name = $var->[$i++]; + my $args = $var->[$i++]; + warn "get_variable: nested \"$name\"\n" if trace; + + ### allow for named portions of a variable name (foo.$name.bar) + if (ref $name) { + $name = $name->call($self); + if (! defined($name) || $name =~ /^[_.]/) { + $ref = undef; + last; + } + } + + if ($name =~ /^_/) { # don't allow vars that begin with _ + $ref = undef; + last; + } + + ### allow for scalar and filter access (this happens for every non virtual method call) + if (! ref $ref) { + if ($SCALAR_OPS->{$name}) { # normal scalar op + $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + + } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op + $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); + + } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args + || $FILTER_OPS->{$name} # predefined filters in CET + || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash + || $self->list_filters->{$name}) { # filter defined in Template::Filters + + if (UNIVERSAL::isa($filter, 'CODE')) { + $ref = eval { $filter->($ref) }; # non-dynamic filter - no args + if (my $err = $@) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { + $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); + + } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters + eval { + my $sub = $filter->[0]; + if ($filter->[1]) { # it is a "dynamic filter" that will return a sub + ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); + if (! $sub && $err) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } elsif (! UNIVERSAL::isa($sub, 'CODE')) { + $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") + if ref($sub) !~ /Template::Exception$/; + die $sub; + } + } + $ref = $sub->($ref); + }; + if (my $err = $@) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) + $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; + $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree + $i = 2; + } + if (scalar keys %seen_filters + && $seen_filters{$var->[$i - 5] || ''}) { + $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); + } + } else { + $ref = undef; + } + + } else { + + ### method calls on objects + if (UNIVERSAL::can($ref, 'can')) { + my @args = $args ? @{ $self->vivify_args($args) } : (); + my @results = eval { $ref->$name(@args) }; + if ($@) { + die $@ if ref $@ || $@ !~ /Can\'t locate object method/; + } elsif (defined $results[0]) { + $ref = ($#results > 0) ? \@results : $results[0]; + next; + } elsif (defined $results[1]) { + die $results[1]; # TT behavior - why not just throw ? + } else { + $ref = undef; + last; + } + # didn't find a method by that name - so fail down to hash and array access + } + + ### hash member access + if (UNIVERSAL::isa($ref, 'HASH')) { + if ($was_dot_call && exists($ref->{$name}) ) { + $ref = $ref->{$name}; + } elsif ($HASH_OPS->{$name}) { + $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + } elsif ($ARGS->{'is_namespace_during_compile'}) { + return $var; # abort - can't fold namespace variable + } else { + $ref = undef; + } + + ### array access + } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { + if ($name =~ /^\d+$/) { + $ref = ($name > $#$ref) ? undef : $ref->[$name]; + } else { + $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + } + } + } + + } # end of while + + ### allow for undefinedness + if (! defined $ref) { + if ($self->{'_debug_undef'}) { + my $chunk = $var->[$i - 2]; + $chunk = $chunk->call($self) if ref $chunk; + die "$chunk is undefined\n"; + } else { + $ref = $self->undefined_any($var); + } + } + + ### allow for special behavior for the '..' operator + if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { + return @$ref; + } + + return $ref; +} +}; +sub plus ($$) { A::B::Plus->new( @_) } +sub minus ($$) { A::B::Minus->new(@_) } +sub mult ($$) { A::B::Mult->new( @_) } +sub div ($$) { A::B::Div->new( @_) } +sub var { A::B::Var->new( @_) }; +$INC{'A/B.pm'} = 1; +$INC{'A/B/Plus.pm'} = 1; +$INC{'A/B/Minus.pm'} = 1; +$INC{'A/B/Mult.pm'} = 1; +$INC{'A/B/Div.pm'} = 1; +$INC{'A/B/Var.pm'} = 1; + +###----------------------------------------------------------------### +### now benchmark the different variable storage methods + +my $vars = { + foo => {bar => {baz => [qw(a b c)]}}, + bing => 'bang', +}; +my $self = bless {'_vars' => $vars}, __PACKAGE__; + +#pauls@pslaptop:~/perl/CGI-Ex/lib$ perl -e 'my $a = "1 + 2 * (3 + (4 / 5) * 9) - 20"; +# use CGI::Ex::Template; +# use Data::Dumper; +# print Dumper(CGI::Ex::Template->new->parse_variable(\$a));' + +###----------------------------------------------------------------### + +my $Y0 = '$self->{_vars}->{bing}'; +my $Y1 = [ 'bing', 0 ]; +my $Y2 = var('bing', 0); +debug $Y2; + +### are they all the same +print eval($Y0)."\n"; +print $self->get_variable($Y1)."\n"; +print $self->get_var2($Y2)."\n"; + +if (! skip_execute) { + cmpthese timethese (-2, { + perl => sub { eval $Y0 }, + bare_data => sub { $self->get_variable($Y1) }, + method_call => sub { $self->get_var2($Y2) }, + }, 'auto'); +} + +###----------------------------------------------------------------### + +my $Z0 = '$self->{_vars}->{foo}->{bar}->{baz}->[1]'; +my $Z1 = [ 'foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0]; +my $Z2 = var('foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0); +debug $Z2; + +### are they all the same +print eval($Z0)."\n"; +print $self->get_variable($Z1)."\n"; +print $self->get_var2($Z2)."\n"; + +if (! skip_execute) { + cmpthese timethese (-2, { + perl => sub { eval $Z0 }, + bare_data => sub { $self->get_variable($Z1) }, + method_call => sub { $self->get_var2($Z2) }, + }, 'auto'); +} + +###----------------------------------------------------------------### + +### $A0 = perl, $A1 = old optree, $A2 = new optree +my $A0 = "1 + 2 * (3 + (4 / 5) * 9) - 20"; +my $A1 = [ \[ '-', [ \[ '+', '1', [ \[ '*', '2', [ \[ '+', '3', [ \[ '*', [ \[ '/', '4', '5' ], 0 ], '9' ], 0 ] ], 0 ] ], 0 ] ], 0 ], '20' ], 0 ]; +my $A2 = minus(plus(1, mult(2, plus(3, mult(div(4,5), 9)))), 20); +debug $A2; + +### are they all the same +print eval($A0)."\n"; +print $self->get_variable($A1)."\n"; +print $self->get_var2($A2)."\n"; + +if (! skip_execute) { + cmpthese timethese (-2, { + perl => sub { eval $A0 }, + bare_data => sub { $self->get_variable($A1) }, + method_call => sub { $self->get_var2($A2) }, + }, 'auto'); +} + +###----------------------------------------------------------------### + +my $B0 = "1 + 2"; +my $B1 = [ \[ '+', 1, 2] ]; +my $B2 = plus(1, 2); +debug $B2; + +### are they all the same +print eval($B0)."\n"; +print $self->get_variable($B1)."\n"; +print $self->get_var2($B2)."\n"; + +if (! skip_execute) { + cmpthese timethese (-2, { + perl => sub { eval $B0 }, + bare_data => sub { $self->get_variable($B1) }, + method_call => sub { $self->get_var2($B2) }, + }, 'auto'); +} + +###----------------------------------------------------------------### +### Test (de)serialization speed + +use Storable; +my $d1 = Storable::freeze($A1); +my $d2 = Storable::freeze($A2); +Storable::thaw($d1); # load lib +print length($d1)."\n"; +print length($d2)."\n"; + +cmpthese timethese (-2, { + freeze_bare => sub { Storable::freeze($A1) }, + freeze_meth => sub { Storable::freeze($A2) }, +}, 'auto'); + +cmpthese timethese (-2, { + thaw_bare => sub { Storable::thaw($d1) }, + thaw_meth => sub { Storable::thaw($d2) }, +}, 'auto'); + +###----------------------------------------------------------------### +### create libraries similar to those from CGI::Ex::Template 1.201 + +use CGI::Ex::Template; +use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC); +BEGIN { + $HASH_OPS = $CGI::Ex::Template::HASH_OPS; + $LIST_OPS = $CGI::Ex::Template::LIST_OPS; + $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; + $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; + $OP_FUNC = $CGI::Ex::Template::OP_FUNC; +} +use constant trace => 0; + +sub get_variable { + ### allow for the parse tree to store literals + return $_[1] if ! ref $_[1]; + + my $self = shift; + my $var = shift; + my $ARGS = shift || {}; + my $i = 0; + my $generated_list; + + ### determine the top level of this particular variable access + my $ref = $var->[$i++]; + my $args = $var->[$i++]; + warn "get_variable: begin \"$ref\"\n" if trace; + if (ref $ref) { + if (ref($ref) eq 'SCALAR') { # a scalar literal + $ref = $$ref; + } elsif (ref($ref) eq 'REF') { # operator + return $self->play_operator($$ref) if ${ $ref }->[0] eq '\\'; # return the closure + $generated_list = 1 if ${ $ref }->[0] eq '..'; + $ref = $self->play_operator($$ref); + } else { # a named variable access (ie via $name.foo) + $ref = $self->get_variable($ref); + if (defined $ref) { + return if $ref =~ /^[_.]/; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$ref}; + } + } + } elsif (defined $ref) { + if ($ARGS->{'is_namespace_during_compile'}) { + $ref = $self->{'NAMESPACE'}->{$ref}; + } else { + return if $ref =~ /^[_.]/; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$ref}; + } + } + + + my %seen_filters; + while (defined $ref) { + + ### check at each point if the returned thing was a code + if (UNIVERSAL::isa($ref, 'CODE')) { + my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); + if (defined $results[0]) { + $ref = ($#results > 0) ? \@results : $results[0]; + } elsif (defined $results[1]) { + die $results[1]; # TT behavior - why not just throw ? + } else { + $ref = undef; + last; + } + } + + ### descend one chained level + last if $i >= $#$var; + my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; + my $name = $var->[$i++]; + my $args = $var->[$i++]; + warn "get_variable: nested \"$name\"\n" if trace; + + ### allow for named portions of a variable name (foo.$name.bar) + if (ref $name) { + if (ref($name) eq 'ARRAY') { + $name = $self->get_variable($name); + if (! defined($name) || $name =~ /^[_.]/) { + $ref = undef; + last; + } + } else { + die "Shouldn't get a ". ref($name) ." during a vivify on chain"; + } + } + if ($name =~ /^_/) { # don't allow vars that begin with _ + $ref = undef; + last; + } + + ### allow for scalar and filter access (this happens for every non virtual method call) + if (! ref $ref) { + if ($SCALAR_OPS->{$name}) { # normal scalar op + $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + + } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op + $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); + + } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args + || $FILTER_OPS->{$name} # predefined filters in CET + || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash + || $self->list_filters->{$name}) { # filter defined in Template::Filters + + if (UNIVERSAL::isa($filter, 'CODE')) { + $ref = eval { $filter->($ref) }; # non-dynamic filter - no args + if (my $err = $@) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { + $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); + + } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters + eval { + my $sub = $filter->[0]; + if ($filter->[1]) { # it is a "dynamic filter" that will return a sub + ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); + if (! $sub && $err) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } elsif (! UNIVERSAL::isa($sub, 'CODE')) { + $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") + if ref($sub) !~ /Template::Exception$/; + die $sub; + } + } + $ref = $sub->($ref); + }; + if (my $err = $@) { + $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) + $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; + $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree + $i = 2; + } + if (scalar keys %seen_filters + && $seen_filters{$var->[$i - 5] || ''}) { + $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); + } + } else { + $ref = undef; + } + + } else { + + ### method calls on objects + if (UNIVERSAL::can($ref, 'can')) { + my @args = $args ? @{ $self->vivify_args($args) } : (); + my @results = eval { $ref->$name(@args) }; + if ($@) { + die $@ if ref $@ || $@ !~ /Can\'t locate object method/; + } elsif (defined $results[0]) { + $ref = ($#results > 0) ? \@results : $results[0]; + next; + } elsif (defined $results[1]) { + die $results[1]; # TT behavior - why not just throw ? + } else { + $ref = undef; + last; + } + # didn't find a method by that name - so fail down to hash and array access + } + + ### hash member access + if (UNIVERSAL::isa($ref, 'HASH')) { + if ($was_dot_call && exists($ref->{$name}) ) { + $ref = $ref->{$name}; + } elsif ($HASH_OPS->{$name}) { + $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + } elsif ($ARGS->{'is_namespace_during_compile'}) { + return $var; # abort - can't fold namespace variable + } else { + $ref = undef; + } + + ### array access + } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { + if ($name =~ /^\d+$/) { + $ref = ($name > $#$ref) ? undef : $ref->[$name]; + } else { + $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + } + } + } + + } # end of while + + ### allow for undefinedness + if (! defined $ref) { + if ($self->{'_debug_undef'}) { + my $chunk = $var->[$i - 2]; + $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY'; + die "$chunk is undefined\n"; + } else { + $ref = $self->undefined_any($var); + } + } + + ### allow for special behavior for the '..' operator + if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { + return @$ref; + } + + return $ref; +} + +sub vivify_args { + my $self = shift; + my $vars = shift; + my $args = shift || {}; + return [map {$self->get_variable($_, $args)} @$vars]; +} + +sub play_operator { + my $self = shift; + my $tree = shift; + my $ARGS = shift || {}; + my $op = $tree->[0]; + $tree = [@$tree[1..$#$tree]]; + + ### allow for operator function override + if (exists $OP_FUNC->{$op}) { + return $OP_FUNC->{$op}->($self, $op, $tree, $ARGS); + } + + ### do constructors and short-circuitable operators + if ($op eq '~' || $op eq '_') { + return join "", grep {defined} @{ $self->vivify_args($tree) }; + } elsif ($op eq 'arrayref') { + return $self->vivify_args($tree, {list_context => 1}); + } elsif ($op eq 'hashref') { + my $args = $self->vivify_args($tree); + push @$args, undef if ! ($#$args % 2); + return {@$args}; + } elsif ($op eq '?') { + if ($self->get_variable($tree->[0])) { + return defined($tree->[1]) ? $self->get_variable($tree->[1]) : undef; + } else { + return defined($tree->[2]) ? $self->get_variable($tree->[2]) : undef; + } + } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { + for my $node (@$tree) { + my $var = $self->get_variable($node); + return $var if $var; + } + return ''; + } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { + my $var; + for my $node (@$tree) { + $var = $self->get_variable($node); + return 0 if ! $var; + } + return $var; + + } elsif ($op eq '!') { + my $var = ! $self->get_variable($tree->[0]); + return defined($var) ? $var : ''; + + } + + ### equality operators + local $^W = 0; + my $n = $self->get_variable($tree->[0]); + $tree = [@$tree[1..$#$tree]]; + if ($op eq '==') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } + elsif ($op eq '!=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } + elsif ($op eq 'eq') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } + elsif ($op eq 'ne') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } + elsif ($op eq '<') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n < $_); $n = $_ }; return 1 } + elsif ($op eq '>') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n > $_); $n = $_ }; return 1 } + elsif ($op eq '<=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n <= $_); $n = $_ }; return 1 } + elsif ($op eq '>=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n >= $_); $n = $_ }; return 1 } + elsif ($op eq 'lt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n lt $_); $n = $_ }; return 1 } + elsif ($op eq 'gt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n gt $_); $n = $_ }; return 1 } + elsif ($op eq 'le') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n le $_); $n = $_ }; return 1 } + elsif ($op eq 'ge') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ge $_); $n = $_ }; return 1 } + + ### numeric operators + my $args = $self->vivify_args($tree); + if (! @$args) { + if ($op eq '-') { return - $n } + $self->throw('operator', "Not enough args for operator \"$op\""); + } + if ($op eq '..') { return [($n || 0) .. ($args->[-1] || 0)] } + elsif ($op eq '+') { $n += $_ for @$args; return $n } + elsif ($op eq '-') { $n -= $_ for @$args; return $n } + elsif ($op eq '*') { $n *= $_ for @$args; return $n } + elsif ($op eq '/') { $n /= $_ for @$args; return $n } + elsif ($op eq 'div' + || $op eq 'DIV') { $n = int($n / $_) for @$args; return $n } + elsif ($op eq '%' + || $op eq 'mod' + || $op eq 'MOD') { $n %= $_ for @$args; return $n } + elsif ($op eq '**' + || $op eq 'pow') { $n **= $_ for @$args; return $n } + + $self->throw('operator', "Un-implemented operation $op"); +} + diff --git a/samples/benchmark/bench_template.pl b/samples/benchmark/bench_template.pl new file mode 100644 index 0000000..450078b --- /dev/null +++ b/samples/benchmark/bench_template.pl @@ -0,0 +1,382 @@ +#!/usr/bin/perl -w + +=head1 NAME + +bench_template.pl - Test relative performance of CGI::Ex::Template to Template::Toolkit + +=cut + +use strict; +use Benchmark qw(cmpthese timethese); +use POSIX qw(tmpnam); +use File::Path qw(rmtree); +use CGI::Ex::Template; +use CGI::Ex::Dump qw(debug); +use Template; +use constant test_taint => 0 && eval { require Taint::Runtime }; # s/0/1/ to check tainting + +Taint::Runtime::taint_start() if test_taint; + +my $tt_cache_dir = tmpnam; +END { rmtree $tt_cache_dir }; +mkdir $tt_cache_dir, 0755; + +my $swap = { + one => "ONE", + a_var => "a", + foo => '[% bar %]', + bar => "baz", + hash => {a => 1, b => 2, c => { d => [{hee => ["hmm"]}] }}, + array => [qw(A B C D E a A)], + code => sub {"(@_)"}, + filt => sub {sub {$_[0]x2}}, +}; + +use Template::Stash;; +my $s = Template::Stash->new($swap); +#use Template::Stash::XS; +#$s = Template::Stash::XS->new($swap); + +###----------------------------------------------------------------### +### get objects ready + +my @config1 = (STASH => $s, ABSOLUTE => 1, CONSTANTS => {simple => 'var'}, EVAL_PERL => 1, INCLUDE_PATH => $tt_cache_dir); +#push @config1, (INTERPOLATE => 1); +my @config2 = (@config1, COMPILE_EXT => '.ttc'); + +#use CGI::Ex::Template209; +#my $tt1 = CGI::Ex::Template209->new(@config1); +my $tt1 = Template->new(@config1); +my $tt2 = Template->new(@config2); + +my $cet = CGI::Ex::Template->new(@config1); +my $cetc = CGI::Ex::Template->new(@config2); + +#$swap->{$_} = $_ for (1 .. 1000); # swap size affects benchmark speed + +###----------------------------------------------------------------### +### write out some file to be used later + +my $fh; +my $bar_template = "$tt_cache_dir/bar.tt"; +END { unlink $bar_template }; +open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; +print $fh "BAR"; +close $fh; + +my $baz_template = "$tt_cache_dir/baz.tt"; +END { unlink $baz_template }; +open($fh, ">$baz_template") || die "Couldn't open $baz_template: $!"; +print $fh "[% SET baz = 42 %][% baz %][% bing %]"; +close $fh; + +my $longer_template = "[% INCLUDE bar.tt %]" + ."[% array.join('|') %]" + .("123"x200) + ."[% FOREACH a IN array %]foobar[% IF a == 'A' %][% INCLUDE baz.tt %][% END %]bazbing[% END %]" + .("456"x200) + ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" + .("789"x200) + ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" + .("012"x200) + ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" + ."[% array.join('|') %]" + ."[% PROCESS bar.tt %]"; + +###----------------------------------------------------------------### +### set a few globals that will be available in our subs +my $show_list = grep {$_ eq '--list'} @ARGV; +my $run_all = grep {$_ eq '--all'} @ARGV; +my @run = $run_all ? () : @ARGV; +my $str_ref; +my $filename; + +### uncomment to run a specific test - otherwise all tests run +#@run = qw(07); + +# ### All percents are CGI::Ex::Template vs TT2 +# ### (The percent that CET is faster than TT) +# Existing object by string ref # +# New object with CACHE_EXT set # # +# New object each time (undef CACHE_SIZE) # # # +# This percent is compiled in memory (repeated calls) # # # # +my $tests = { # # # # # + '01_empty' => "", # 231% # 571% # 310% # 431% # 20798.0/s # + '02_var_sma' => "[% one %]", # 162% # 531% # 409% # 436% # 14964.9/s # + '03_var_lar' => "[% one %]"x100, # 22% # 338% # 63% # 331% # 948.8/s # + '04_set_sma' => "[% SET one = 2 %]", # 160% # 478% # 391% # 370% # 14835.7/s # + '05_set_lar' => "[% SET one = 2 %]"x100, # 12% # 280% # 28% # 272% # 919.7/s # + '06_set_range' => "[% SET one = [0..30] %]", # 42% # 289% # 230% # 192% # 7909.3/s # + '07_chain_sm' => "[% hash.a %]", # 163% # 551% # 397% # 450% # 13791.3/s # + '08_mixed_sma' => "".((" "x100)."[% one %]\n")x10, # 72% # 467% # 234% # 440% # 5941.1/s # + '09_mixed_med' => "".((" "x10)."[% one %]\n")x100, # 17% # 416% # 99% # 394% # 879.7/s # + '10_str_sma' => "".("[% \"".(" "x100)."\$one\" %]\n")x10, # -12% # 1391% # 96% # 1448% # 2939.5/s # + '11_str_lar' => "".("[% \"".(" "x10)."\$one\" %]\n")x100, # -50% # 303% # -1% # 303% # 365.3/s # + '12_num_lterl' => "[% 2 %]", # 170% # 534% # 430% # 422% # 16592.1/s # + '13_plus' => "[% 1 + 2 %]", # 116% # 426% # 351% # 311% # 13151.4/s # + '14_chained' => "[% c.d.0.hee.0 %]", # 168% # 567% # 390% # 486% # 14451.2/s # + '15_chain_set' => "[% SET c.d.0.hee.0 = 2 %]", # 153% # 465% # 337% # 389% # 11123.9/s # + '16_chain_lar' => "[% c.d.0.hee.0 %]"x100, # 58% # 468% # 74% # 465% # 828.2/s # + '17_chain_sl' => "[% SET c.d.0.hee.0 = 2 %]"x100, # 111% # 343% # 85% # 346% # 367.4/s # + '18_cplx_comp' => "[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]", # 81% # 254% # 253% # 188% # 9677.4/s # + '19_if_sim_t' => "[% a=1 %][% IF a %]Two[% END %]", # 119% # 428% # 316% # 352% # 11600.5/s # + '20_if_sim_f' => " [% IF a %]Two[% END %]", # 163% # 536% # 398% # 459% # 14693.3/s # + '21_if_else' => "[% IF a %]A[% ELSE %]B[% END %]", # 139% # 483% # 363% # 393% # 13480.3/s # + '22_if_elsif' => "[% IF a %]A[% ELSIF b %]B[% ELSE %]C[% END %]", # 133% # 453% # 334% # 379% # 12151.0/s # + '23_for_i_sml' => "[% FOREACH i = [0..10] ; i ; END %]", # 12% # 197% # 131% # 140% # 2497.6/s # + '24_for_i_med' => "[% FOREACH i = [0..100] ; i ; END %]", # -23% # 21% # 0% # 5% # 357.3/s # + '25_for_sml' => "[% FOREACH [0..10] ; i ; END %]", # 23% # 220% # 151% # 160% # 2670.6/s # + '26_for_med' => "[% FOREACH [0..100] ; i ; END %]", # -5% # 41% # 19% # 24% # 404.5/s # + '27_while' => "[% f = 10 %][%WHILE f%][%f=f- 1%][%f%][% END %]", # 0% # 161% # 65% # 120% # 1604.2/s # + '28_whl_set_l' => "[% f = 10; WHILE (g=f) ; f = f - 1 ; f ; END %]", # -3% # 128% # 50% # 91% # 1285.6/s # + '29_whl_set_s' => "[% f = 1; WHILE (g=f) ; f = f - 1 ; f ; END %]", # 51% # 287% # 196% # 227% # 5914.2/s # + '30_file_proc' => "[% PROCESS bar.tt %]", # 231% # 492% # 370% # 468% # 10900.5/s # + '31_file_incl' => "[% INCLUDE baz.tt %]", # 150% # 403% # 278% # 335% # 6915.6/s # + '32_process' => "[% BLOCK foo %]Hi[% END %][% PROCESS foo %]", # 159% # 519% # 396% # 463% # 10647.0/s # + '33_include' => "[% BLOCK foo %]Hi[% END %][% INCLUDE foo %]", # 137% # 491% # 367% # 424% # 9087.9/s # + '34_macro' => "[% MACRO foo BLOCK %]Hi[% END %][% foo %]", # 76% # 364% # 276% # 285% # 7838.4/s # + '35_macro_arg' => "[% MACRO foo(n) BLOCK %]Hi[%n%][%END%][%foo(2)%]", # 64% # 263% # 251% # 200% # 6532.9/s # + '36_macro_pro' => "[% MACRO foo PROCESS bar;BLOCK bar%]7[%END;foo%]", # 95% # 393% # 300% # 333% # 6369.2/s # + '37_filter2' => "[% n = 1 %][% n | repeat(2) %]", # 129% # 394% # 342% # 313% # 10703.2/s # + '38_filter' => "[% n = 1 %][% n FILTER repeat(2) %]", # 90% # 322% # 286% # 245% # 8865.2/s # + '39_fltr_name' => "[% n=1; n FILTER echo=repeat(2); n FILTER echo%]", # 36% # 284% # 211% # 229% # 5824.9/s # + '40_constant' => "[% constants.simple %]", # 174% # 515% # 435% # 425% # 16588.0/s # + '41_perl' => "[%one='ONE'%][% PERL %]print \"[%one%]\"[%END%]", # 62% # 403% # 278% # 332% # 6885.4/s # + '42_filtervar' => "[% 'hi' | \$filt %]", # 95% # 454% # 328% # 370% # 10167.3/s # + '43_filteruri' => "[% ' ' | uri %]", # 132% # 550% # 379% # 471% # 12524.4/s # + '44_filterevl' => "[% foo | eval %]", # 303% # 530% # 434% # 478% # 5475.5/s # + '45_capture' => "[% foo = BLOCK %]Hi[% END %][% foo %]", # 102% # 386% # 291% # 304% # 10606.5/s # + '46_complex' => "$longer_template", # 55% # 288% # 133% # 251% # 1230.3/s # + # overall # 95% # 406% # 251% # 346% # + + + # With Stash::XS + #'46_complex' => "$longer_template", # -4% # 274% # 93% # 228% # 1201.9/s # + ## overall # 30% # 377% # 211% # 317% # +}; + +### load the code representation +my $text = {}; +seek DATA, 0, 0; +my $data = do { local $/ = undef; }; +foreach my $key (keys %$tests) { + $data =~ m/(.*\Q$key\E.*)/ || next; + $text->{$key} = $1; +} + +if ($show_list) { + foreach my $text (sort values %$text) { + print "$text\n"; + } + exit; +} + +my $run = join("|", @run); +@run = grep {/$run/} sort keys %$tests; + +###----------------------------------------------------------------### + +sub file_TT_new { + my $out = ''; + my $t = Template->new(@config1); + $t->process($filename, $swap, \$out); + return $out; +} + +sub str_TT_new { + my $out = ''; + my $t = Template->new(@config1); + $t->process($str_ref, $swap, \$out); + return $out; +} + +sub file_TT { + my $out = ''; + $tt1->process($filename, $swap, \$out); + return $out; +} + +sub str_TT { + my $out = ''; + $tt1->process($str_ref, $swap, \$out) || debug $tt1->error; + return $out; +} + +sub file_TT_cache_new { + my $out = ''; + my $t = Template->new(@config2); + $t->process($filename, $swap, \$out); + return $out; +} + +###----------------------------------------------------------------### + +sub file_CET_new { + my $out = ''; + my $t = CGI::Ex::Template->new(@config1); + $t->process($filename, $swap, \$out); + return $out; +} + +sub str_CET_new { + my $out = ''; + my $t = CGI::Ex::Template->new(@config1); + $t->process($str_ref, $swap, \$out); + return $out; +} + +sub file_CET { + my $out = ''; + $cet->process($filename, $swap, \$out); + return $out; +} + +sub str_CET { + my $out = ''; + $cet->process($str_ref, $swap, \$out); + return $out; +} + +sub str_CET_swap { + my $txt = $cet->swap($str_ref, $swap); + return $txt; +} + +sub file_CET_cache_new { + my $out = ''; + my $t = CGI::Ex::Template->new(@config2); + $t->process($filename, $swap, \$out); + return $out; +} + +###----------------------------------------------------------------### + +@run = sort(keys %$tests) if $#run == -1; + +my $output = ''; +my %cumulative; +foreach my $test_name (@run) { + die "Invalid test $test_name" if ! exists $tests->{$test_name}; + my $txt = $tests->{$test_name}; + my $sample =$text->{$test_name}; + $sample =~ s/^.+=>//; + $sample =~ s/\#.+$//; + print "-------------------------------------------------------------\n"; + print "Running test $test_name\n"; + print "Test text: $sample\n"; + + ### set the global file types + $str_ref = \$txt; + $filename = $tt_cache_dir ."/$test_name.tt"; + open(my $fh, ">$filename") || die "Couldn't open $filename: $!"; + print $fh $txt; + close $fh; + + #debug file_CET(), str_TT(); + #debug $cet->parse_tree($file); + + ### check out put - and also allow for caching + for (1..2) { + if (file_CET() ne str_TT()) { + debug $cet->parse_tree($str_ref); + debug file_CET(), str_TT(); + die "file_CET didn't match"; + } + die "file_TT didn't match " if file_TT() ne str_TT(); + die "str_CET didn't match " if str_CET() ne str_TT(); +# die "str_CET_swap didn't match " if str_CET_swap() ne str_TT(); + die "file_CET_cache_new didn't match " if file_CET_cache_new() ne str_TT(); + die "file_TT_cache_new didn't match " if file_TT_cache_new() ne str_TT(); + } + + next if test_taint; + +###----------------------------------------------------------------### + + my $r = eval { timethese (-2, { + file_TT_n => \&file_TT_new, +# str_TT_n => \&str_TT_new, + file_TT => \&file_TT, + str_TT => \&str_TT, + file_TT_c_n => \&file_TT_cache_new, + + file_CT_n => \&file_CET_new, +# str_CT_n => \&str_CET_new, + file_CT => \&file_CET, + str_CT => \&str_CET, +# str_CT_sw => \&str_CET_swap, + file_CT_c_n => \&file_CET_cache_new, + }) }; + if (! $r) { + debug "$@"; + next; + } + eval { cmpthese $r }; + + my $copy = $text->{$test_name}; + $copy =~ s/\#.+//; + $output .= $copy; + + eval { + my $hash = { + '1 cached_in_memory ' => ['file_CT', 'file_TT'], + '2 new_object ' => ['file_CT_n', 'file_TT_n'], + '3 cached_on_file (new_object)' => ['file_CT_c_n', 'file_TT_c_n'], + '4 string reference ' => ['str_CT', 'str_TT'], + '5 CT new vs TT in mem ' => ['file_CT_n', 'file_TT'], + '6 CT in mem vs TT new ' => ['file_CT', 'file_TT_n'], + '7 CT in mem vs CT new ' => ['file_CT', 'file_CT_n'], + '8 TT in mem vs TT new ' => ['file_TT', 'file_TT_n'], + }; + foreach my $type (sort keys %$hash) { + my ($key1, $key2) = @{ $hash->{$type} }; + my $ct = $r->{$key1}; + my $tt = $r->{$key2}; + my $ct_s = $ct->iters / ($ct->cpu_a || 1); + my $tt_s = $tt->iters / ($tt->cpu_a || 1); + my $p = int(100 * ($ct_s - $tt_s) / ($tt_s || 1)); + print "$type - CT is $p% faster than TT\n"; + + $output .= sprintf('# %3s%% ', $p) if $type =~ /^[1234]/; + + ### store cumulatives + if (abs($p) < 10000) { + $cumulative{$type} ||= [0, 0]; + $cumulative{$type}->[0] += $p; + $cumulative{$type}->[1] ++; + } + } + }; + debug "$@" + if $@; + + $output .= "# ".sprintf("%.1f", $r->{'file_CT'}->iters / ($r->{'file_CT'}->cpu_a || 1))."/s #\n"; +# $output .= "#\n"; + + foreach my $row (values %cumulative) { + $row->[2] = sprintf('%.1f', $row->[0] / ($row->[1]||1)); + } + + if ($#run > 0) { + foreach (sort keys %cumulative) { + printf "Cumulative $_: %6.1f\n", $cumulative{$_}->[2]; + } + } + +} + +### add the final total row +if ($#run > 0) { + $output .= " # overall" . (" "x61); + foreach my $type (sort keys %cumulative) { + $output .= sprintf('# %3s%% ', int $cumulative{$type}->[2]) if $type =~ /^[1234]/; + } + $output .= "#\n"; + + print $output; +} + + + +#print `ls -lR $tt_cache_dir`; +__DATA__ diff --git a/samples/benchmark/bench_template_tag_parser.pl b/samples/benchmark/bench_template_tag_parser.pl new file mode 100644 index 0000000..68aa14c --- /dev/null +++ b/samples/benchmark/bench_template_tag_parser.pl @@ -0,0 +1,187 @@ +#!/usr/bin/perl -w + +use strict; +use Benchmark qw(timethese cmpthese countit timestr); +use IO::Socket; + +my $str = "--[% one %][% two %]--\n"; +# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... +# grammar: 4 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 36585.78/s (n=74635) +# index: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 81146.23/s (n=172030) +# index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 71674.76/s (n=150517) +# match: 4 wallclock secs ( 2.12 usr + 0.01 sys = 2.13 CPU) @ 57690.14/s (n=122880) +# split: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 36230.58/s (n=74635) +# Rate split grammar match index2 index +# split 36231/s -- -1% -37% -49% -55% +# grammar 36586/s 1% -- -37% -49% -55% +# match 57690/s 59% 58% -- -20% -29% +# index2 71675/s 98% 96% 24% -- -12% +# index 81146/s 124% 122% 41% 13% -- + +#my $str = ((" "x1000)."[% one %]\n")x10; +# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... +# grammar: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 689.52/s (n=1448) +# index: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 10239.52/s (n=21503) +# index2: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 10095.31/s (n=21503) +# match: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 6727.23/s (n=14329) +# split: 4 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 5023.83/s (n=10751) +# Rate grammar split match index2 index +# grammar 690/s -- -86% -90% -93% -93% +# split 5024/s 629% -- -25% -50% -51% +# match 6727/s 876% 34% -- -33% -34% +# index2 10095/s 1364% 101% 50% -- -1% +# index 10240/s 1385% 104% 52% 1% -- + +#my $str = ((" "x10)."[% one %]\n")x1000; +# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... +# grammar: 3 wallclock secs ( 2.10 usr + 0.01 sys = 2.11 CPU) @ 81.52/s (n=172) +# index: 4 wallclock secs ( 2.11 usr + 0.01 sys = 2.12 CPU) @ 207.55/s (n=440) +# index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 209.52/s (n=440) +# match: 3 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 173.43/s (n=359) +# split: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 91.98/s (n=195) +# Rate grammar split match index index2 +# grammar 81.5/s -- -11% -53% -61% -61% +# split 92.0/s 13% -- -47% -56% -56% +# match 173/s 113% 89% -- -16% -17% +# index 208/s 155% 126% 20% -- -1% +# index2 210/s 157% 128% 21% 1% -- + +###----------------------------------------------------------------### + +### use a regular expression to go through the string +sub parse_match { + my $new = ''; + my $START = quotemeta '[%'; + my $END = quotemeta '%]'; + + my $pos; + local pos($_[0]) = 0; + while ($_[0] =~ / \G (.*?) $START (.*?) $END /gsx) { + my ($begin, $tag) = ($1, $2); + $pos = pos($_[0]); + $new .= $begin; + $new .= "($tag)"; + } + return $pos ? $new . substr($_[0], $pos) : $_[0]; +} + +### good ole index - hard coded +sub parse_index { + my $new = ''; + + my $last = 0; + while (1) { + my $i = index($_[0], '[%', $last); + last if $i == -1; + $new .= substr($_[0], $last, $i - $last), + my $j = index($_[0], '%]', $i + 2); + die "Unclosed tag" if $j == -1; + my $tag = substr($_[0], $i + 2, $j - ($i + 2)); + $new .= "($tag)"; + $last = $j + 2; + } + return $last ? $new . substr($_[0], $last) : $_[0]; +} + +### index searching - but configurable +sub parse_index2 { + my $new = ''; + my $START = '[%'; + my $END = '%]'; + my $len_s = length $START; + my $len_e = length $END; + + my $last = 0; + while (1) { + my $i = index($_[0], $START, $last); + last if $i == -1; + $new .= substr($_[0], $last, $i - $last), + my $j = index($_[0], $END, $i + $len_s); + $last = $j + $len_e; + if ($j == -1) { # missing closing tag + $last = length($_[0]); + last; + } + my $tag = substr($_[0], $i + $len_s, $j - ($i + $len_s)); + $new .= "($tag)"; + } + return $last ? $new . substr($_[0], $last) : $_[0]; +} + +### using a split method (several other split methods were also tried - but were slower) +sub parse_split { + my $new = ''; + my $START = quotemeta '[%'; + my $END = quotemeta '%]'; + + my @all = split /($START .*? $END)/sx, $_[0]; + for my $piece (@all) { + next if ! length $piece; + if ($piece !~ /^$START (.*) $END$/sx) { + $new .= $piece; + next; + } + my $tag = $1; + $new .= "($tag)"; + } + return $new; +} + +### a regex grammar type matcher +sub parse_grammar { + my $new = ''; + my $START = quotemeta '[%'; + my $END = quotemeta '%]'; + + my $in_tag; + local pos($_[0]) = 0; + while (1) { + ### find the start tag + if (! $in_tag) { + if ($_[0] =~ /\G (.*?) $START /gcxs) { + $new .= $1; + $in_tag = 1; + next; + } else { + $new .= substr $_[0], pos($_[0]); + last; + } + } + + ### end + if ($_[0] =~ /\G $END /gcx) { + $in_tag = 0; + } + + if ($_[0] =~ /\G (\s*\w+\s*) /gcx) { + my $tag = $1; + $new .= "($tag)"; + } + } + return $new; +} + +###----------------------------------------------------------------### +### check compliance + +#print parse_match($str); +#print "---\n"; +#print parse_split($str); +#print "---\n"; +#print parse_grammar($str); +#print "---\n"; +#print parse_index($str); +die "parse_split didn't match" if parse_split($str) ne parse_match($str); +die "parse_grammar didn't match" if parse_grammar($str) ne parse_match($str); +die "parse_index didn't match" if parse_index($str) ne parse_match($str); +die "parse_index2 didn't match" if parse_index2($str) ne parse_match($str); +#exit; + +### and run them +cmpthese timethese (-2, { + index => sub { parse_index($str) }, + index2 => sub { parse_index2($str) }, + match => sub { parse_match($str) }, + split => sub { parse_split($str) }, + grammar => sub { parse_grammar($str) }, +}); diff --git a/samples/benchmark/bench_validation.pl b/samples/benchmark/bench_validation.pl new file mode 100644 index 0000000..24244d9 --- /dev/null +++ b/samples/benchmark/bench_validation.pl @@ -0,0 +1,126 @@ +#!/usr/bin/perl -w + +use Benchmark qw(timethese cmpthese countit timestr); +use CGI::Ex::Validate; +use Data::FormValidator; + +my $form = { + username => "++foobar++", + password => "123", + password2 => "1234", +}; + +my $val_hash_ce = { + username => { + required => 1, + match => 'm/^\w+$/', + match_error => '$name may only contain letters and numbers', + untaint => 1, + }, + password => { + required => 1, + match => 'm/^[ -~]{6,30}$/', +# min_len => 6, +# max_len => 30, +# match => 'm/^[ -~]+$/', + untaint => 1, + }, + password2 => { + validate_if => 'password', + equals => 'password', + }, + email => { + required => 1, + match => 'm/^[\w\.\-]+\@[\w\.\-]+$/', + untaint => 1, + }, +}; + +my $val_hash_df = { + required => [qw(username password email)], + dependencies => { + password => [qw(password2)], + }, + constraints => { + email => qr/^[\w\.\-]+\@[\w\.\-]+$/, + password => qr/^[ -~]{6,30}$/, + username => qr/^\w+$/, + }, + untaint_all_constraints => 1, + msgs => { + format => '%s', + prefix => 'error_', + }, +}; + +sub check_form { + my $form = shift; + my $hash = {}; + if (! exists $form->{'username'}) { + push @{ $hash->{'username_error'} }, 'Username required'; + } elsif ($form->{'username'} !~ m/^(\w+)$/) { + push @{ $hash->{'username_error'} }, 'Username may only contain letters and numbers'; + } else { + $form->{'username'} = $1; + } + if (! exists $form->{'password'}) { + push @{ $hash->{'password_error'} }, 'Password required'; + } else { + if ($form->{'password'} !~ m/^([ -~]+)$/) { + push @{ $hash->{'password_error'} }, 'Password contained bad characters'; + } else { + $form->{'password'} = $1; + } + if (length($form->{'password'}) < 6) { + push @{ $hash->{'password_error'} }, 'Password must be more than 6 characters'; + } elsif (length($form->{'password'}) > 30) { + push @{ $hash->{'password_error'} }, 'Password must be less than 30 characters'; + } + + if (! defined($form->{'password2'}) + || $form->{'password2'} ne $form->{'password'}) { + push @{ $hash->{'password2_error'} }, 'Password2 and password must be the same'; + } + } + + if (! exists $form->{'email'}) { + push @{ $hash->{'email_error'} }, 'Email required'; + } elsif ($form->{'email'} !~ m/^[\w\.\-]+\@[\w\.\-]+$/) { + push @{ $hash->{'email_error'} }, 'Please type a valid email address'; + } + + return $hash; +} + + +cmpthese (-2,{ + cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce) }, + data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df) }, + homegrown => sub { my $t = scalar keys %{ check_form($form) } }, +},'auto'); + +cmpthese (-2,{ + cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash }, + data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df)->msgs }, + homegrown => sub { my $t = check_form($form) }, +},'auto'); + + +### Home grown solution blows the others away - but lacks features +# +# Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds... +# cgi_ex: 2 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 1430.66/s (n=3033) +# data_val: 2 wallclock secs ( 2.01 usr + 0.00 sys = 2.01 CPU) @ 2588.56/s (n=5203) +# homegrown: 2 wallclock secs ( 2.19 usr + 0.01 sys = 2.20 CPU) @ 54733.18/s (n=120413) +# Rate cgi_ex data_val homegrown +# cgi_ex 1431/s -- -45% -97% +# data_val 2589/s 81% -- -95% +# homegrown 54733/s 3726% 2014% -- +# Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds... +# cgi_ex: 2 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 1218.57/s (n=2559) +# data_val: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 2092.99/s (n=4479) +# homegrown: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 56267.76/s (n=120413) +# Rate cgi_ex data_val homegrown +# cgi_ex 1219/s -- -42% -98% +# data_val 2093/s 72% -- -96% +# homegrown 56268/s 4518% 2588% -- diff --git a/samples/benchmark/bench_various_templaters.pl b/samples/benchmark/bench_various_templaters.pl new file mode 100644 index 0000000..1dc6b69 --- /dev/null +++ b/samples/benchmark/bench_various_templaters.pl @@ -0,0 +1,230 @@ +#!/usr/bin/perl -w + +=head1 NAME + +bench_various_templaters.pl - test the relative performance of several different types of template engines. + +=cut + +use strict; +use Benchmark qw(timethese cmpthese); + +my $file = $0; +$file =~ s|[^/]+$|WrapEx.pm|; +#require $file; + +use Template; +use Template::Stash; +use Text::Template; +use CGI::Ex::Dump qw(debug); +use CGI::Ex::Template; +use POSIX qw(tmpnam); +use File::Path qw(mkpath rmtree); + +my $dir = tmpnam; +mkpath($dir); +END {rmtree $dir}; +my @dirs = ($dir); + +my $form = { + foo => 'bar', + pass_in_something => 'what ever you want', +}; + +###----------------------------------------------------------------### + +my $stash_w = { + shell => { + header => "This is a header", + footer => "This is a footer", + start => "", + end => "", + foo => $form->{'foo'}, + }, + a => { + stuff => [qw(one two three four)], + }, +}; + +my $stash_t = { + shell_header => "This is a header", + shell_footer => "This is a footer", + shell_start => "", + shell_end => "", + a_stuff => [qw(one two three four)], +}; + +$FOO::shell_header = $FOO::shell_footer = $FOO::shell_start = $FOO::shell_end = $FOO::a_stuff; +$FOO::shell_header = "This is a header"; +$FOO::shell_footer = "This is a footer"; +$FOO::shell_start = ""; +$FOO::shell_end = ""; +$FOO::a_stuff = [qw(one two three four)]; + + +###----------------------------------------------------------------### + +my $content_w = q{[shell.header] +[shell.start] + +[if shell.foo q{ +This is some text. +}] + +[loop i a.stuff.length q{[a.stuff]}] +[form.pass_in_something] + +[shell.end] +[shell.footer] +}; + +my $content_t = q{[% shell_header %] +[% shell_start %] + +[% IF foo %] +This is some text. +[% END %] + +[% FOREACH i IN a_stuff %][% i %][% END %] +[% pass_in_something %] + +[% shell_end %] +[% shell_footer %] +}; + +my $content_h = q{ +[% shell_start %] + +[% IF foo %] +This is some text. +[% END %] + +[% FOREACH i IN a_stuff %][% i %][% END %] +[% pass_in_something %] + +[% shell_end %] +[% shell_footer %] +}; + +if (open (my $fh, ">$dir/foo.tt")) { + print $fh $content_t; + close $fh; +} + +my $content_p = q{{$shell_header} +{$shell_start} + +{ if ($foo) { + $OUT .= " +This is some text. +"; + } +} + +{ $OUT .= $_ foreach @$a_stuff; } +{$pass_in_something} + +{$shell_end} +{$shell_footer} +}; + +#my $wrap = WrapEx->new({ +# dirs => \@dirs, +# W => $stash_w, +# form => [$form], +#}); + + my $tt = Template->new({ + INCLUDE_PATH => \@dirs, + STASH => Template::Stash->new($stash_t), +}); + +my $ct = CGI::Ex::Template->new({ + INCLUDE_PATH => \@dirs, + VARIABLES => $stash_t, +}); + +my $pt = Text::Template->new(TYPE => 'STRING', SOURCE => $content_p, HASH => $form); + +###----------------------------------------------------------------### +### make sure everything is ok + +#my $out_wr = $content_w; +#$wrap->wrap(\$out_wr); + +my $out_tt = ""; +$tt->process(\$content_t, $form, \$out_tt); + +my $out_ct = ""; +$ct->process(\$content_t, $form, \$out_ct); + +my $out_c2 = ""; +$ct->process('foo.tt', $form, \$out_c2); + +my $out_c3 = ''; +$ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out_c3); + +my $out_pt = $pt->fill_in(PACKAGE => 'FOO', HASH => $form); + +if ($out_wr ne $out_tt) { + debug $out_wr, $out_tt; + die "Wrap didn't match tt"; +} +if ($out_ct ne $out_tt) { + debug $out_ct, $out_tt; + die "CGI::Ex::Template didn't match tt"; +} +if ($out_c2 ne $out_tt) { + debug $out_c2, $out_tt; + die "CGI::Ex::Template from file didn't match tt"; +} +if ($out_c3 ne $out_tt) { + debug $out_c3, $out_tt; + die "CGI::Ex::Template by swap didn't match tt"; +} +if ($out_pt ne $out_tt) { + debug $out_pt, $out_tt; + die "Text Template didn't match tt"; +} + +###----------------------------------------------------------------### + +cmpthese timethese (-2, { +# wrap => sub { +# my $out = $content_w; +# $wrap->wrap(\$out); +# }, + TemplateToolkit => sub { + my $out = ""; + $tt->process(\$content_t, $form, \$out); + }, + CET => sub { + my $out = ""; + $ct->process(\$content_t, $form, \$out); + }, + CET_mem => sub { + my $out = ""; + $ct->process('foo.tt', $form, \$out); + }, + CET_process_s => sub { + my $out = ''; + $ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out); + }, + CET_cache => sub { + my $ct = CGI::Ex::Template->new({ + INCLUDE_PATH => \@dirs, + STASH => Template::Stash->new($stash_t), + CACHE_DIR => $dir, + }); + my $out = ''; + $ct->process('foo.tt', {%$stash_t, %$form}, \$out); + }, + TextTemplate => sub { + my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => $form); + }, + TextTemplate2 => sub { + my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => {%$stash_t, %$form}); + }, +}); + +###----------------------------------------------------------------### diff --git a/samples/cgi_ex_1.cgi b/samples/cgi_ex_1.cgi new file mode 100755 index 0000000..2f10b1d --- /dev/null +++ b/samples/cgi_ex_1.cgi @@ -0,0 +1,186 @@ +#!/usr/bin/perl -w + +=head1 NAME + +cgi_ex_1.cgi - Show a basic example using some of the CGI::Ex tools + +=cut + +if (__FILE__ eq $0) { + handler(); +} + +###----------------------------------------------------------------### + +use strict; +use CGI::Ex; +use CGI::Ex::Validate (); +use CGI::Ex::Dump qw(debug); + +###----------------------------------------------------------------### + +sub handler { + my $cgix = CGI::Ex->new; + my $vob = CGI::Ex::Validate->new; + my $form = $cgix->get_form(); + + ### allow for js validation libraries + ### path_info should contain something like /CGI/Ex/yaml_load.js + ### see the line with 'js_val' below + my $info = $ENV{PATH_INFO} || ''; + if ($info =~ m|^(/\w+)+.js$|) { + $info =~ s|^/+||; + $cgix->print_js($info); + return; + } + + + debug $form; + + + ### check for errors - if they have submitted information + my $has_info = ($form->{processing}) ? 1 : 0; + my $errob = $has_info ? $vob->validate($form, validation_hash()) : undef; + my $form_name = 'formfoo'; + + ### failed validation - send out the template + if (! $has_info || $errob) { + + ### get a template and swap defaults + my $swap = defaults_hash(); + + ### add errors to the swap (if any) + if ($errob) { + my $hash = $errob->as_hash(); + $swap->{$_} = delete($hash->{$_}) foreach keys %$hash; + $swap->{'error_header'} = 'Please correct the form information below'; + } + + ### get js validation ready + $swap->{'form_name'} = $form_name; + $swap->{'js_val'} = $vob->generate_js(validation_hash(), # filename or valhash + $form_name, # name of form + $ENV{SCRIPT_NAME}); # browser path to cgi that calls print_js + + ### swap in defaults, errors and js_validation + my $content = $cgix->swap_template(get_content_form(), $swap); + + ### fill form fields + $cgix->fill(\$content, $form); + #debug $content; + + ### print it out + $cgix->print_content_type(); + print $content; + return; + } + + + ### show some sort of success if there were no errors + $cgix->print_content_type; + my $content = $cgix->swap_template(get_content_success(), defaults_hash()); + print $content; + return; + +} + +###----------------------------------------------------------------### + +sub validation_hash { + return { + 'group order' => ['username', 'password'], + username => { + required => 1, + min_len => 3, + max_len => 30, + match => 'm/^\w+$/', + # could probably all be done with match => 'm/^\w{3,30}$/' + }, + password => { + required => 1, + max_len => 20, + }, + password_verify => { + validate_if => 'password', + equals => 'password', + }, + }; +} + +sub defaults_hash { + return { + title => 'My Application', + script => $ENV{SCRIPT_NAME}, + color => ['#ccf', '#aaf'], + } +} + +###----------------------------------------------------------------### + +sub get_content_form { + return qq{ + + + [% 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/samples/cgi_ex_2.cgi b/samples/cgi_ex_2.cgi new file mode 100755 index 0000000..114b4da --- /dev/null +++ b/samples/cgi_ex_2.cgi @@ -0,0 +1,150 @@ +#!/usr/bin/perl -w + +=head1 NAME + +cgi_ex_2.cgi - Rewrite of cgi_ex_1.cgi using CGI::Ex::App + +=cut + +if (__FILE__ eq $0) { + handler(); +} + +sub handler { + MyCGI->navigate; +} + +###----------------------------------------------------------------### + +package MyCGI; + +use strict; +use base CGI::Ex::App; +use CGI::Ex::Dump qw(debug); + +sub pre_loop { + my $self = shift; + my $path = shift; + if ($#$path == -1) { + push @$path, 'userinfo'; + } +} + +### this will work for both userinfo_hash_common and success_hash_common +sub hash_common { + my $self = shift; + return { + title => 'My Application', + script => $ENV{SCRIPT_NAME}, + color => ['#ccf', '#aaf'], + history => $self->history, + } +} + +sub ready_validate { + my $self = shift; + return $self->form->{processing} ? 1 : 0; +} + +###----------------------------------------------------------------### + +sub userinfo_hash_validation { + return { + 'group order' => ['username', 'password'], + username => { + required => 1, + min_len => 3, + max_len => 30, + match => 'm/^\w+$/', + # could probably all be done with match => 'm/^\w{3,30}$/' + }, + password => { + required => 1, + max_len => 20, + }, + password_verify => { + validate_if => 'password', + equals => 'password', + }, + }; +} + +sub userinfo_hash_swap { + my $self = shift; + my $hash = $self->form; + $hash->{form_name} = 'formfoo'; + $hash->{js_val} = $self->vob->generate_js($self->userinfo_hash_validation(), + $hash->{form_name}, + "$ENV{SCRIPT_NAME}/js"); + return $hash; +} + +###----------------------------------------------------------------### + +sub userinfo_file_print { + return \ qq { + + + [% title %] + + + +

Please Enter information

+ [% error_header %] +
+ +
+ + + + + + + + + + + + + + + + + + + +
Username: + + [% username_error %]
Password: + [% password_error %]
Password Verify: + [% password_verify_error %]
+ +
+ + [% js_validation %] + + + }; +} + +sub success_file_print { + return \ qq{ + + [% title %] + +

Success

+
+ print "I can now continue on with the rest of my script!"; + + + }; +} + + +1; diff --git a/samples/conf_path_1/apples.pl b/samples/conf_path_1/apples.pl new file mode 100644 index 0000000..56856ae --- /dev/null +++ b/samples/conf_path_1/apples.pl @@ -0,0 +1,5 @@ +{ + quantity => 20, + color => 'red', + foo_immutable => 'file1', +}; diff --git a/samples/conf_path_1/oranges.pl b/samples/conf_path_1/oranges.pl new file mode 100644 index 0000000..03fc08b --- /dev/null +++ b/samples/conf_path_1/oranges.pl @@ -0,0 +1,6 @@ +{ + immutable => 1, + quantity => 20, + color => 'orange', + foo => 'file1', +}; diff --git a/samples/conf_path_3/apples.pl b/samples/conf_path_3/apples.pl new file mode 100644 index 0000000..e72f0ee --- /dev/null +++ b/samples/conf_path_3/apples.pl @@ -0,0 +1,5 @@ +{ + quantity => 30, + color => 'green', + foo => 'file2', +}; diff --git a/samples/conf_path_3/oranges.pl b/samples/conf_path_3/oranges.pl new file mode 100644 index 0000000..f02324d --- /dev/null +++ b/samples/conf_path_3/oranges.pl @@ -0,0 +1,5 @@ +{ + quantity => 30, + color => 'orange', + foo => 'file2', +}; diff --git a/samples/devel/dprof_conf.d b/samples/devel/dprof_conf.d new file mode 100644 index 0000000..a99369c --- /dev/null +++ b/samples/devel/dprof_conf.d @@ -0,0 +1,77 @@ +# -*-perl-*- +# run with perl -d:DProf $0 + +use CGI::Ex::Conf qw(conf_read conf_write); +use POSIX qw(tmpnam); +use Data::Dumper qw(Dumper); + +#my $cob = CGI::Ex::Conf->new; +my $tmp = tmpnam .".sto"; +END { unlink $tmp }; + +my $conf = { + one => 1, + two => 2, + three => 3, + four => 4, + five => 5, + six => 6, + seven => 7, + eight => 8, + nine => 9, + ten => 10, +}; + +#$cob->write($tmp, $conf); +conf_write($tmp, $conf); +#print `cat $tmp`; exit; + +for (1 .. 100_000) { +# my $ref = $cob->read($tmp); +# my $ref = conf_read($tmp); +# print Dumper $ref; exit; + + conf_write($tmp, $conf); +} + + +__END__ + +### conf_read +%Time ExclSec CumulS #Calls sec/call Csec/c Name + 38.5 2.120 0.000 100000 0.0000 0.0000 Storable::_retrieve + 38.1 2.100 2.100 100000 0.0000 0.0000 Storable::pretrieve + 20.9 1.150 5.860 100000 0.0000 0.0001 CGI::Ex::Conf::read_ref + 8.73 0.480 6.720 100000 0.0000 0.0001 CGI::Ex::Conf::conf_read + 6.91 0.380 0.380 100001 0.0000 0.0000 CGI::Ex::Conf::new + 4.73 0.260 0.000 100000 0.0000 0.0000 Storable::retrieve + 4.18 0.230 4.710 100000 0.0000 0.0000 CGI::Ex::Conf::read_handler_storab + le + 0.36 0.020 0.040 3 0.0067 0.0133 main::BEGIN + 0.18 0.010 0.010 6 0.0017 0.0017 Exporter::import + 0.18 0.010 0.010 4 0.0025 0.0025 CGI::Ex::Conf::BEGIN + 0.18 0.010 0.020 1 0.0100 0.0199 CGI::Ex::Conf::write_handler_stora + ble + 0.18 0.010 0.010 5 0.0020 0.0020 AutoLoader::AUTOLOAD + 0.00 0.000 0.000 1 0.0000 0.0000 POSIX::load_imports + 0.00 0.000 0.000 1 0.0000 0.0000 Exporter::Heavy::heavy_export + 0.00 0.000 0.000 1 0.0000 0.0000 Storable::store + +### conf_write +%Time ExclSec CumulS #Calls sec/call Csec/c Name + 60.3 9.510 9.510 100001 0.0001 0.0001 Storable::pstore + 32.8 5.170 0.000 100001 0.0001 0.0000 Storable::_store + 7.68 1.210 16.450 100001 0.0000 0.0002 CGI::Ex::Conf::write_ref + 2.60 0.410 17.220 100001 0.0000 0.0002 CGI::Ex::Conf::conf_write + 2.28 0.360 0.360 100001 0.0000 0.0000 CGI::Ex::Conf::new + 2.16 0.340 15.240 100001 0.0000 0.0002 CGI::Ex::Conf::write_handler_stora + ble + 1.33 0.210 0.000 100001 0.0000 0.0000 Storable::store + 0.06 0.010 0.010 3 0.0033 0.0033 AutoLoader::import + 0.06 0.010 0.010 2 0.0050 0.0050 DynaLoader::BEGIN + 0.06 0.010 0.010 4 0.0025 0.0025 CGI::Ex::Conf::BEGIN + 0.06 0.010 0.030 3 0.0033 0.0099 main::BEGIN + 0.00 0.000 0.000 1 0.0000 0.0000 POSIX::load_imports + 0.00 0.000 0.000 1 0.0000 0.0000 Exporter::Heavy::heavy_export + 0.00 - -0.000 1 - - main::END + 0.00 - -0.000 1 - - bytes::import diff --git a/samples/devel/dprof_template.d b/samples/devel/dprof_template.d new file mode 100644 index 0000000..15c30cf --- /dev/null +++ b/samples/devel/dprof_template.d @@ -0,0 +1,54 @@ +# -*-perl-*- +# run with perl -d:DProf $0 ; dprofpp + +use strict; +use POSIX qw(tmpnam); +use File::Path qw(rmtree); +use CGI::Ex::Template; +#use CGI::Ex::Template_60; + +my $tt_cache_dir = tmpnam; +END { rmtree $tt_cache_dir }; +mkdir $tt_cache_dir, 0755; + +my $cet = CGI::Ex::Template->new(ABSOLUTE => 1); +#use Template; +#my $cet = Template->new(ABSOLUTE => 1); + +###----------------------------------------------------------------### + +my $swap = { + one => "ONE", + two => "TWO", + three => "THREE", + a_var => "a", + hash => {a => 1, b => 2, c => { d => ["hmm"] }}, + array => [qw(A B C D E a A)], + code => sub {"($_[0])"}, + cet => $cet, +}; + +my $txt = ''; +$txt .= "[% one %]\n"; +$txt .= ((" "x1000)."[% one %]\n")x100; +$txt .= "[%f=10; WHILE (g=f) ; f = f - 1 ; f ; END %]"; +$txt .= ("[% \"".(" "x10)."\$one\" %]\n")x1000; + +my $file = \$txt; + +if (1) { + $file = $tt_cache_dir .'/template.txt'; + open(my $fh, ">$file") || die "Couldn't open $file: $!"; + print $fh $txt; + close $fh; +} + +###----------------------------------------------------------------### + +sub cet { + my $out = ''; + $cet->process($file, $swap, \$out); + return $out; +} + +cet() for 1 .. 500; diff --git a/samples/devel/dprof_validation.d b/samples/devel/dprof_validation.d new file mode 100644 index 0000000..5b02305 --- /dev/null +++ b/samples/devel/dprof_validation.d @@ -0,0 +1,41 @@ +# -*-perl-*- +# run with perl -d:DProf $0 + +use CGI::Ex::Validate; + +my $form = { + username => "++foobar++", + password => "123", + password2 => "1234", +}; + +my $val_hash_ce = { + username => { + required => 1, + match => 'm/^\w+$/', + match_error => '$name may only contain letters and numbers', + untaint => 1, + }, + password => { + required => 1, + min_len => 6, + max_len => 30, + match => 'm/^[ -~]+$/', + untaint => 1, + }, + password2 => { + validate_if => 'password', + equals => 'password', + }, + email => { + required => 1, + match => 'm/^[\w\.\-]+\@[\w\.\-]+$/', + untaint => 1, + }, +}; + + +for (1 .. 10_000) { + my $err_obj = CGI::Ex::Validate->validate($form, $val_hash_ce); +# my $err_obj = CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash; +} diff --git a/samples/generate_js.pl b/samples/generate_js.pl new file mode 100644 index 0000000..aeb1ecb --- /dev/null +++ b/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/samples/html1.htm b/samples/html1.htm new file mode 100644 index 0000000..9441558 --- /dev/null +++ b/samples/html1.htm @@ -0,0 +1,14 @@ +
+ + + +
+ + + diff --git a/samples/html2.htm b/samples/html2.htm new file mode 100644 index 0000000..1d8a41c --- /dev/null +++ b/samples/html2.htm @@ -0,0 +1,10 @@ +
+ + + +
+ diff --git a/samples/js_validate_1.html b/samples/js_validate_1.html new file mode 100644 index 0000000..991b07d --- /dev/null +++ b/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/samples/js_validate_2.html b/samples/js_validate_2.html new file mode 100644 index 0000000..7c42708 --- /dev/null +++ b/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/samples/js_validate_3.html b/samples/js_validate_3.html new file mode 100644 index 0000000..430e531 --- /dev/null +++ b/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/samples/memory_template.pl b/samples/memory_template.pl new file mode 100644 index 0000000..28b1710 --- /dev/null +++ b/samples/memory_template.pl @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w + +my $swap = { + one => "ONE", + two => "TWO", + three => "THREE", + a_var => "a", + hash => {a => 1, b => 2}, + code => sub {"($_[0])"}, +}; + +my $txt = "[% one %][% two %][% three %][% hash.keys.join %] [% code(one).length %] [% hash.\$a_var %]\n"; + +###----------------------------------------------------------------### + +my $module; +if (! fork) { + $module = 'CGI::Ex::Template'; + $0 = "perl $module"; +} elsif (! fork) { + $module = 'Template'; + $0 = "perl $module"; +} + +if ($module) { + my $pm = "$module.pm"; + $pm =~ s|::|/|g; + require $pm; + + my $t = $module->new(ABSOLUTE => 1); + my $out = ''; + $t->process(\$txt, $swap, \$out); + print $out; +} + +sleep 15; # go and check the 'ps fauwx|grep perl' + + +###----------------------------------------------------------------### diff --git a/samples/perl1.pl b/samples/perl1.pl new file mode 100644 index 0000000..4b41e16 --- /dev/null +++ b/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/samples/perl2.pl b/samples/perl2.pl new file mode 100644 index 0000000..2a45fea --- /dev/null +++ b/samples/perl2.pl @@ -0,0 +1,17 @@ +[ + { + 'group validate_if' => 'foo', + bar => { + required => 1, + }, + }, + { + 'group validate_if' => 'hem', + haw => { required => 1 }, + }, + { + raspberry => { + required => 1, + }, + }, +]; diff --git a/samples/yaml1.val b/samples/yaml1.val new file mode 100644 index 0000000..0e97091 --- /dev/null +++ b/samples/yaml1.val @@ -0,0 +1,8 @@ +user: + required: 1 +foo: + required_if: bar + +### you could also do +# user: {required: 1} +# foo: {required: 1} diff --git a/samples/yaml2.val b/samples/yaml2.val new file mode 100644 index 0000000..73ce52e --- /dev/null +++ b/samples/yaml2.val @@ -0,0 +1,7 @@ +- group validate_if: foo + bar: + required: 1 +- group validate_if: hem + haw: { required: 1 } +- raspberry: + required: 1 diff --git a/samples/yaml3.val b/samples/yaml3.val new file mode 100644 index 0000000..d8dae6c --- /dev/null +++ b/samples/yaml3.val @@ -0,0 +1,13 @@ +--- +group validate_if: foo +bar: + required: 1 + +--- +group validate_if: hem +haw: { required: 1 } + +--- +raspberry: + required: 1 + diff --git a/samples/yaml_js_1.html b/samples/yaml_js_1.html new file mode 100644 index 0000000..263d16a --- /dev/null +++ b/samples/yaml_js_1.html @@ -0,0 +1,62 @@ + +Yaml Test + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/samples/yaml_js_2.html b/samples/yaml_js_2.html new file mode 100644 index 0000000..faf32cc --- /dev/null +++ b/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/samples/yaml_js_3.html b/samples/yaml_js_3.html new file mode 100644 index 0000000..08a69ce --- /dev/null +++ b/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/samples/yaml_js_4.html b/samples/yaml_js_4.html new file mode 100644 index 0000000..d68885a --- /dev/null +++ b/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 diff --git a/t/0_ex_00_base.t b/t/0_ex_00_base.t index a31a737..387170a 100644 --- a/t/0_ex_00_base.t +++ b/t/0_ex_00_base.t @@ -1,8 +1,169 @@ +# -*- Mode: Perl; -*- -BEGIN { - print "1..1\n"; +=head1 NAME + +0_ex_00_base.t - Testing of the base CGI::Ex module. + +=cut + +use strict; +use Test::More tests => 63; + +use_ok('CGI::Ex'); + +my $cgix = CGI::Ex->new; +ok($cgix, "Got object"); + +### test out form and cookies from the CGI object +SKIP: { + skip("CGI.pm not found", 9) if ! eval { require CGI }; + local $ENV{'REQUEST_METHOD'} = 'GET'; + local $ENV{'QUERY_STRING'} = 'foo=bar&foo=baz&us=them'; + local $ENV{'HTTP_COOKIE'} = 'bar=baz; bing=blam'; + + my $form = $cgix->form; + ok($form, "Got form"); + ok(ref($form) eq 'HASH', "Good form"); + ok($form->{'foo'}, "Found foo"); + ok(ref($form->{'foo'}) eq 'ARRAY', "Foo is array"); + ok(@{ $form->{'foo'} } == 2, "Correct number"); + ok($form->{'us'}, "Found us"); + ok($form->{'us'} eq 'them', "Us is correct"); + + my $cookies = $cgix->cookies; + ok($cookies, "Got cookies"); + ok($cookies->{'bar'} eq 'baz', "Found correct bar"); +}; + +### set a new form +my $form = {foo => 'bar', mult => [qw(a b c)]}; +$cgix->form($form); +$cgix->cookies($form); + +$form = $cgix->form; +ok($form->{'foo'} eq 'bar', "Could set form"); + +my $cookies = $cgix->cookies; +ok($cookies->{'foo'} eq 'bar', "Could set form"); + + +### try out make_form +my $str = $cgix->make_form($form); +ok($str =~ /foo=bar/, "Make form works"); +ok($str =~ /mult=a&mult=b&mult=c/, "Make form works 2"); + +$str = $cgix->make_form($form, ['foo']); +ok($str eq 'foo=bar', "Make form works with keys"); + +### can't test these without being in apache (well we could test STDOUT - but that is for another day - TODO) +foreach my $meth (qw( + apache_request + content_typed + expires + is_mod_perl_1 + is_mod_perl_2 + last_modified + location_bounce + mod_perl_version + print_content_type + print_js + send_status + send_header + set_apache_request + set_cookie + )) { + ok($cgix->can($meth), "Has method $meth"); } -use CGI::Ex; +### try out time_calc +my $sec; +ok(($sec = CGI::Ex::time_calc('1m')) == time + 60, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc('-1m')) == time - 60, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc('1 m')) == time + 60, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc('1 min')) == time + 60, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc('1')) == 1, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc('now')) == time, "Time_calc ($sec)"); +ok(($sec = CGI::Ex::time_calc(__FILE__)), "Time_calc ($sec)"); + +###----------------------------------------------------------------### + +my $html = ""; +$form = {foo => 'bar'}; +my $out; + +ok(($out = $cgix->fill(scalarref => \$html, form => $form)) =~ /value=([\"\'])bar\1/, "Filled $out"); +ok(($out = $cgix->fill(arrayref => [$html], form => $form)) =~ /value=([\"\'])bar\1/, "Filled $out"); + +$cgix->fill(text => \$html, form => $form); +ok($html =~ /value=([\"\'])bar\1/, "Filled $html"); + +$html = ""; + +$form = {baz => 'bing', bim => 'bang'}; + +$out = $cgix->fill(scalarref => \$html, form => $form, target => 'foo'); +ok($out =~ /bing/, "Got bing"); +ok($out !~ /bang/, "Didn't get bang"); + +$out = $cgix->fill(scalarref => \$html, form => $form, target => 'bar'); +ok($out =~ /bang/, "Got bang"); +ok($out !~ /bing/, "Didn't get bing"); + +$out = $cgix->fill(scalarref => \$html, form => $form, ignore_fields => ['baz']); +ok($out =~ /bang/, "Got bang"); +ok($out !~ /bing/, "Didn't get bing"); + +$out = $cgix->fill(scalarref => \$html, form => $form, ignore_fields => ['bim']); +ok($out =~ /bing/, "Got bing"); +ok($out !~ /bang/, "Didn't get bang"); + +$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => 1); +ok($out =~ /bing/, "Got bing"); +ok($out =~ /bang/, "Got bang"); + +$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => undef); +ok($out =~ /bing/, "Got bing"); +ok($out =~ /bang/, "Got bang"); + +$out = $cgix->fill(scalarref => \$html, form => $form, fill_password => 0); +ok($out =~ /bing/, "Got bing"); +ok($out !~ /bang/, "Didn't get bang"); + +###----------------------------------------------------------------### + +$form = {foo => 'bar'}; +my $val = {foo => {'required' => 1}}; + +my $e = $cgix->validate($form, $val); +ok(! $e, "No error"); + +$form = {}; +$e = $cgix->validate($form, $val); +ok($e, "Got error"); +ok("$e" =~ /required/i, "Had error message ($e)"); + +###----------------------------------------------------------------### + +### defer testing to the conf test modules +foreach my $meth (qw( + conf_obj + conf_read + )) { + ok($cgix->can($meth), "Has method $meth"); +} + +###----------------------------------------------------------------### + +$form = {foo => 'bar'}; +my $args = {VARIABLES => {bim => 'bam'}}; +my $temp = "([% foo %])([% bim %])"; + +$out = $cgix->swap_template($temp, $form, $args); +ok($out =~ /bar/, "Got bar"); +ok($out =~ /bam/, "Got bam"); + +$cgix->swap_template(\$temp, $form, $args); +ok($temp =~ /bar/, "Got bar"); +ok($temp =~ /bam/, "Got bam"); -BEGIN { print "ok 1\n"; } +###----------------------------------------------------------------### diff --git a/t/1_validate_00_base.t b/t/1_validate_00_base.t index d8ea8df..12a1b0c 100644 --- a/t/1_validate_00_base.t +++ b/t/1_validate_00_base.t @@ -1,8 +1,39 @@ +# -*- Mode: Perl; -*- -BEGIN { - print "1..1\n"; -} +=head1 NAME -use CGI::Ex::Validate; +1_validate_00_base.t - Test CGI::Ex::Validate's ability to compile and execute -BEGIN { print "ok 1\n"; } +=cut + +use strict; +use Test::More tests => 3; + +use_ok('CGI::Ex::Validate'); + +my $form = { + user => 'abc', + pass => '123', +}; +my $val = { + user => { + required => 1, + }, + pass => { + required => 1, + }, +}; + +my $err_obj = CGI::Ex::Validate::validate($form, $val); +ok(! $err_obj, "Basic function works"); + +###----------------------------------------------------------------### + +$form = { + user => 'abc', +# pass => '123', +}; + +$err_obj = CGI::Ex::Validate::validate($form,$val); + +ok($err_obj, "Successfully failed"); diff --git a/t/1_validate_03_cgi.t b/t/1_validate_03_cgi.t index 32dff8f..a6e4153 100644 --- a/t/1_validate_03_cgi.t +++ b/t/1_validate_03_cgi.t @@ -1,34 +1,41 @@ # -*- Mode: Perl; -*- +=head1 NAME + +1_validate_03_cgi.t - Test CGI::Ex::Validate's ability to interact with CGI.pm. + +=cut + use strict; +use Test::More tests => 3; -$^W = 1; +use_ok('CGI::Ex::Validate'); -print "1..2\n"; +SKIP: { + skip("CGI.pm not installed", 2) if ! eval { require CGI }; -use CGI::Ex; -use CGI; + my $form = CGI->new({ + user => 'abc', + pass => '123', + }); + my $val = { + user => { + required => 1, + }, + pass => { + required => 1, + }, + }; -print "ok 1\n"; + my $err_obj = CGI::Ex::Validate::validate($form,$val); + ok(! $err_obj, "Correctly didn't get an error object"); -my $form = CGI->new({ - user => 'abc', - pass => '123', -}); -my $val = { - user => { - required => 1, - }, - pass => { - required => 1, - }, -}; + $form = CGI->new({ + user => 'abc', + #pass => '123', + }); -my $err_obj = CGI::Ex->new->validate($form,$val); + $err_obj = CGI::Ex::Validate::validate($form, $val); + ok($err_obj, "Correctly did get an error object"); -if (! $err_obj) { - print "ok 2\n"; -} else { - warn "$err_obj\n"; - print "not ok 2\n"; } diff --git a/t/1_validate_05_types.t b/t/1_validate_05_types.t index bb87b5b..2247107 100644 --- a/t/1_validate_05_types.t +++ b/t/1_validate_05_types.t @@ -1,300 +1,289 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +1_validate_05_types.t - Test CGI::Ex::Validate's ability to do multitudinous types of validate -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +=cut -require CGI::Ex::Validate; +use strict; +use Test::More tests => 104; -my ($N, $v, $e, $ok) = (0); +use_ok('CGI::Ex::Validate'); -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); +my $v; +my $e; +sub validate { scalar &CGI::Ex::Validate::validate(@_) } ### required $v = {foo => {required => 1}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({foo => 1}, $v); -&print_ok(! $e); +$e = validate({foo => 1}, $v); +ok(! $e); ### validate_if $v = {foo => {required => 1, validate_if => 'bar'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({bar => 1}, $v); -&print_ok($e); +$e = validate({bar => 1}, $v); +ok($e); ### required_if $v = {foo => {required_if => 'bar'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({bar => 1}, $v); -&print_ok($e); +$e = validate({bar => 1}, $v); +ok($e); ### max_values $v = {foo => {required => 1}}; -$e = &validate({foo => [1,2]}, $v); -&print_ok($e); +$e = validate({foo => [1,2]}, $v); +ok($e); $v = {foo => {max_values => 2}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({foo => "str"}, $v); -&print_ok(! $e); +$e = validate({foo => "str"}, $v); +ok(! $e); -$e = &validate({foo => [1]}, $v); -&print_ok(! $e); +$e = validate({foo => [1]}, $v); +ok(! $e); -$e = &validate({foo => [1,2]}, $v); -&print_ok(! $e); +$e = validate({foo => [1,2]}, $v); +ok(! $e); -$e = &validate({foo => [1,2,3]}, $v); -&print_ok($e); +$e = validate({foo => [1,2,3]}, $v); +ok($e); ### min_values $v = {foo => {min_values => 3, max_values => 10}}; -$e = &validate({foo => [1,2,3]}, $v); -&print_ok(! $e); +$e = validate({foo => [1,2,3]}, $v); +ok(! $e); -$e = &validate({foo => [1,2,3,4]}, $v); -&print_ok(! $e); +$e = validate({foo => [1,2,3,4]}, $v); +ok(! $e); -$e = &validate({foo => [1,2]}, $v); -&print_ok($e); +$e = validate({foo => [1,2]}, $v); +ok($e); -$e = &validate({foo => "str"}, $v); -&print_ok($e); +$e = validate({foo => "str"}, $v); +ok($e); -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); ### enum $v = {foo => {enum => [1, 2, 3]}, bar => {enum => "1 || 2||3"}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok(! $e); +$e = validate({foo => 1, bar => 1}, $v); +ok(! $e); -$e = &validate({foo => 1, bar => 2}, $v); -&print_ok(! $e); +$e = validate({foo => 1, bar => 2}, $v); +ok(! $e); -$e = &validate({foo => 1, bar => 3}, $v); -&print_ok(! $e); +$e = validate({foo => 1, bar => 3}, $v); +ok(! $e); -$e = &validate({foo => 1, bar => 4}, $v); -&print_ok($e); +$e = validate({foo => 1, bar => 4}, $v); +ok($e); # equals $v = {foo => {equals => 'bar'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({foo => 1}, $v); -&print_ok($e); +$e = validate({foo => 1}, $v); +ok($e); -$e = &validate({bar => 1}, $v); -&print_ok($e); +$e = validate({bar => 1}, $v); +ok($e); -$e = &validate({foo => 1, bar => 2}, $v); -&print_ok($e); +$e = validate({foo => 1, bar => 2}, $v); +ok($e); -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok(! $e); +$e = validate({foo => 1, bar => 1}, $v); +ok(! $e); $v = {foo => {equals => '"bar"'}}; -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok($e); +$e = validate({foo => 1, bar => 1}, $v); +ok($e); -$e = &validate({foo => 'bar', bar => 1}, $v); -&print_ok(! $e); +$e = validate({foo => 'bar', bar => 1}, $v); +ok(! $e); ### min_len $v = {foo => {min_len => 10}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({foo => ""}, $v); -&print_ok($e); +$e = validate({foo => ""}, $v); +ok($e); -$e = &validate({foo => "123456789"}, $v); -&print_ok($e); +$e = validate({foo => "123456789"}, $v); +ok($e); -$e = &validate({foo => "1234567890"}, $v); -&print_ok(! $e); +$e = validate({foo => "1234567890"}, $v); +ok(! $e); ### max_len $v = {foo => {max_len => 10}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({foo => ""}, $v); -&print_ok(! $e); +$e = validate({foo => ""}, $v); +ok(! $e); -$e = &validate({foo => "1234567890"}, $v); -&print_ok(! $e); +$e = validate({foo => "1234567890"}, $v); +ok(! $e); -$e = &validate({foo => "12345678901"}, $v); -&print_ok($e); +$e = validate({foo => "12345678901"}, $v); +ok($e); ### match $v = {foo => {match => qr/^\w+$/}}; -$e = &validate({foo => "abc"}, $v); -&print_ok(! $e); +$e = validate({foo => "abc"}, $v); +ok(! $e); -$e = &validate({foo => "abc."}, $v); -&print_ok($e); +$e = validate({foo => "abc."}, $v); +ok($e); $v = {foo => {match => [qr/^\w+$/, qr/^[a-z]+$/]}}; -$e = &validate({foo => "abc"}, $v); -&print_ok(! $e); +$e = validate({foo => "abc"}, $v); +ok(! $e); -$e = &validate({foo => "abc1"}, $v); -&print_ok($e); +$e = validate({foo => "abc1"}, $v); +ok($e); $v = {foo => {match => 'm/^\w+$/'}}; -$e = &validate({foo => "abc"}, $v); -&print_ok(! $e); +$e = validate({foo => "abc"}, $v); +ok(! $e); -$e = &validate({foo => "abc."}, $v); -&print_ok($e); +$e = validate({foo => "abc."}, $v); +ok($e); $v = {foo => {match => 'm/^\w+$/ || m/^[a-z]+$/'}}; -$e = &validate({foo => "abc"}, $v); -&print_ok(! $e); +$e = validate({foo => "abc"}, $v); +ok(! $e); -$e = &validate({foo => "abc1"}, $v); -&print_ok($e); +$e = validate({foo => "abc1"}, $v); +ok($e); $v = {foo => {match => '! m/^\w+$/'}}; -$e = &validate({foo => "abc"}, $v); -&print_ok($e); +$e = validate({foo => "abc"}, $v); +ok($e); -$e = &validate({foo => "abc."}, $v); -&print_ok(! $e); +$e = validate({foo => "abc."}, $v); +ok(! $e); $v = {foo => {match => 'm/^\w+$/'}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); $v = {foo => {match => '! m/^\w+$/'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); ### compare $v = {foo => {compare => '> 0'}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); $v = {foo => {compare => '== 0'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); $v = {foo => {compare => '< 0'}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); $v = {foo => {compare => '> 10'}}; -$e = &validate({foo => 11}, $v); -&print_ok(! $e); -$e = &validate({foo => 10}, $v); -&print_ok($e); +$e = validate({foo => 11}, $v); +ok(! $e); +$e = validate({foo => 10}, $v); +ok($e); $v = {foo => {compare => '== 10'}}; -$e = &validate({foo => 11}, $v); -&print_ok($e); -$e = &validate({foo => 10}, $v); -&print_ok(! $e); +$e = validate({foo => 11}, $v); +ok($e); +$e = validate({foo => 10}, $v); +ok(! $e); $v = {foo => {compare => '< 10'}}; -$e = &validate({foo => 9}, $v); -&print_ok(! $e); -$e = &validate({foo => 10}, $v); -&print_ok($e); +$e = validate({foo => 9}, $v); +ok(! $e); +$e = validate({foo => 10}, $v); +ok($e); $v = {foo => {compare => '>= 10'}}; -$e = &validate({foo => 10}, $v); -&print_ok(! $e); -$e = &validate({foo => 9}, $v); -&print_ok($e); +$e = validate({foo => 10}, $v); +ok(! $e); +$e = validate({foo => 9}, $v); +ok($e); $v = {foo => {compare => '!= 10'}}; -$e = &validate({foo => 10}, $v); -&print_ok($e); -$e = &validate({foo => 9}, $v); -&print_ok(! $e); +$e = validate({foo => 10}, $v); +ok($e); +$e = validate({foo => 9}, $v); +ok(! $e); $v = {foo => {compare => '<= 10'}}; -$e = &validate({foo => 11}, $v); -&print_ok($e); -$e = &validate({foo => 10}, $v); -&print_ok(! $e); +$e = validate({foo => 11}, $v); +ok($e); +$e = validate({foo => 10}, $v); +ok(! $e); $v = {foo => {compare => 'gt ""'}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); $v = {foo => {compare => 'eq ""'}}; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); $v = {foo => {compare => 'lt ""'}}; -$e = &validate({}, $v); -&print_ok($e); # 68 +$e = validate({}, $v); +ok($e); # 68 $v = {foo => {compare => 'gt "c"'}}; -$e = &validate({foo => 'd'}, $v); -&print_ok(! $e); -$e = &validate({foo => 'c'}, $v); -&print_ok($e); +$e = validate({foo => 'd'}, $v); +ok(! $e); +$e = validate({foo => 'c'}, $v); +ok($e); $v = {foo => {compare => 'eq c'}}; -$e = &validate({foo => 'd'}, $v); -&print_ok($e); -$e = &validate({foo => 'c'}, $v); -&print_ok(! $e); +$e = validate({foo => 'd'}, $v); +ok($e); +$e = validate({foo => 'c'}, $v); +ok(! $e); $v = {foo => {compare => 'lt c'}}; -$e = &validate({foo => 'b'}, $v); -&print_ok(! $e); -$e = &validate({foo => 'c'}, $v); -&print_ok($e); +$e = validate({foo => 'b'}, $v); +ok(! $e); +$e = validate({foo => 'c'}, $v); +ok($e); $v = {foo => {compare => 'ge c'}}; -$e = &validate({foo => 'c'}, $v); -&print_ok(! $e); -$e = &validate({foo => 'b'}, $v); -&print_ok($e); +$e = validate({foo => 'c'}, $v); +ok(! $e); +$e = validate({foo => 'b'}, $v); +ok($e); $v = {foo => {compare => 'ne c'}}; -$e = &validate({foo => 'c'}, $v); -&print_ok($e); -$e = &validate({foo => 'b'}, $v); -&print_ok(! $e); +$e = validate({foo => 'c'}, $v); +ok($e); +$e = validate({foo => 'b'}, $v); +ok(! $e); $v = {foo => {compare => 'le c'}}; -$e = &validate({foo => 'd'}, $v); -&print_ok($e); -$e = &validate({foo => 'c'}, $v); -&print_ok(! $e); # 80 +$e = validate({foo => 'd'}, $v); +ok($e); +$e = validate({foo => 'c'}, $v); +ok(! $e); # 80 ### sql ### can't really do anything here without prompting for a db connection @@ -302,77 +291,76 @@ $e = &validate({foo => 'c'}, $v); ### custom my $n = 1; $v = {foo => {custom => $n}}; -$e = &validate({}, $v); -&print_ok(! $e); -$e = &validate({foo => "str"}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); +$e = validate({foo => "str"}, $v); +ok(! $e); $n = 0; $v = {foo => {custom => $n}}; -$e = &validate({}, $v); -&print_ok($e); -$e = &validate({foo => "str"}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); +$e = validate({foo => "str"}, $v); +ok($e); $n = sub { my ($key, $val) = @_; return defined($val) ? 1 : 0}; $v = {foo => {custom => $n}}; -$e = &validate({}, $v); -&print_ok($e); -$e = &validate({foo => "str"}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok($e); +$e = validate({foo => "str"}, $v); +ok(! $e); ### type checks $v = {foo => {type => 'ip'}}; -$e = &validate({foo => '209.108.25'}, $v); -&print_ok($e); -$e = &validate({foo => '209.108.25.111'}, $v); -&print_ok(! $e); +$e = validate({foo => '209.108.25'}, $v); +ok($e); +$e = validate({foo => '209.108.25.111'}, $v); +ok(! $e); ### min_in_set checks $v = {foo => {min_in_set => '2 of foo bar baz', max_values => 5}}; -$e = &validate({foo => 1}, $v); -&print_ok($e); -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok(! $e); -$e = &validate({foo => 1, bar => ''}, $v); # empty string doesn't count as value -&print_ok($e); -$e = &validate({foo => 1, bar => 0}, $v); -&print_ok(! $e); -$e = &validate({foo => [1, 2]}, $v); -&print_ok(! $e); -$e = &validate({foo => [1]}, $v); -&print_ok($e); +$e = validate({foo => 1}, $v); +ok($e); +$e = validate({foo => 1, bar => 1}, $v); +ok(! $e); +$e = validate({foo => 1, bar => ''}, $v); # empty string doesn't count as value +ok($e); +$e = validate({foo => 1, bar => 0}, $v); +ok(! $e); +$e = validate({foo => [1, 2]}, $v); +ok(! $e); +$e = validate({foo => [1]}, $v); +ok($e); $v = {foo => {min_in_set => '2 foo bar baz', max_values => 5}}; -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok(! $e); +$e = validate({foo => 1, bar => 1}, $v); +ok(! $e); ### max_in_set checks $v = {foo => {max_in_set => '2 of foo bar baz', max_values => 5}}; -$e = &validate({foo => 1}, $v); -&print_ok(! $e); -$e = &validate({foo => 1, bar => 1}, $v); -&print_ok(! $e); -$e = &validate({foo => 1, bar => 1, baz => 1}, $v); -&print_ok($e); -$e = &validate({foo => [1, 2]}, $v); -&print_ok(! $e); -$e = &validate({foo => [1, 2, 3]}, $v); -&print_ok($e); +$e = validate({foo => 1}, $v); +ok(! $e); +$e = validate({foo => 1, bar => 1}, $v); +ok(! $e); +$e = validate({foo => 1, bar => 1, baz => 1}, $v); +ok($e); +$e = validate({foo => [1, 2]}, $v); +ok(! $e); +$e = validate({foo => [1, 2, 3]}, $v); +ok($e); ### validate_if revisited (but negated - uses max_in_set) $v = {foo => {required => 1, validate_if => '! bar'}}; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({bar => 1}, $v); -&print_ok(! $e); +$e = validate({bar => 1}, $v); +ok(! $e); ### default value my $f = {}; $v = {foo => {required => 1, default => 'hmmmm'}}; -$e = &validate($f, $v); -&print_ok(! $e); +$e = validate($f, $v); +ok(! $e); -&print_ok($f->{foo} && $f->{foo} eq 'hmmmm'); +ok($f->{foo} && $f->{foo} eq 'hmmmm'); -__DATA__ diff --git a/t/1_validate_06_groups.t b/t/1_validate_06_groups.t index 972624c..152cdad 100644 --- a/t/1_validate_06_groups.t +++ b/t/1_validate_06_groups.t @@ -1,30 +1,19 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +1_validate_06_groups.t - Test CGI::Ex::Validate's ability to use groups of validation -$^W = 1; +=cut -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +use strict; +use Test::More tests => 7; -require CGI::Ex::Validate; +use_ok('CGI::Ex::Validate'); -my ($N, $v, $e, $ok) = (0); +my ($v, $e); -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); +sub validate { scalar CGI::Ex::Validate::validate(@_) } ###----------------------------------------------------------------### @@ -41,42 +30,41 @@ $v = [{ raspberry => {required => 1}, }]; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({ +$e = validate({ raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, haw => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -__DATA__ diff --git a/t/1_validate_07_yaml.t b/t/1_validate_07_yaml.t index 61f9f1e..12d1c1f 100644 --- a/t/1_validate_07_yaml.t +++ b/t/1_validate_07_yaml.t @@ -1,30 +1,25 @@ # -*- Mode: Perl; -*- +=head1 NAME + +1_validate_07_yaml.t - Check for CGI::Ex::Validate's ability to use YAML. + +=cut + use strict; +use Test::More tests => 15; -$^W = 1; +SKIP: { -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +skip("Missing YAML.pm", 15) if ! eval { require 'YAML' }; -require CGI::Ex::Validate; +use_ok('CGI::Ex::Validate'); -my ($N, $v, $e, $ok) = (0); +my $N = 0; +my $v; +my $e; -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); +sub validate { scalar CGI::Ex::Validate::validate(@_) } ###----------------------------------------------------------------### @@ -36,14 +31,14 @@ foo: required_if: bar '; -$e = &validate({}, $v); -&print_ok($e); -$e = &validate({user => 1}, $v); -&print_ok(! $e); -$e = &validate({user => 1, bar => 1}, $v); -&print_ok($e); -$e = &validate({user => 1, bar => 1, foo => 1}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok($e); +$e = validate({user => 1}, $v); +ok(! $e); +$e = validate({user => 1, bar => 1}, $v); +ok($e); +$e = validate({user => 1, bar => 1, foo => 1}, $v); +ok(! $e); ### three groups, some with validate_if's - using arrayref @@ -57,43 +52,43 @@ $v = ' required: 1 '; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({ +$e = validate({ raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, haw => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); ### three groups, some with validate_if's - using documents @@ -109,42 +104,42 @@ raspberry: required: 1 '; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({ +$e = validate({ raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, haw => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -__DATA__ +} # end of SKIP diff --git a/t/1_validate_08_yaml_file.t b/t/1_validate_08_yaml_file.t index 8881462..e9c3ca0 100644 --- a/t/1_validate_08_yaml_file.t +++ b/t/1_validate_08_yaml_file.t @@ -1,146 +1,139 @@ # -*- Mode: Perl; -*- +=head1 NAME + +1_validate_08_yaml_file.t - Check for CGI::Ex::Validate's ability to load YAML conf files. + +=cut + use strict; +use Test::More tests => 22; -$^W = 1; +SKIP: { -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +skip("Missing YAML.pm", 22) if ! eval { require 'YAML' }; -require CGI::Ex::Validate; +use_ok('CGI::Ex::Validate'); -my ($N, $v, $e, $ok) = (0); +my ($v, $e); -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); +sub validate { scalar CGI::Ex::Validate::validate(@_) } ###----------------------------------------------------------------### ### where are my samples my $dir = __FILE__; $dir =~ tr|\\|/|; # should probably use File::Spec -$dir =~ s|[^/]+$|samples| || die "Couldn't determine dir"; +$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir"; $dir =~ s|^t/|./t/|; # to satisfy conf ### single group $v = "$dir/yaml1.val"; -$e = &validate({}, $v); -&print_ok($e); -$e = &validate({user => 1}, $v); -&print_ok(! $e); -$e = &validate({user => 1, bar => 1}, $v); -&print_ok($e); -$e = &validate({user => 1, bar => 1, foo => 1}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok($e, 'nothing passed'); +$e = validate({user => 1}, $v); +ok(! $e, 'user passed'); +$e = validate({user => 1, bar => 1}, $v); +ok($e, 'user and bar passed'); +$e = validate({user => 1, bar => 1, foo => 1}, $v); +ok(! $e, 'user and bar and foo passed'); ### single group - default extension $v = "$dir/yaml1"; -$e = &validate({}, $v); -&print_ok($e); -$e = &validate({user => 1}, $v); -&print_ok(! $e); -$e = &validate({user => 1, bar => 1}, $v); -&print_ok($e); -$e = &validate({user => 1, bar => 1, foo => 1}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok($e); +$e = validate({user => 1}, $v); +ok(! $e); +$e = validate({user => 1, bar => 1}, $v); +ok($e); +$e = validate({user => 1, bar => 1, foo => 1}, $v); +ok(! $e); ### three groups, some with validate_if's - using arrayref $v = "$dir/yaml2.val"; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({ +$e = validate({ raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, haw => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); ### three groups, some with validate_if's - using documents $v = "$dir/yaml3.val"; -$e = &validate({}, $v); -&print_ok($e); +$e = validate({}, $v); +ok($e); -$e = &validate({ +$e = validate({ raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, raspberry => 'tart', }, $v); -&print_ok($e); +ok($e); -$e = &validate({ +$e = validate({ foo => 1, bar => 1, hem => 1, haw => 1, raspberry => 'tart', }, $v); -&print_ok(! $e); +ok(! $e); -__DATA__ +} # end of SKIP diff --git a/t/1_validate_11_no_extra.t b/t/1_validate_11_no_extra.t index 46ca0e6..c7a8d0c 100644 --- a/t/1_validate_11_no_extra.t +++ b/t/1_validate_11_no_extra.t @@ -1,30 +1,19 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +1_validate_11_no_extra.t - Test CGI::Ex::Validate's ability to not allow extra form fields -$^W = 1; +=cut -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +use strict; +use Test::More tests => 21; -require CGI::Ex::Validate; +use_ok('CGI::Ex::Validate'); -my ($N, $v, $e, $ok) = (0); +my ($v, $e); -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); +sub validate { CGI::Ex::Validate::validate(@_) } ###----------------------------------------------------------------### @@ -36,17 +25,17 @@ $v = [ }, ]; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({foo => "foo"}, $v); -&print_ok(! $e); +$e = validate({foo => "foo"}, $v); +ok(! $e); -$e = &validate({foo => "foo", bar => "bar"}, $v); -&print_ok($e); +$e = validate({foo => "foo", bar => "bar"}, $v); +ok($e); -$e = &validate({bar => "bar"}, $v); -&print_ok($e); +$e = validate({bar => "bar"}, $v); +ok($e); ### test on failed validate if @@ -58,17 +47,17 @@ $v = [ }, ]; -$e = &validate({}, $v); -&print_ok(! $e); +$e = validate({}, $v); +ok(! $e); -$e = &validate({foo => "foo"}, $v); -&print_ok(! $e); +$e = validate({foo => "foo"}, $v); +ok(! $e); -$e = &validate({foo => "foo", bar => "bar"}, $v); -&print_ok(! $e); +$e = validate({foo => "foo", bar => "bar"}, $v); +ok(! $e); -$e = &validate({bar => "bar"}, $v); -&print_ok(! $e); +$e = validate({bar => "bar"}, $v); +ok(! $e); ### test on successful validate if $v = [ @@ -80,17 +69,17 @@ $v = [ }, ]; -$e = &validate({baz => 1}, $v); -&print_ok(! $e); +$e = validate({baz => 1}, $v); +ok(! $e); -$e = &validate({baz => 1, foo => "foo"}, $v); -&print_ok(! $e); +$e = validate({baz => 1, foo => "foo"}, $v); +ok(! $e); -$e = &validate({baz => 1, foo => "foo", bar => "bar"}, $v); -&print_ok($e); +$e = validate({baz => 1, foo => "foo", bar => "bar"}, $v); +ok($e); -$e = &validate({baz => 1, bar => "bar"}, $v); -&print_ok($e); +$e = validate({baz => 1, bar => "bar"}, $v); +ok($e); ### test on multiple groups, some with validate if $v = [ @@ -106,17 +95,17 @@ $v = [ }, ]; -$e = &validate({haw => 1, baz => 1}, $v); -&print_ok(! $e); +$e = validate({haw => 1, baz => 1}, $v); +ok(! $e); -$e = &validate({haw => 1, baz => 1, foo => "foo"}, $v); -&print_ok(! $e); +$e = validate({haw => 1, baz => 1, foo => "foo"}, $v); +ok(! $e); -$e = &validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v); -&print_ok($e); +$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v); +ok($e); -$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v); -&print_ok($e); +$e = validate({haw => 1, baz => 1, bar => "bar"}, $v); +ok($e); ### test on multiple groups, some with validate if @@ -133,16 +122,14 @@ $v = [ }, ]; -$e = &validate({haw => 1, baz => 1}, $v); -&print_ok($e); - -$e = &validate({haw => 1, baz => 1, foo => "foo"}, $v); -&print_ok($e); +$e = validate({haw => 1, baz => 1}, $v); +ok($e); -$e = &validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v); -&print_ok($e); +$e = validate({haw => 1, baz => 1, foo => "foo"}, $v); +ok($e); -$e = &validate({haw => 1, baz => 1, bar => "bar"}, $v); -&print_ok($e); +$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v); +ok($e); -__DATA__ +$e = validate({haw => 1, baz => 1, bar => "bar"}, $v); +ok($e); diff --git a/t/1_validate_12_change.t b/t/1_validate_12_change.t index e577b0d..06784d6 100644 --- a/t/1_validate_12_change.t +++ b/t/1_validate_12_change.t @@ -1,30 +1,20 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +1_validate_12_change.t - Test CGI::Ex::Validate's ability to modify form fields -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /&print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +=cut -require CGI::Ex::Validate; +use strict; +use Test::More tests => 5; +use strict; -my ($N, $v, $e, $ok) = (0); +use_ok('CGI::Ex::Validate'); +my $e; +my $v; +sub validate { scalar CGI::Ex::Validate::validate(@_) } -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); ###----------------------------------------------------------------### @@ -37,10 +27,10 @@ $v = [ }, ]; -$e = &validate({ +$e = validate({ foo => '123-456-7890', }, $v); -&print_ok(! $e); +ok(! $e); my $form = { @@ -55,8 +45,8 @@ $v = { }, }; -$e = &validate($form, $v); -&print_ok(! $e && $form->{key1} eq 'Bunch of characters'); +$e = validate($form, $v); +ok(! $e && $form->{key1} eq 'Bunch of characters'); $v = { key2 => { @@ -64,8 +54,8 @@ $v = { }, }; -$e = &validate($form, $v); -&print_ok(! $e && $form->{key2} eq '(123) 456-7890'); +$e = validate($form, $v); +ok(! $e && $form->{key2} eq '(123) 456-7890'); $v = { @@ -75,7 +65,6 @@ $v = { }, }; -$e = &validate($form, $v); -&print_ok($e && $form->{key2} eq ''); +$e = validate($form, $v); +ok($e && $form->{key2} eq ''); -__DATA__ diff --git a/t/1_validate_14_untaint.t b/t/1_validate_14_untaint.t index 59d256d..0af323b 100644 --- a/t/1_validate_14_untaint.t +++ b/t/1_validate_14_untaint.t @@ -1,12 +1,21 @@ #!perl -T # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +1_validate_14_untaint.t - Test CGI::Ex::Validate's ability to untaint tested fields -$^W = 1; +=cut + +use strict; +use Test::More tests => 14; +use FindBin qw($Bin); +use lib ($Bin =~ /(.+)/ ? "$1/../lib" : ''); # add bin - but untaint it ### Set up taint checking -sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 } } +sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1; 0 } } + +SKIP: { my $taint = join(",", $0, %ENV, @ARGV); if (! is_tainted($taint) && open(my $fh, "/dev/urandom")) { @@ -14,8 +23,7 @@ if (! is_tainted($taint) && open(my $fh, "/dev/urandom")) { } $taint = substr($taint, 0, 0); if (! is_tainted($taint)) { - print "1..1\nok 1 # skip Couldn't get any tainted data or we aren't in taint mode\n"; - exit; + skip("is_tainted doesn't appear to work", 14); } ### make sure tainted hash values don't bleed into other values @@ -23,83 +31,68 @@ my $form = {}; $form->{'foo'} = "123$taint"; $form->{'bar'} = "456$taint"; $form->{'baz'} = "789"; -if (! is_tainted($form->{'foo'}) - || is_tainted($form->{'baz'})) { - # untaint checking doesn't really work - print "1..1\nok 1 # skip Hashes with mixed taint don't work right (older perls ?)\n"; - exit; +if (! is_tainted($form->{'foo'})) { + skip("Tainted hash key didn't work right", 14); +} elsif (is_tainted($form->{'baz'})) { + # untaint checking doesn't really work + skip("Hashes with mixed taint don't work right", 14); } ###----------------------------------------------------------------### ### Looks good - here we go -### determine number of tests -seek(DATA,0,0); -my $prog = join "", ; -my @tests = ($prog =~ /print_ok\(/g); -my $tests = @tests; -print "1..$tests\n"; +use_ok('CGI::Ex::Validate'); -require CGI::Ex::Validate; +my $e; -my ($N, $v, $e, $ok) = (0); +ok(is_tainted($taint)); +ok(is_tainted($form->{'foo'})); +ok(! is_tainted($form->{'baz'})); +ok(! is_tainted($form->{'non_existent_key'})); +sub validate { scalar CGI::Ex::Validate::validate(@_) } -print_ok(is_tainted($taint)); -print_ok(is_tainted($form->{'foo'})); -print_ok(! is_tainted($form->{'baz'})); -print_ok(! is_tainted($form->{'non_existent_key'})); - -sub validate { - return scalar &CGI::Ex::Validate::validate(@_); -} -sub print_ok { - my $ok = shift; - $N ++; - warn "Test failed at line ".(caller)[2]."\n" if ! $ok; - print "" . ($ok ? "" : "not ") . "ok $N\n"; -} -&print_ok(1); ###----------------------------------------------------------------### -$e = &validate($form, { +$e = validate($form, { foo => { match => 'm/^\d+$/', untaint => 1, }, }); -print_ok(! $e); -print_ok(! is_tainted($form->{foo})); +ok(! $e); +ok(! is_tainted($form->{foo})); ###----------------------------------------------------------------### -$e = &validate($form, { +$e = validate($form, { bar => { match => 'm/^\d+$/', }, }); -print_ok(! $e); -print_ok(is_tainted($form->{bar})); +ok(! $e); +ok(is_tainted($form->{bar})); ###----------------------------------------------------------------### -$e = &validate($form, { +$e = validate($form, { bar => { untaint => 1, }, }); -print_ok($e); +ok($e); #print $e if $e; -print_ok(is_tainted($form->{bar})); +ok(is_tainted($form->{bar})); ###----------------------------------------------------------------### -print_ok(!is_tainted($form->{foo})); -print_ok( is_tainted($form->{bar})); -print_ok(!is_tainted($form->{baz})); +ok(!is_tainted($form->{foo})); +ok( is_tainted($form->{bar})); +ok(!is_tainted($form->{baz})); + +} -__DATA__ diff --git a/t/2_fill_00_base.t b/t/2_fill_00_base.t index bb1348f..bf955b2 100644 --- a/t/2_fill_00_base.t +++ b/t/2_fill_00_base.t @@ -1,8 +1,149 @@ +# -*-perl-*- -BEGIN { - print "1..1\n"; -} +=head1 NAME -use CGI::Ex::Fill; +2_fill_00_base.t - Test CGI::Ex::Fill's base ability. -BEGIN { print "ok 1\n"; } +=cut + +use strict; +use Test::More tests => 6; + +use_ok qw(CGI::Ex::Fill); + +###----------------------------------------------------------------### + + my $form = {foo => "FOO", bar => "BAR", baz => "BAZ"}; + + my $html = ' + + + + + + + '; + + CGI::Ex::Fill::form_fill(\$html, $form); + + ok( + $html eq ' + + + + + + + ', "perldoc example 1 passed"); + + #print $html; + +###----------------------------------------------------------------### + + $form = {foo => ['aaaa', 'bbbb', 'cccc']}; + + $html = ' + + + + + + '; + + form_fill(\$html, $form); + + ok( + $html eq ' + + + + + + ', "Perldoc example 2 passed"); + + #print $html; + +###----------------------------------------------------------------### + + $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc'], baz => 'on'}; + + $html = ' + + + + + + + '; + + form_fill(\$html, $form); + + ok( + $html eq ' + + + + + + + ', "Perldoc example 3 passed"); + + #print $html; + +###----------------------------------------------------------------### + + $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc']}; + + $html = ' + + + + + + '; + + form_fill(\$html, $form); + + ok( + $html eq ' + + + + + + ', "Perldoc example 4 passed"); + +# print $html; + +###----------------------------------------------------------------### + + $form = {foo => 'FOO', bar => ['aaaa', 'bbbb']}; + + $html = ' + + + +
+
+ + + +
+
+ }; 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"; -} +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output eq '', + "Output should match ($output)"); # empty fdat test %fdat = (foo => ''); -$fif = new CGI::Ex; -$output = $fif->fill(scalarref => \$hidden_form_in, - fdat => \%fdat); -if ($output eq ''){ - print "ok 3\n"; -} else { - print "Got unexpected out for $hidden_form_in:\n$output\n"; - print "not ok 3\n"; -} +$output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output eq '', + "Output should match ($output)"); diff --git a/t/2_fill_06_radio.t b/t/2_fill_06_radio.t index 53ba4ad..3ae260a 100644 --- a/t/2_fill_06_radio.t +++ b/t/2_fill_06_radio.t @@ -1,14 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +2_fill_06_radio.t - Test CGI::Ex::Fill's ability to fill radio fields -print "1..2\n"; +=cut -use CGI::Ex; +use strict; +use Test::More tests => 2; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $hidden_form_in = qq{ @@ -17,13 +18,8 @@ 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 $output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); my $is_checked = join(" ",map { m/checked/ ? "yes" : "no" } split ("\n",$output)); -if ($is_checked eq 'no yes no no'){ - print "ok 2\n"; -} else { - print "Got unexpected is_checked:\n$is_checked\n"; - print "not ok 2\n"; -} +ok($is_checked eq 'no yes no no', + "Should match ($is_checked)"); diff --git a/t/2_fill_07_reuse.t b/t/2_fill_07_reuse.t index 56d97ea..8e60c34 100644 --- a/t/2_fill_07_reuse.t +++ b/t/2_fill_07_reuse.t @@ -1,14 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +2_fill_02_hidden.t - Test CGI::Ex::Fill's ability to fill refill used fields -print "1..2\n"; +=cut -use CGI::Ex; +use strict; +use Test::More tests => 2; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $hidden_form_in = qq{ }; @@ -16,14 +17,9 @@ 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"; -} +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +my $output2 = CGI::Ex::Fill::form_fill($output, + \%fdat); +ok($output2 =~ m/^\s*$/i, + "Should match ($output2)"); diff --git a/t/2_fill_08_multiple_objects.t b/t/2_fill_08_multiple_objects.t index c26cf13..28548ab 100644 --- a/t/2_fill_08_multiple_objects.t +++ b/t/2_fill_08_multiple_objects.t @@ -1,31 +1,32 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +2_fill_08_multiple_objects.t - Test CGI::Ex::Fill's ability to fill using multiple form objects -$^W = 1; +=cut + +use strict; +use Test::More tests => 2; -print "1..2\n"; +use_ok('CGI::Ex::Fill'); -use CGI::Ex; -use CGI; +SKIP: { -print "ok 1\n"; +skip('CGI.pm not found', 1) if ! eval { require CGI }; my $hidden_form_in = qq{ }; 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"; -} + foo2 => 'bar2'); + +my $q1 = CGI->new({ foo1 => 'bar1' }); +my $q2 = CGI->new({ foo2 => 'bar2' }); + +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + [$q1, $q2]); +ok($output =~ m/^\s*$/i, + "Should match ($output)"); + +}; #end of SKIP diff --git a/t/2_fill_09_default_type.t b/t/2_fill_09_default_type.t index 5db1f59..1320fdb 100644 --- a/t/2_fill_09_default_type.t +++ b/t/2_fill_09_default_type.t @@ -1,14 +1,16 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +2_fill_09_default_type.t - Test CGI::Ex::Fill's ability to set default falues -$^W = 1; +=cut -print "1..2\n"; +use strict; +use Test::More tests => 2; -use CGI::Ex; +use_ok('CGI::Ex::Fill'); -print "ok 1\n"; my $hidden_form_in = qq{ }; @@ -16,12 +18,7 @@ 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"; -} +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output =~ m/^\s*$/i, + "Should match ($output)"); diff --git a/t/2_fill_10_escape.t b/t/2_fill_10_escape.t index fbacf04..e32fc9f 100644 --- a/t/2_fill_10_escape.t +++ b/t/2_fill_10_escape.t @@ -1,10 +1,16 @@ # -*- Mode: Perl; -*- +=head1 NAME + +2_fill_10_escape.t - Make sure CGI::Ex::Fill works with escaped values. + +=cut + use strict; +use Test::More tests => 2; + +use_ok('CGI::Ex::Fill'); -print "1..1\n"; -use CGI::Ex; - my $html =<<"__HTML__"; @@ -29,15 +35,12 @@ __HTML__ my %fdat = (); -my $fif = CGI::Ex->new; -my $output = $fif->fill(scalarref => \$html, - fdat => \%fdat); +my $output = CGI::Ex::Fill::form_fill($html, + \%fdat); # FIF changes order of HTML attributes, so split strings and sort my $strings_output = join("\n", sort split(/[\s><]+/, lc($output))); my $strings_html = join("\n", sort split(/[\s><]+/, lc($html))); -unless ($strings_output eq $strings_html){ - print "not "; -} -print "ok 1"; +ok($strings_output eq $strings_html, + "Strings matched"); diff --git a/t/2_fill_11_target.t b/t/2_fill_11_target.t index 4a270de..a1083b6 100644 --- a/t/2_fill_11_target.t +++ b/t/2_fill_11_target.t @@ -1,10 +1,15 @@ # -*- Mode: Perl; -*- +=head1 NAME + +2_fill_11_target.t - Test CGI::Ex::Fill's ability to fill hidden fields + +=cut + use strict; -use Test; -BEGIN { plan tests => 3 } +use Test::More tests => 4; -use CGI::Ex; +use_ok('CGI::Ex::Fill'); my $form = < @@ -18,21 +23,16 @@ 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 $output = CGI::Ex::Fill::form_fill($form, \%fdat, 'foo2'); my @v = $output =~ m/ 4; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $hidden_form_in = qq{ }; 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"; -} +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output =~ m/^\s*$/i, + "Should match ($output)"); + %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"; -} +$output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output =~ m/^\s*$/i, + "Should match ($output)"); + +%fdat = (foo1 => 'bar1'); + +$output = CGI::Ex::Fill::form_fill($hidden_form_in, + \%fdat); +ok($output =~ m/^\s*$/i, + "Should match ($output)"); diff --git a/t/2_fill_13_warning.t b/t/2_fill_13_warning.t index 882df15..beb4010 100644 --- a/t/2_fill_13_warning.t +++ b/t/2_fill_13_warning.t @@ -1,25 +1,29 @@ # -*- Mode: Perl; -*- -#!/usr/bin/perl -w +=head1 NAME + +2_fill_13_warning.t - Check for no warning on a special case - I can't remember what it was though + +=cut + +use strict; +use Test::More tests => 2; # emits warnings for HTML::FIF <= 0.22 -use CGI qw(:no_debug); -use CGI::Ex; -use Test; - -BEGIN { plan tests => 1 } - -local $/; -my $html = qq{}; - -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!!); +use_ok('CGI::Ex::Fill'); + +SKIP: { + skip("CGI.pm not found", 1) if ! eval { require CGI }; + CGI->import(':no_debug'); + + local $/; + my $html = qq{}; + + my $q = CGI->new; + + $q->param( "name", "John Smith" ); + my $output = CGI::Ex::Fill::form_fill($html, $q); + + ok($html =~ m!!); +}; diff --git a/t/2_fill_14_password.t b/t/2_fill_14_password.t index ddb56f6..a1857ac 100644 --- a/t/2_fill_14_password.t +++ b/t/2_fill_14_password.t @@ -1,39 +1,25 @@ # -*- Mode: Perl; -*- -#!/usr/bin/perl -w +=head1 NAME -use CGI qw(:no_debug); -use CGI::Ex; -use Test; +2_fill_13_password.t - Test CGI::Ex::Fill's ability to not fill passwords -BEGIN { plan tests => 2 } +=cut + +use strict; +use Test::More tests => 3; + +use_ok('CGI::Ex::Fill'); local $/; my $html = qq{}; -my $q = new CGI; -$q->param( foo => 'bar' ); - -{ - my $fif = new CGI::Ex; - my $output = $fif->fill( - scalarref => \$html, - fobject => $q, - fill_password => 0, - ); - - ok($output !~ /value="bar"/); -} - - -{ - my $fif = new CGI::Ex; - my $output = $fif->fill( - scalarref => \$html, - fobject => $q, -# fill_password => 1, - ); - - ok($output =~ /value="bar"/); -} +my $q = {foo => 'bar'}; + +my $output = CGI::Ex::Fill::form_fill($html, $q, undef, 0); +ok($output !~ /value="bar"/); + +$output = CGI::Ex::Fill::form_fill($html, $q, undef); +ok($output =~ /value="bar"/); + diff --git a/t/2_fill_16_ignore_fields.t b/t/2_fill_16_ignore_fields.t index 56ffe44..4bcf43d 100644 --- a/t/2_fill_16_ignore_fields.t +++ b/t/2_fill_16_ignore_fields.t @@ -1,15 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +2_fill_16_ignore_fields.t - Test CGI::Ex::Fill's ability to fill ignore some fields -print "1..2\n"; +=cut -use CGI::Ex; -use CGI; +use strict; +use Test::More tests => 2; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $hidden_form_in = qq{ }; -my $q = new CGI( { foo1 => '0', - foo2 => ['bar1', 'bar2',], - foo3 => '' } - ); +my $q = { + foo1 => '0', + foo2 => ['bar1', 'bar2',], + foo3 => '', +}; -my $fif = new CGI::Ex; -my $output = $fif->fill(scalarref => \$hidden_form_in, - fobject => $q, - ignore_fields => ['asdf','foo1','asdf']); +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, $q, undef, undef, ['asdf','foo1','asdf']); my $is_selected = join(" ",map { m/selected/ ? "yes" : "no" } grep /option/, split ("\n",$output)); -if ($is_selected eq "no no no yes yes no no no no no yes no"){ - print "ok 2\n"; -} else { - print "Got unexpected is_seleced for select menus:\n$is_selected\n$output\n"; - print "not ok 2\n"; -} - +ok($is_selected eq "no no no yes yes no no no no no yes no", + "Should match ($is_selected)"); diff --git a/t/2_fill_17_xhtml.t b/t/2_fill_17_xhtml.t index 5fde93b..4e4b105 100644 --- a/t/2_fill_17_xhtml.t +++ b/t/2_fill_17_xhtml.t @@ -1,13 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME + +2_fill_17_xhtml.t - Test CGI::Ex::Fill's ability to play nice with XHTML -$^W = 1; +=cut -print "1..1\n"; +use strict; +use Test::More tests => 2; -use CGI::Ex; -use CGI; +use_ok('CGI::Ex::Fill'); my $html = < EOF -my $q = CGI->new; -$q->param('status', 1 ); +my $q = { + status => 1, +}; -my $fif = CGI::Ex->new; - -my $output = $fif->fill( - scalarref => \$html, - fobject => $q -); +my $output = CGI::Ex::Fill::form_fill($html, $q); my $matches; while ($output =~ m!( />)!g) { $matches++; } -if ($matches == 6) { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} - -print $output; +ok($matches == 6, + "Had correct matches ($output)"); diff --git a/t/2_fill_18_coderef.t b/t/2_fill_18_coderef.t index f09b3b0..46556fe 100644 --- a/t/2_fill_18_coderef.t +++ b/t/2_fill_18_coderef.t @@ -1,14 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +2_fill_18_coderef.t - Test CGI::Ex::Fill's ability to use coderef callbacks -print "1..4\n"; +=cut -use CGI::Ex; +use strict; +use Test::More tests => 4; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $ok2 = 0; my $ok3 = 0; @@ -24,16 +25,12 @@ my $cdat = sub { return ($key eq 'foo2') ? 'bar2' : ''; }; -my $fif = new CGI::Ex; -my $output = $fif->fill(scalarref => \$hidden_form_in, - fdat => [\%fdat, $cdat]); +my $output = CGI::Ex::Fill::form_fill($hidden_form_in, + [\%fdat, $cdat]); + +ok($ok2); +ok($ok3); -print "" . ($ok2 ? "" : "not ") . "ok 2\n"; -print "" . ($ok3 ? "" : "not ") . "ok 3\n"; +ok($output =~ m/^\s*$/, + "Should match ($output)"); -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 index 7a86735..4852f57 100644 --- a/t/2_fill_19_complex.t +++ b/t/2_fill_19_complex.t @@ -1,14 +1,15 @@ # -*- Mode: Perl; -*- -use strict; +=head1 NAME -$^W = 1; +2_fill_19_complex.t - Test CGI::Ex::Fill's regex against difficult tags (with embeded html) -print "1..2\n"; +=cut -use CGI::Ex; +use strict; +use Test::More tests => 2; -print "ok 1\n"; +use_ok('CGI::Ex::Fill'); my $string = qq{ 27; + +use_ok('CGI::Ex::Fill'); my $string; my %fdat = (foo1 => 'bar1'); -my $cgix = new CGI::Ex; -my $n = 1; -my $dook = sub { - $n ++; - print "$n - ($string)\n"; +my $do_ok = sub { my @a; - if ($string =~ m/ value=([\"\'])bar1\1/i - && 1 == scalar(@a=$string =~ m/(value)/gi)) { - print "ok $n\n"; - } else { - print "not ok $n\n"; - } + ok($string =~ m/ value=([\"\'])bar1\1/i + && 1 == scalar(@a=$string =~ m/(value)/gi), "Should match ($string)"); }; ###----------------------------------------------------------------### $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); $string = qq{}; -$cgix->fill(text => \$string, form => \%fdat); -&$dook(); +CGI::Ex::Fill::form_fill(\$string, \%fdat); +$do_ok->(); diff --git a/t/3_conf_00_base.t b/t/3_conf_00_base.t index 31591c0..cae8b75 100644 --- a/t/3_conf_00_base.t +++ b/t/3_conf_00_base.t @@ -1,17 +1,21 @@ # -*- Mode: Perl; -*- -use Test; +=head1 NAME -BEGIN {plan tests => 24}; +3_conf_00_base.t - Test for the basic functionality of CGI::Ex::Conf -use CGI::Ex::Conf; -ok(1); +=cut -my $dir = $0; +use strict; +use Test::More tests => 24; + +use_ok('CGI::Ex::Conf'); + +my $dir = __FILE__; $dir =~ tr|\\|/|; # should probably use File::Spec -$dir =~ s|/[^/]+$||; -$dir = '.' if ! length $dir; -$dir .= '/samples'; +$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir"; +$dir =~ s|^t/|./t/|; # to satisfy conf + my $obj = CGI::Ex::Conf->new({ paths => ["$dir/conf_path_1", "$dir/conf_path_3"], }); diff --git a/t/3_conf_01_write.t b/t/3_conf_01_write.t index d77c83a..c31bfe4 100644 --- a/t/3_conf_01_write.t +++ b/t/3_conf_01_write.t @@ -1,17 +1,21 @@ # -*- Mode: Perl; -*- -use Test; +=head1 NAME -BEGIN {plan tests => 12}; +3_conf_01_write.t - Test CGI::Ex::Conf's ability to write and read the various file types. -use CGI::Ex::Conf; -ok(1); +=cut -my $dir = $0; +use strict; +use Test::More tests => 18; + +use_ok('CGI::Ex::Conf'); + +my $dir = __FILE__; $dir =~ tr|\\|/|; # should probably use File::Spec -$dir =~ s|/[^/]+$||; -$dir = '.' if ! length $dir; -$dir .= '/samples'; +$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir"; +$dir =~ s|^t/|./t/|; # to satisfy conf + my $obj = CGI::Ex::Conf->new({ paths => ["$dir/conf_path_1", "$dir/conf_path_3"], }); @@ -30,18 +34,8 @@ my $hash = { bar => 'Bar', }, }; - -my $file = $tmpfile .'.yaml'; -ok( eval { $obj->write_ref($file, $hash) } ); -my $in = $obj->read_ref($file); -ok($in->{'three'}->{'foo'} eq 'Foo'); -unlink $file; - -$file = $tmpfile .'.sto'; -ok( eval { $obj->write_ref($file, $hash) } ); -$in = $obj->read_ref($file); -ok($in->{'three'}->{'foo'} eq 'Foo'); -unlink $file; +my $file; +my $in; $file = $tmpfile .'.pl'; ok( eval { $obj->write_ref($file, $hash) } ); @@ -49,23 +43,59 @@ $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'); +SKIP: { + skip("YAML.pm not found", 2) if ! eval { require YAML }; + my $file = $tmpfile .'.yaml'; + ok( eval { $obj->write_ref($file, $hash) } ); + my $in = $obj->read_ref($file); + ok($in->{'three'}->{'foo'} eq 'Foo'); + unlink $file; +}; + +SKIP: { + skip("JSON.pm not found", 2) if ! eval { require JSON }; + my $file = $tmpfile .'.json'; + ok( eval { $obj->write_ref($file, $hash) } ); + my $in = $obj->read_ref($file); + ok($in->{'three'}->{'foo'} eq 'Foo'); + unlink $file; +}; + +SKIP: { + skip("Storable.pm not found", 2) if ! eval { require Storable }; + $file = $tmpfile .'.sto'; + ok( eval { $obj->write_ref($file, $hash) } ); + $in = $obj->read_ref($file); + ok($in->{'three'}->{'foo'} eq 'Foo'); + unlink $file; +}; + +SKIP: { + skip("XML::Simple not found", 2) if ! eval { require XML::Simple }; + $file = $tmpfile .'.xml'; + ok( eval { $obj->write_ref($file, $hash) } ); + $in = $obj->read_ref($file); + ok($in->{'three'}->{'foo'} eq 'Foo'); + unlink $file; +}; + +SKIP: { + skip("Config::IniHash not found", 2) if ! eval { require Conifg::IniHash }; + ### ini likes hash O' hashes + $hash->{'one'} = {}; + $hash->{'two'} = {}; + $file = $tmpfile .'.ini'; + ok( eval { $obj->write_ref($file, $hash) } ); + $in = $obj->read_ref($file); + ok($in->{'three'}->{'foo'} eq 'Foo'); + unlink $file; +}; + +SKIP: { + skip('YAML.pm still not found', 4) if ! eval { require YAML }; + ok (eval { $obj->write('FooSpace', $hash) }); + ok (unlink $obj->{'paths'}->[1] . '/FooSpace.conf'); + + ok (eval { $obj->write('FooSpace', $hash, {directive => 'FIRST'}) }); + ok (unlink $obj->{'paths'}->[0] . '/FooSpace.conf'); +}; diff --git a/t/4_app_00_base.t b/t/4_app_00_base.t index 2e3170a..59bfa52 100644 --- a/t/4_app_00_base.t +++ b/t/4_app_00_base.t @@ -1,12 +1,83 @@ # -*- Mode: Perl; -*- -use Test; +=head1 NAME -BEGIN {plan tests => 2}; +4_app_00_base.t - Check for the basic functionality of CGI::Ex::App. -use CGI::Ex::App; -ok(1); +=cut -my $obj = CGI::Ex::App->new({ -}); -ok($obj); +use Test::More tests => 3; +use strict; + +{ + package Foo; + + use base qw(CGI::Ex::App); + use vars qw($test_stdout); + + sub ready_validate { 1 } + + sub print_out { + my $self = shift; + my $step = shift; + $test_stdout = shift; + } + + sub swap_template { + my ($self, $step, $file, $swap) = @_; + my $out = ref($file) ? $$file : "No filenames allowed during test mode"; + $self->cgix->swap_template(\$out, $swap); + return $out; + } + + ###----------------------------------------------------------------### + + sub main_info_complete { 0 } + + sub main_file_print { return \ "Main Content" } + + sub step2_hash_validation { return {wow => {required => 1, required_error => 'wow is required'}} } + + sub step2_file_print { return \ "Some step2 content ([% foo %], [% one %]) [% wow_error %]" } + + sub step2_hash_swap { return {foo => 'bar', one => 'two'} } + + sub step2_hash_fill { return {wow => 'wee'} } + + sub step2_finalize { shift->append_path('step3') } + + sub step3_info_complete { 0 } + + sub step3_file_print { return \ "All good" } + +} + +###----------------------------------------------------------------### + +#$ENV{'REQUEST_METHOD'} = 'GET'; +#$ENV{'QUERY_STRING'} = ''; + +Foo->new({ + form => {}, +})->navigate; +ok($Foo::test_stdout eq "Main Content"); + +###----------------------------------------------------------------### + +#$ENV{'REQUEST_METHOD'} = 'GET'; +#$ENV{'QUERY_STRING'} = 'step=step2'; + +Foo->new({ + form => {step => 'step2'}, +})->navigate; +ok($Foo::test_stdout eq "Some step2 content (bar, two) wow is required"); + +###----------------------------------------------------------------### + +#$ENV{'REQUEST_METHOD'} = 'GET'; +#$ENV{'QUERY_STRING'} = 'step=step2&wow=something'; + +Foo->new({ + form=> {step => 'step2', wow => 'something'}, +})->navigate; +ok($Foo::test_stdout eq "All good"); diff --git a/t/5_dump_00_base.t b/t/5_dump_00_base.t index 50cd4a2..a0782a4 100644 --- a/t/5_dump_00_base.t +++ b/t/5_dump_00_base.t @@ -1,9 +1,12 @@ # -*- Mode: Perl; -*- -use Test; +=head1 NAME -BEGIN {plan tests => 1}; +5_dump_00_base.t - Very basic testing of CGI::Ex::Dump. -use CGI::Ex::Dump (); -ok(1); +=cut + +use Test::More tests => 1; + +use_ok('CGI::Ex::Dump'); diff --git a/t/6_die_00_base.t b/t/6_die_00_base.t index cca35e7..cacfab5 100644 --- a/t/6_die_00_base.t +++ b/t/6_die_00_base.t @@ -1,11 +1,14 @@ # -*- Mode: Perl; -*- -use Test; +=head1 NAME -BEGIN {plan tests => 2}; +6_die_00_base.t - Very basic testing of the Die module. -use CGI::Ex::Die; -ok(1); +=cut + +use Test::More tests => 2; + +use_ok('CGI::Ex::Die'); ok(eval { import CGI::Ex::Die register => 1; diff --git a/t/7_template_00_base.t b/t/7_template_00_base.t new file mode 100644 index 0000000..f394d67 --- /dev/null +++ b/t/7_template_00_base.t @@ -0,0 +1,739 @@ +# -*- Mode: Perl; -*- + +=head1 NAME + +7_template_00_base.t - Test the basic language functionality of CGI::Ex::Template - including many edge cases + +=cut + +use vars qw($module $is_tt); +BEGIN { + $module = 'CGI::Ex::Template'; #real 0m1.243s #user 0m0.695s #sys 0m0.018s + #$module = 'Template'; #real 0m2.329s #user 0m1.466s #sys 0m0.021s + $is_tt = $module eq 'Template'; +}; + +use strict; +use Test::More tests => 460 - ($is_tt ? 54 : 0); +use Data::Dumper qw(Dumper); +use constant test_taint => 0 && eval { require Taint::Runtime }; + +use_ok($module); + +Taint::Runtime::taint_start() if test_taint; + +###----------------------------------------------------------------### + +sub process_ok { # process the value and say if it was ok + my $str = shift; + my $test = shift; + my $vars = shift; + my $obj = shift || $module->new(@{ $vars->{tt_config} || [] }); # new object each time + my $out = ''; + + Taint::Runtime::taint(\$str) if test_taint; + + $obj->process(\$str, $vars, \$out); + my $ok = ref($test) ? $out =~ $test : $out eq $test; + ok($ok, "\"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\"")); + my $line = (caller)[2]; + warn "# process_ok called at line $line.\n" if ! $ok; + print $obj->error if ! $ok && $obj->can('error'); + print Dumper $obj->parse_tree(\$str) if ! $ok && $obj->can('parse_tree'); + exit if ! $ok; +} + +###----------------------------------------------------------------### + +### set up some dummy packages for various tests +{ + package MyTestPlugin::Foo; + $INC{'MyTestPlugin/Foo.pm'} = $0; + sub load { $_[0] } + sub new { + my $class = shift; + my $context = shift; # note the plugin style object that needs to shift off context + my $args = shift || {}; + return bless $args, $class; + } + sub bar { my $self = shift; return join('', map {"$_$self->{$_}"} sort keys %$self) } + sub seven { 7 } + sub many { return 1, 2, 3 } + sub echo { my $self = shift; $_[0] } +} +{ + package Foo2; + $INC{'Foo2.pm'} = $0; + use base qw(MyTestPlugin::Foo); + use vars qw($AUTOLOAD); + sub new { + my $class = shift; + my $args = shift || {}; # note - no plugin context + return bless $args, $class; + } + sub leave {} # hacks to allow tt to do the plugins passed via PLUGINS + sub delocalise {} # hacks to allow tt to do the plugins passed via PLUGINS +} + +my $obj = Foo2->new; + + +###----------------------------------------------------------------### +### variable GETting + +process_ok("[% foo %]" => ""); +process_ok("[% foo %]" => "7", {foo => 7}); +process_ok("[% foo %]" => "7", {tt_config => [VARIABLES => {foo => 7}]}); +process_ok("[% foo %]" => "7", {tt_config => [PRE_DEFINE => {foo => 7}]}); +process_ok("[% foo %][% foo %][% foo %]" => "777", {foo => 7}); +process_ok("[% foo() %]" => "7", {foo => 7}); +process_ok("[% foo.bar %]" => ""); +process_ok("[% foo.bar %]" => "", {foo => {}}); +process_ok("[% foo.bar %]" => "7", {foo => {bar => 7}}); +process_ok("[% foo().bar %]" => "7", {foo => {bar => 7}}); +process_ok("[% foo.0 %]" => "7", {foo => [7, 2, 3]}); +process_ok("[% foo.10 %]" => "", {foo => [7, 2, 3]}); +process_ok("[% foo %]" => 7, {foo => sub { 7 }}); +process_ok("[% foo(7) %]" => 7, {foo => sub { $_[0] }}); +process_ok("[% foo.length %]" => 1, {foo => sub { 7 }}); +process_ok("[% foo.0 %]" => 7, {foo => sub { return 7, 2, 3 }}); +process_ok("[% foo(bar) %]" => 7, {foo => sub { $_[0] }, bar => 7}); +process_ok("[% foo.seven %]" => 7, {foo => $obj}); +process_ok("[% foo.seven() %]" => 7, {foo => $obj}); +process_ok("[% foo.seven.length %]" => 1, {foo => $obj}); +process_ok("[% foo.echo(7) %]" => 7, {foo => $obj}); +process_ok("[% foo.many.0 %]" => 1, {foo => $obj}); +process_ok("[% foo.many.10 %]" => '',{foo => $obj}); +process_ok("[% foo.nomethod %]" => '',{foo => $obj}); +process_ok("[% foo.nomethod.0 %]" => '',{foo => $obj}); + +process_ok("[% GET foo %]" => ""); +process_ok("[% GET foo %]" => "7", {foo => 7}); +process_ok("[% GET foo.bar %]" => ""); +process_ok("[% GET foo.bar %]" => "", {foo => {}}); +process_ok("[% GET foo.bar %]" => "7", {foo => {bar => 7}}); +process_ok("[% GET foo.0 %]" => "7", {foo => [7, 2, 3]}); +process_ok("[% GET foo %]" => 7, {foo => sub { 7 }}); +process_ok("[% GET foo(7) %]" => 7, {foo => sub { $_[0] }}); + +process_ok("[% \$name %]" => "", {name => 'foo'}); +process_ok("[% \$name %]" => "7", {name => 'foo', foo => 7}); +process_ok("[% \$name.bar %]" => "", {name => 'foo'}); +process_ok("[% \$name.bar %]" => "", {name => 'foo', foo => {}}); +process_ok("[% \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% \$name().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); +process_ok("[% \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); +process_ok("[% \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); + +process_ok("[% GET \$name %]" => "", {name => 'foo'}); +process_ok("[% GET \$name %]" => "7", {name => 'foo', foo => 7}); +process_ok("[% GET \$name.bar %]" => "", {name => 'foo'}); +process_ok("[% GET \$name.bar %]" => "", {name => 'foo', foo => {}}); +process_ok("[% GET \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% GET \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); +process_ok("[% GET \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); +process_ok("[% GET \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); + +process_ok("[% \$name %]" => "", {name => 'foo foo', foo => 7}); +process_ok("[% GET \$name %]" => "", {name => 'foo foo', foo => 7}); + +process_ok("[% \${name} %]" => "", {name => 'foo'}); +process_ok("[% \${name} %]" => "7", {name => 'foo', foo => 7}); +process_ok("[% \${name}.bar %]" => "", {name => 'foo'}); +process_ok("[% \${name}.bar %]" => "", {name => 'foo', foo => {}}); +process_ok("[% \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% \${name}().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); +process_ok("[% \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); +process_ok("[% \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); + +process_ok("[% GET \${name} %]" => "", {name => 'foo'}); +process_ok("[% GET \${name} %]" => "7", {name => 'foo', foo => 7}); +process_ok("[% GET \${name}.bar %]" => "", {name => 'foo'}); +process_ok("[% GET \${name}.bar %]" => "", {name => 'foo', foo => {}}); +process_ok("[% GET \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); +process_ok("[% GET \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); +process_ok("[% GET \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); +process_ok("[% GET \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); + +process_ok("[% \${name} %]" => "", {name => 'foo foo', foo => 7}); +process_ok("[% GET \${name} %]" => "", {name => 'foo foo', foo => 7}); +process_ok("[% GET \${'foo'} %]" => 'bar', {foo => 'bar'}); + +process_ok("[% foo.\$name %]" => '', {name => 'bar'}); +process_ok("[% foo.\$name %]" => 7, {name => 'bar', foo => {bar => 7}}); +process_ok("[% foo.\$name.baz %]" => '', {name => 'bar', bar => {baz => 7}}); + +process_ok("[% \"hi\" %]" => 'hi'); +process_ok("[% 'hi' %]" => 'hi'); +process_ok("[% \"\$foo\" %]" => '7', {foo => 7}); +process_ok("[% \"hi \$foo\" %]" => 'hi 7', {foo => 7}); +process_ok("[% \"hi \${foo}\" %]" => 'hi 7', {foo => 7}); +process_ok("[% 'hi \$foo' %]" => 'hi $foo', {foo => 7}); +process_ok("[% 'hi \${foo}' %]" => 'hi ${foo}', {foo => 7}); + +process_ok("[% \"hi \${foo.seven}\" %]" => 'hi 7', {foo => $obj}); +process_ok("[% \"hi \${foo.echo(7)}\" %]" => 'hi 7', {foo => $obj}); + +process_ok("[% _foo %]2" => '2', {_foo => 1}); +process_ok("[% \$bar %]2" => '2', {_foo => 1, bar => '_foo'}); +process_ok("[% __foo %]2" => '2', {__foo => 1}); +process_ok("[% _foo = 1 %][% _foo %]2" => '2'); +process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}}); + +###----------------------------------------------------------------### +### variable SETting + +process_ok("[% SET foo bar %][% foo %]" => ''); +process_ok("[% SET foo = 1 %][% foo %]" => '1'); +process_ok("[% SET foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); +process_ok("[% SET foo bar = 1 %][% foo %]" => ''); +process_ok("[% SET foo = 1 ; bar = 1 %][% foo %]" => '1'); +process_ok("[% SET foo = 1 %][% SET foo %][% foo %]" => ''); + +process_ok("[% SET foo = [] %][% foo.0 %]" => ""); +process_ok("[% SET foo = [1, 2, 3] %][% foo.1 %]" => 2); +process_ok("[% SET foo = {} %][% foo.0 %]" => ""); +process_ok("[% SET foo = {1 => 2} %][% foo.1 %]" => "2") if ! $is_tt; +process_ok("[% SET foo = {'1' => 2} %][% foo.1 %]" => "2"); + +process_ok("[% SET name = 1 %][% SET foo = name %][% foo %]" => "1"); +process_ok("[% SET name = 1 %][% SET foo = \$name %][% foo %]" => ""); +process_ok("[% SET name = 1 %][% SET foo = \${name} %][% foo %]" => ""); +process_ok("[% SET name = 1 %][% SET foo = \"\$name\" %][% foo %]" => "1"); +process_ok("[% SET name = 1 foo = name %][% foo %]" => '1'); +process_ok("[% SET name = 1 %][% SET foo = {\$name => 2} %][% foo.1 %]" => "2"); +process_ok("[% SET name = 1 %][% SET foo = {\"\$name\" => 2} %][% foo.1 %]" => "2") if ! $is_tt; +process_ok("[% SET name = 1 %][% SET foo = {\${name} => 2} %][% foo.1 %]" => "2"); + +process_ok("[% SET name = 7 %][% SET foo = {'2' => name} %][% foo.2 %]" => "7"); +process_ok("[% SET name = 7 %][% SET foo = {'2' => \"\$name\"} %][% foo.2 %]" => "7"); + +process_ok("[% SET name = 7 %][% SET foo = [1, name, 3] %][% foo.1 %]" => "7"); +process_ok("[% SET name = 7 %][% SET foo = [1, \"\$name\", 3] %][% foo.1 %]" => "7"); + +process_ok("[% SET foo = { bar => { baz => [0, 7, 2] } } %][% foo.bar.baz.1 %]" => "7"); + +process_ok("[% SET foo.bar = 1 %][% foo.bar %]" => '1'); +process_ok("[% SET foo.bar.baz.bing = 1 %][% foo.bar.baz.bing %]" => '1'); +process_ok("[% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 1'); +process_ok("[% SET foo.bar = [] %][% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 3'); + +process_ok("[% SET name = 'two' %][% SET \$name = 3 %][% two %]" => 3); +process_ok("[% SET name = 'two' %][% SET \${name} = 3 %][% two %]" => 3); +process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.2 %]" => 3); +process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.\$name %]" => 3); +process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); +process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); +process_ok("[% SET name = 'two' %][% SET \$name.foo = 3 %][% two.foo %]" => 3); +process_ok("[% SET name = 'two' %][% SET \${name}.foo = 3 %][% two.foo %]" => 3); +process_ok("[% SET name = 'two' %][% SET foo.\$name.foo = 3 %][% foo.two.foo %]" => 3); +process_ok("[% SET name = 'two' %][% SET foo.\${name}.foo = 3 %][% foo.two.foo %]" => 3); + +process_ok("[% SET foo = [1..10] %][% foo.6 %]" => 7); +process_ok("[% SET foo = [10..1] %][% foo.6 %]" => ''); +process_ok("[% SET foo = [-10..-1] %][% foo.6 %]" => -4); +process_ok("[% SET foo = [1..10, 21..30] %][% foo.12 %]" => 23) if ! $is_tt; +process_ok("[% SET foo = [..100] bar = 7 %][% bar %][% foo.0 %]" => ''); +process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => 7) if ! $is_tt; +process_ok("[% SET foo = ['a'..'z'] %][% foo.6 %]" => 'g'); +process_ok("[% SET foo = ['z'..'a'] %][% foo.6 %]" => ''); +process_ok("[% SET foo = ['a'..'z'].reverse %][% foo.6 %]" => 't') if ! $is_tt; + +process_ok("[% foo = 1 %][% foo %]" => '1'); +process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); +process_ok("[% foo = 1 ; bar = 2 %][% foo %][% bar %]" => '12'); +process_ok("[% foo.bar = 2 %][% foo.bar %]" => '2'); + +process_ok('[% a = "a" %][% (b = a) %][% a %][% b %]' => 'aaa'); +process_ok('[% a = "a" %][% (c = (b = a)) %][% a %][% b %][% c %]' => 'aaaa'); + +###----------------------------------------------------------------### +### Reserved words + +my $vars = { + GET => 'named_get', + get => 'lower_named_get', + named_get => 'value of named_get', + hold_get => 'GET', +}; +process_ok("[% GET %]" => '', $vars); +process_ok("[% GET GET %]" => 'named_get', $vars) if ! $is_tt; +process_ok("[% GET get %]" => 'lower_named_get', $vars); +process_ok("[% GET \${'GET'} %]" => 'bar', {GET => 'bar'}); + +process_ok("[% GET = 1 %][% GET GET %]" => '', $vars); +process_ok("[% SET GET = 1 %][% GET GET %]" => '1', $vars) if ! $is_tt; + +process_ok("[% GET \$hold_get %]" => 'named_get', $vars); +process_ok("[% GET \$GET %]" => 'value of named_get', $vars) if ! $is_tt; +process_ok("[% BLOCK GET %]hi[% END %][% PROCESS GET %]" => 'hi') if ! $is_tt; +process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo a = GET %]" => 'hi', $vars) if ! $is_tt; +process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo GET = 1 %]" => ''); +process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo IF GET %]" => 'hi', $vars) if ! $is_tt; + +###----------------------------------------------------------------### +### CALL and DEFAULT + +process_ok("[% DEFAULT foo = 7 %][% foo %]" => 7); +process_ok("[% SET foo = 5 %][% DEFAULT foo = 7 %][% foo %]" => 5); +process_ok("[% DEFAULT foo.bar.baz.bing = 6 %][% foo.bar.baz.bing %]" => 6); + +my $t = 0; +process_ok("[% foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); +process_ok("[% GET foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); +process_ok("[% CALL foo %]" => '', {foo => sub {$t++; 'hi'}}); +ok($t == 3, "CALL method actually called var"); + +###----------------------------------------------------------------### +### virtual methods / filters + +process_ok("[% [0 .. 10].reverse.1 %]" => 9) if ! $is_tt; +process_ok("[% {a => 'A'}.a %]" => 'A') if ! $is_tt; +process_ok("[% 'This is a string'.length %]" => 16) if ! $is_tt; +process_ok("[% 123.length %]" => 3) if ! $is_tt; +process_ok("[% 123.2.length %]" => 5) if ! $is_tt; +process_ok("[% -123.2.length %]" => -5) if ! $is_tt; # the - doesn't bind as tight as the dot methods +process_ok("[% (-123.2).length %]" => 6) if ! $is_tt; + +process_ok("[% n.repeat %]" => '1', {n => 1}) if ! $is_tt; # tt2 virtual method defaults to 0 +process_ok("[% n.repeat(0) %]" => '', {n => 1}); +process_ok("[% n.repeat(1) %]" => '1', {n => 1}); +process_ok("[% n.repeat(2) %]" => '11', {n => 1}); +process_ok("[% n.repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; + +process_ok("[% n.size %]", => 'SIZE', {n => {size => 'SIZE', a => 'A'}}); +process_ok("[% n|size %]", => '2', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 | is alias for FILTER + +process_ok('[% foo | eval %]' => 'baz', {foo => '[% bar %]', bar => 'baz'}); +process_ok('[% "1" | indent(2) %]' => ' 1'); + +process_ok("[% n.replace('foo', 'bar') %]" => 'barbar', {n => 'foofoo'}); +process_ok("[% n.replace('(foo)', 'bar\$1') %]" => 'barfoobarfoo', {n => 'foofoo'}) if ! $is_tt; +process_ok("[% n.replace('foo', 'bar', 0) %]" => 'barfoo', {n => 'foofoo'}) if ! $is_tt; + +process_ok("[% n FILTER size %]", => '1', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 doesn't have size + +process_ok("[% n FILTER repeat %]" => '1', {n => 1}); +process_ok("[% n FILTER repeat(0) %]" => '', {n => 1}); +process_ok("[% n FILTER repeat(1) %]" => '1', {n => 1}); +process_ok("[% n FILTER repeat(2) %]" => '11', {n => 1}); +process_ok("[% n FILTER repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; + +process_ok("[% n FILTER echo = repeat(2) %][% n FILTER echo %]" => '1111', {n => 1}); +process_ok("[% n FILTER echo = repeat(2) %][% n | echo %]" => '1111', {n => 1}); +process_ok("[% n FILTER echo = repeat(2) %][% n|echo.length %]" => '112', {n => 1}) if ! $is_tt; +process_ok("[% n FILTER echo = repeat(2) %][% n FILTER \$foo %]" => '1111', {n => 1, foo => 'echo'}); +process_ok("[% n FILTER echo = repeat(2) %][% n | \$foo %]" => '1111', {n => 1, foo => 'echo'}); +process_ok("[% n FILTER echo = repeat(2) %][% n|\$foo.length %]" => '112', {n => 1, foo => 'echo'}) if ! $is_tt; + +process_ok('[% "hi" FILTER $foo %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var +process_ok('[% FILTER $foo %]hi[% END %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var +process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => sub {$_[0]x2}}]}); +process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {$_[0]x2},0]}]}); +process_ok('[% "hi" FILTER foo(2) %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {my$a=$_[1];sub{$_[0]x$a}},1]}]}); + +### this does work - but requires that Template::Filters is installed +#process_ok("[% ' ' | uri %]" => '%20'); + +###----------------------------------------------------------------### +### chomping + +process_ok(" [% foo %]" => ' '); +process_ok(" [%- foo %]" => ''); +process_ok("\n[%- foo %]" => ''); +process_ok("\n [%- foo %]" => ''); +process_ok("\n\n[%- foo %]" => "\n"); +process_ok(" \n\n[%- foo %]" => " \n"); +process_ok(" \n[%- foo %]" => " ") if ! $is_tt; +process_ok(" \n \n[%- foo %]" => " \n ") if ! $is_tt; + +process_ok("[% foo %] " => ' '); +process_ok("[% foo -%] " => ' '); +process_ok("[% foo -%]\n" => ''); +process_ok("[% foo -%] \n" => ''); +process_ok("[% foo -%]\n " => ' '); +process_ok("[% foo -%]\n\n\n" => "\n\n"); +process_ok("[% foo -%] \n " => ' '); + +###----------------------------------------------------------------### +### math operations + +process_ok("[% 1 + 2 %]" => 3); +process_ok("[% 1 + 2 + 3 %]" => 6); +process_ok("[% (1 + 2) %]" => 3); +process_ok("[% 2 - 1 %]" => 1); +process_ok("[% -1 + 2 %]" => 1); +process_ok("[% -1+2 %]" => 1); +process_ok("[% 2 - 1 %]" => 1); +process_ok("[% 2-1 %]" => 1) if ! $is_tt; +process_ok("[% 2 - -1 %]" => 3); +process_ok("[% 4 * 2 %]" => 8); +process_ok("[% 4 / 2 %]" => 2); +process_ok("[% 10 / 3 %]" => qr/^3.333/); +process_ok("[% 10 div 3 %]" => '3'); +process_ok("[% 2 ** 3 %]" => 8) if ! $is_tt; +process_ok("[% 1 + 2 * 3 %]" => 7); +process_ok("[% 3 * 2 + 1 %]" => 7); +process_ok("[% (1 + 2) * 3 %]" => 9); +process_ok("[% 3 * (1 + 2) %]" => 9); +process_ok("[% 1 + 2 ** 3 %]" => 9) if ! $is_tt; +process_ok("[% 2 * 2 ** 3 %]" => 16) if ! $is_tt; +process_ok("[% SET foo = 1 %][% foo + 2 %]" => 3); +process_ok("[% SET foo = 1 %][% (foo + 2) %]" => 3); + +###----------------------------------------------------------------### +### boolean operations + +process_ok("[% 5 && 6 %]" => 6); +process_ok("[% 5 || 6 %]" => 5); +process_ok("[% 0 || 6 %]" => 6); +process_ok("[% 0 && 6 %]" => 0); +process_ok("[% 0 && 0 %]" => 0); +process_ok("[% 5 && 6 && 7%]" => 7); +process_ok("[% 0 || 1 || 2 %]" => 1); + +process_ok("[% 5 + (0 || 5) %]" => 10); + + +process_ok("[% 1 ? 2 : 3 %]" => '2'); +process_ok("[% 0 ? 2 : 3 %]" => '3'); +process_ok("[% 0 ? (1 ? 2 : 3) : 4 %]" => '4'); +process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); + +process_ok("[% t = 1 || 0 ? 3 : 4 %][% t %]" => 3); +process_ok("[% t = 0 or 1 ? 3 : 4 %][% t %]" => 3); +process_ok("[% t = 1 or 0 ? 3 : 4 %][% t %]" => 1) if ! $is_tt; + +process_ok("[% 0 ? 2 : 3 %]" => '3'); +process_ok("[% 1 ? 2 : 3 %]" => '2'); +process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); +process_ok("[% t = 0 ? 1 ? [1..4] : [2..4] : [3..4] %][% t.0 %]" => '3'); +process_ok("[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]" => '0'); +process_ok("[% t = 0 or 0 ? 0 : 1 or 2 ? 2 : 3 %][% t %]" => '1') if ! $is_tt; +process_ok("[% t = 0 or 0 ? 0 : 0 or 2 ? 2 : 3 %][% t %]" => '2'); + +process_ok("[% 0 ? 1 ? 1 + 2 * 3 : 1 + 2 * 4 : 1 + 2 * 5 %]" => '11'); + +###----------------------------------------------------------------### +### blocks + +process_ok("[% PROCESS foo %]" => ''); +process_ok("[% BLOCK foo %]" => ''); +process_ok("[% BLOCK foo %][% END %]" => ''); +process_ok("[% BLOCK %][% END %]one" => 'one'); +process_ok("[% BLOCK foo %]hi there[% END %]" => ''); +process_ok("[% BLOCK foo %][% BLOCK foo %][% END %][% END %]" => ''); +process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo %]" => 'hi there'); +process_ok("[% PROCESS foo %][% BLOCK foo %]hi there[% END %]" => 'hi there'); +process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo %]" => 'hi ONE there', {one => 'ONE'}); +process_ok("[% BLOCK foo %]hi [% IF 1 %]Yes[% END %] there[% END %]<<[% PROCESS foo %]>>" => '<>'); +process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %]" => 'hi two there'); +process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo one.two = 'two' %]" => 'hi two there'); +process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo + foo one.two = 'two' %]" => 'hi two there'x2); + +process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %][% one %]" => 'hi two theretwo'); +process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% INCLUDE foo one = 'two' %][% one %]" => 'hi two there'); + +###----------------------------------------------------------------### +### if/unless/elsif/else + +process_ok("[% IF 1 %]Yes[% END %]" => 'Yes'); +process_ok("[% IF 0 %]Yes[% END %]" => ''); +process_ok("[% IF 0 %]Yes[% ELSE %]No[% END %]" => 'No'); +process_ok("[% IF 0 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); +process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% END %]" => ''); +process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); + +process_ok("[% UNLESS 1 %]Yes[% END %]" => ''); +process_ok("[% UNLESS 0 %]Yes[% END %]" => 'Yes'); +process_ok("[% UNLESS 0 %]Yes[% ELSE %]No[% END %]" => 'Yes'); +process_ok("[% UNLESS 1 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); +process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% END %]" => ''); +process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); + +###----------------------------------------------------------------### +### comments + +process_ok("[%# one %]" => '', {one => 'ONE'}); +process_ok("[%#\n one %]" => '', {one => 'ONE'}); +process_ok("[%-#\n one %]" => '', {one => 'ONE'}) if ! $is_tt; +process_ok("[% #\n one %]" => 'ONE', {one => 'ONE'}); +process_ok("[%# BLOCK one %]" => ''); +process_ok("[%# BLOCK one %]two" => 'two'); +process_ok("[%# BLOCK one %]two[% END %]" => ''); +process_ok("[%# BLOCK one %]two[% END %]three" => ''); + +###----------------------------------------------------------------### +### foreach, next, last + +process_ok("[% FOREACH foo %]" => ''); +process_ok("[% FOREACH foo %][% END %]" => ''); +process_ok("[% FOREACH foo %]bar[% END %]" => ''); +process_ok("[% FOREACH foo %]bar[% END %]" => 'bar', {foo => 1}); +process_ok("[% FOREACH f IN foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); +process_ok("[% FOREACH f = foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); +process_ok("[% FOREACH f = [1,2] %]bar[% f %][% END %]" => 'bar1bar2'); +process_ok("[% FOREACH f = [1..3] %]bar[% f %][% END %]" => 'bar1bar2bar3'); +process_ok("[% FOREACH f = [{a=>'A'},{a=>'B'}] %]bar[% f.a %][% END %]" => 'barAbarB'); +process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %]" => 'barAbarB'); +process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB'); +process_ok("[% FOREACH f = [1..3] %][% loop.count %]/[% loop.size %] [% END %]" => '1/3 2/3 3/3 '); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% f %][% END %][% END %]" => '1'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% f %][% END %][% END %]" => '3'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% NEXT %][% END %][% f %][% END %]" => '23'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% LAST %][% END %][% f %][% END %]" => ''); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% NEXT %][% END %][% END %]" => '123'); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% LAST %][% END %][% END %]" => '1'); + +### TT is not consistent in what is localized - well it is documented +### if you set a variable in the FOREACH tag, then nothing in the loop gets localized +### if you don't set a variable - everything gets localized +process_ok("[% foo = 1 %][% FOREACH [1..10] %][% foo %][% foo = 2 %][% END %]" => '1222222222'); +process_ok("[% f = 1 %][% FOREACH i = [1..10] %][% i %][% f = 2 %][% END %][% f %]" => '123456789102'); +process_ok("[% f = 1 %][% FOREACH [1..10] %][% f = 2 %][% END %][% f %]" => '1'); +process_ok("[% f = 1 %][% FOREACH f = [1..10] %][% f %][% END %][% f %]" => '1234567891010'); +process_ok("[% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); +process_ok("[% a %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); +process_ok("[% a = 2 %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '2'); +process_ok("[% a = 2 %][% FOREACH [1] %][% a = 1 %][% END %][% a %]" => '2'); +process_ok("[% a = 2 %][% FOREACH i = [1] %][% a = 1 %][% END %][% a %]" => '1'); +process_ok("[% FOREACH i = [1] %][% SET a = 1 %][% END %][% a %]" => '1'); +process_ok("[% f.b = 1 %][% FOREACH f.b = [1..10] %][% f.b %][% END %][% f.b %]" => '1234567891010') if ! $is_tt; +process_ok("[% a = 1 %][% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB1'); +process_ok("[% FOREACH [1..3] %][% loop.size %][% END %][% loop.size %]" => '333'); +process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '333') if ! $is_tt; +process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '3331') if $is_tt; + +###----------------------------------------------------------------### +### while + +process_ok("[% WHILE foo %]" => ''); +process_ok("[% WHILE foo %][% END %]" => ''); +process_ok("[% WHILE (foo = foo - 1) %][% END %]" => ''); +process_ok("[% WHILE (foo = foo - 1) %][% foo %][% END %]" => '21', {foo => 3}); +process_ok("[% WHILE foo %][% foo %][% foo = foo - 1 %][% END %]" => '321', {foo => 3}); + +process_ok("[% WHILE 1 %][% foo %][% foo = foo - 1 %][% LAST IF foo == 1 %][% END %]" => '32', {foo => 3}); +process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END %]" => '9876543210'); +process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END ; f %]" => '98765432100'); +process_ok("[% f = 10 a = 2; WHILE f; f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); + +process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END %]" => '9876543210'); +process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END ; f %]" => '98765432100'); +process_ok("[% f = 10 a = 2; WHILE (g=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); +process_ok("[% f = 10 a = 2; WHILE (a=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432100'); + +###----------------------------------------------------------------### +### stop, return, clear + +process_ok("[% STOP %]" => ''); +process_ok("One[% STOP %]Two" => 'One'); +process_ok("[% BLOCK foo %]One[% STOP %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOne'); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% STOP %][% END %][% END %]" => '1'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% STOP %][% END %][% f %][% END %]" => ''); + +process_ok("[% RETURN %]" => ''); +process_ok("One[% RETURN %]Two" => 'One'); +process_ok("[% BLOCK foo %]One[% RETURN %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOneLast'); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% RETURN %][% END %][% END %]" => '1'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% RETURN %][% END %][% f %][% END %]" => ''); + +process_ok("[% CLEAR %]" => ''); +process_ok("One[% CLEAR %]Two" => 'Two'); +process_ok("[% BLOCK foo %]One[% CLEAR %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstTwoLast'); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% CLEAR %][% END %][% END %]" => '23'); +process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% CLEAR %][% END %][% f %][% END %]" => '123'); +process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.last %][% CLEAR %][% END %][% END %]" => ''); +process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% CLEAR %][% END %][% f %][% END %]" => '3'); + +###----------------------------------------------------------------### +### multiple-directives + +process_ok("[% GET foo; GET foo %]" => '11', {foo => 1}); +process_ok('[% FOREACH f = [1..3]; 1; END %]' => '111'); +process_ok('[% FOREACH f = [1..3]; f; END %]' => '123'); +process_ok('[% FOREACH f = [1..3]; "$f"; END %]' => '123'); +process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234'); + +###----------------------------------------------------------------### +### post opererator + +process_ok("[% GET foo IF 1 %]" => '1', {foo => 1}); +process_ok("[% f FOREACH f = [1..3] %]" => '123'); + +process_ok("2[% GET foo IF 1 IF 2 %]" => '21', {foo => 1}) if ! $is_tt; +process_ok("2[% GET foo IF 1 IF 0 %]" => '2', {foo => 1}) if ! $is_tt; +process_ok("[% f FOREACH f = [1..3] IF 1 %]" => '123') if ! $is_tt; +process_ok("[% f FOREACH f = [1..3] IF 0 %]" => '') if ! $is_tt; +process_ok("[% f FOREACH f = g FOREACH g = [1..3] %]" => '123') if ! $is_tt; +process_ok("[% f FOREACH f = g.a FOREACH g = [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; +process_ok("[% f FOREACH f = a FOREACH [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; + +process_ok("[% FOREACH f = [1..3] IF 1 %]([% f %])[% END %]" => '(1)(2)(3)') if ! $is_tt; +process_ok("[% FOREACH f = [1..3] IF 0 %]([% f %])[% END %]" => '') if ! $is_tt; + +process_ok("[% BLOCK bar %][% foo %][% foo = foo - 1 %][% END %][% PROCESS bar WHILE foo %]" => '321', {foo => 3}); + +###----------------------------------------------------------------### +### capturing + +process_ok("[% foo = BLOCK %]Hi[% END %][% foo %][% foo %]" => 'HiHi'); +process_ok("[% BLOCK foo %]Hi[% END %][% bar = PROCESS foo %]-[% bar %]" => '-Hi'); +process_ok("[% foo = IF 1 %]Hi[% END %][% foo %]" => 'Hi'); + +###----------------------------------------------------------------### +### tags + +process_ok("[% TAGS html %]" => '3'); +process_ok("[% TAGS %]" => '3'); +process_ok("[% TAGS html %] " => '3'); +process_ok("[% TAGS html %]" => '3') if ! $is_tt; +process_ok("[% TAGS html %]\n" => '3'); +process_ok("[% BLOCK foo %][% TAGS html %][% END %][% PROCESS foo %] [% 1 + 2 %]" => ''); + +###----------------------------------------------------------------### +### switch + +process_ok("[% SWITCH 1 %][% END %]hi" => 'hi'); +process_ok("[% SWITCH 1 %][% CASE %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 1 %]Pre[% CASE %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 1 %][% CASE DEFAULT %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 1 %][% CASE 0 %]bar[% END %]hi" => 'hi'); +process_ok("[% SWITCH 1 %][% CASE 1 %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 1 %][% CASE foo %][% CASE 1 %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 1 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH 11 %][% CASE [1..10] %]bar[% END %]hi" => 'hi'); + +process_ok("[% SWITCH 1.0 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); +process_ok("[% SWITCH '1.0' %][% CASE [1..10] %]bar[% END %]hi" => 'barhi') if ! $is_tt; + +###----------------------------------------------------------------### +### try/throw/catch/final + +process_ok("[% TRY %][% END %]hi" => 'hi'); +process_ok("[% TRY %]Foo[% END %]hi" => 'Foohi'); +process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% END %]hi" => ''); +process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %][% END %]hi" => 'Foohi') if ! $is_tt; +process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %]there[% END %]hi" => 'Footherehi'); +process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH foo %]there[% END %]hi" => 'Footherehi'); +process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH %]two[% END %]hi" => 'FooFootwohi'); +process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH s %]two[% END %]hi" => ''); +process_ok("[% TRY %]Foo[% THROW foo.bar 'for fun' %][% CATCH foo %]one[% CATCH foo.bar %]two[% END %]hi" => 'Footwohi'); + +process_ok("[% TRY %]Foo[% FINAL %]Bar[% END %]hi" => 'FooBarhi'); +process_ok("[% TRY %]Foo[% THROW foo %][% FINAL %]Bar[% CATCH %]one[% END %]hi" => ''); +process_ok("[% TRY %]Foo[% THROW foo %][% CATCH %]one[% FINAL %]Bar[% END %]hi" => 'FoooneBarhi'); +process_ok("[% TRY %]Foo[% THROW foo %][% CATCH bar %]one[% FINAL %]Bar[% END %]hi" => ''); + +process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error %][% END %]" => 'foo error - bar'); +process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.type %][% END %]" => 'foo'); +process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.info %][% END %]" => 'bar'); +process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.type %][% END %]" => 'undef'); +process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.info %][% END %]" => 'foo'); + +###----------------------------------------------------------------### +### named args + +process_ok("[% foo(bar = 'one', baz = 'two') %]" => "baronebaztwo", + {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); +process_ok("[%bar='ONE'%][% foo(\$bar = 'one') %]" => "ONEone", + {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); + +###----------------------------------------------------------------### +### use + +my @config_p = (PLUGIN_BASE => 'MyTestPlugin', LOAD_PERL => 1); +process_ok("[% USE son_of_gun_that_does_not_exist %]one" => '', {tt_config => \@config_p}); +process_ok("[% USE Foo %]one" => 'one', {tt_config => \@config_p}); +process_ok("[% USE Foo2 %]one" => 'one', {tt_config => \@config_p}); +process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p}); +process_ok("[% USE Foo2(bar = 'baz') %]one[% Foo2.bar %]" => 'onebarbaz', {tt_config => \@config_p}); +process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p}); +process_ok("[% USE d = Foo(bar = 'baz') %]one[% d.bar %]" => 'onebarbaz', {tt_config => \@config_p}); +process_ok("[% USE d.d = Foo(bar = 'baz') %]one[% d.d.bar %]" => '', {tt_config => \@config_p}); + +process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => '', {tt_config => [@config_p, PLUGINS => {a=>'Foo'}, ]}); +process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => 'one7', {tt_config => [@config_p, PLUGINS => {a=>'Foo2'},]}); + +###----------------------------------------------------------------### +### macro + +process_ok("[% MACRO foo PROCESS bar %][% BLOCK bar %]Hi[% END %][% foo %]" => 'Hi'); +process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); +process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); +process_ok("[% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %]" => 'Hi2'); +process_ok("[%n=1%][% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %][%n%]" => 'Hi21'); +process_ok("[%n=1%][% MACRO foo BLOCK %]Hi[% n = 2%][% END %][% foo %][%n%]" => 'Hi1'); +process_ok("[% MACRO foo(n) FOREACH i=[1..n] %][% i %][% END %][% foo(3) %]" => '123'); + +###----------------------------------------------------------------### +### debug; + +process_ok("\n\n[% one %]" => "\n\n\n## input text line 3 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); +process_ok("[% one %]" => "\n## input text line 1 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); +process_ok("[% one %]\n\n" => "(1)ONE\n\n", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); +process_ok("1\n2\n3[% one %]" => "1\n2\n3(3)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); +process_ok("[% one;\n one %]" => "(1)ONE(2)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, + 'DEBUG_FORMAT' => '($line)']}) if ! $is_tt; +process_ok("[% DEBUG format '(\$line)' %][% one %]" => qr/\(1\)/, {one=>'ONE', tt_config => ['DEBUG' => 8]}); + +process_ok("[% TRY %][% abc %][% CATCH %][% error %][% END %]" => "undef error - abc is undefined\n", {tt_config => ['DEBUG' => 2]}); +process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]}); + +###----------------------------------------------------------------### +### constants + +my @config_c = ( + CONSTANTS => { + harry => sub {'do_this_once'}, + foo => { + bar => {baz => 42}, + bim => 57, + }, + bing => 'baz', + bang => 'bim', + }, + VARIABLES => { + bam => 'bar', + }, +); +process_ok("[% constants.harry %]" => 'do_this_once', {tt_config => \@config_c}); +process_ok("[% constants.harry.length %]" => '12', {tt_config => \@config_c}); +process_ok("[% SET constants.something = 1 %][% constants.something %]one" => '1one', {tt_config => \@config_c}); +process_ok("[% SET constants.harry = 1 %][% constants.harry %]one" => 'do_this_onceone', {tt_config => \@config_c}); +process_ok("[% constants.foo.\${constants.bang} %]" => '57', {tt_config => [@config_c]}); +process_ok("[% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; +process_ok("[% bam = 'somethingelse' %][% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; + +###----------------------------------------------------------------### +### interpolate / anycase / trim + +process_ok("Foo \$one Bar" => 'Foo ONE Bar', {one => 'ONE', tt_config => ['INTERPOLATE' => 1]}); +process_ok("[% PERL %] my \$n=7; print \$n [% END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); +process_ok("[% TRY ; PERL %] my \$n=7; print \$n [% END ; END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); + +process_ok("[% GET %]" => '', {GET => 'ONE'}); +process_ok("[% GET GET %]" => 'ONE', {GET => 'ONE'}) if ! $is_tt; + +process_ok("[% BLOCK foo %]\nhi\n[% END %][% PROCESS foo %]" => "\nhi\n"); +process_ok("[% BLOCK foo %]\nhi[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]}); +process_ok("[% BLOCK foo %]hi\n[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]}); +process_ok("[% BLOCK foo %]hi[% nl %][% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]}); +process_ok("[% BLOCK foo %][% nl %]hi[% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]}); +process_ok("A[% TRY %]\nhi\n[% END %]" => "A\nhi", {tt_config => [TRIM => 1]}); + +###----------------------------------------------------------------### +### perl + +process_ok("[% TRY %][% PERL %][% END %][% CATCH ; error; END %]" => 'perl error - EVAL_PERL not set'); +process_ok("[% PERL %] print \"[% one %]\" [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); +process_ok("[% PERL %] print \$stash->get('one') [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); +process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => '77', {tt_config => ['EVAL_PERL' => 1]}); + +###----------------------------------------------------------------### +### recursion prevention + +process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt; + diff --git a/t/7_template_01_includes.t b/t/7_template_01_includes.t new file mode 100644 index 0000000..c52fe15 --- /dev/null +++ b/t/7_template_01_includes.t @@ -0,0 +1,114 @@ +# -*- Mode: Perl; -*- + +=head1 NAME + +7_template_01_includes.t - Test the file include functionality of CGI::Ex::Template - including some edge cases + +=cut + +use vars qw($module $is_tt); +BEGIN { + $module = 'CGI::Ex::Template'; + #$module = 'Template'; + $is_tt = $module eq 'Template'; +}; + +use strict; +use Test::More tests => 25 - ($is_tt ? 6 : 0); +use Data::Dumper qw(Dumper); +use constant test_taint => 0 && eval { require Taint::Runtime }; + +use_ok($module); + +Taint::Runtime::taint_start() if test_taint; + +### find a place to allow for testing +my $test_dir = $0 .'.test_dir'; +END { rmdir $test_dir } +mkdir $test_dir, 0755; +ok(-d $test_dir, "Got a test dir up and running"); + + +sub process_ok { # process the value + my $str = shift; + my $test = shift; + my $args = shift; + my $out = ''; + + Taint::Runtime::taint(\$str) if test_taint; + + my $obj = $module->new(ABSOLUTE => 1, INCLUDE_PATH => $test_dir); + $obj->process(\$str, $args, \$out); + my $ok = $out eq $test; + ok($ok, "\"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\"")); + my $line = (caller)[2]; + warn "# process_ok called at line $line.\n" if ! $ok; +} + +### create some files to include +my $foo_template = "$test_dir/foo.tt"; +END { unlink $foo_template }; +open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!"; +print $fh "([% INCLUDE bar.tt %])"; +close $fh; + +### +my $bar_template = "$test_dir/bar.tt"; +END { unlink $bar_template }; +open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; +print $fh "BAR"; +close $fh; + +my $baz_template = "$test_dir/baz.tt"; +END { unlink $baz_template }; +open($fh, ">$baz_template") || die "Couldn't open $baz_template: $!"; +print $fh "[% SET baz = 42 %][% baz %][% bing %]"; +close $fh; + +### +my $wrap_template = "$test_dir/wrap.tt"; +END { unlink $wrap_template }; +open($fh, ">$wrap_template") || die "Couldn't open $wrap_template: $!"; +print $fh "Hi[% content %]there"; +close $fh; + +###----------------------------------------------------------------### +### INSERT + +process_ok("([% INSERT bar.tt %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% INSERT \$file %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% INSERT \${file} %])" => '(BAR)') if ! $is_tt; +process_ok("([% SET file = 'bar.tt' %][% INSERT \"\$file\" %])" => '(BAR)'); +process_ok("([% SET file = 'bar' %][% INSERT \"\$file.tt\" %])" => '(BAR)') if ! $is_tt; + +###----------------------------------------------------------------### +### INCLUDE + +process_ok("([% INCLUDE bar.tt %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% INCLUDE \$file %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% INCLUDE \${file} %])" => '(BAR)') if ! $is_tt; +process_ok("([% SET file = 'bar.tt' %][% INCLUDE \"\$file\" %])" => '(BAR)'); +process_ok("([% SET file = 'bar' %][% INCLUDE \"\$file.tt\" %])" => '(BAR)') if ! $is_tt; + +process_ok("([% INCLUDE baz.tt %])" => '(42)'); +process_ok("([% INCLUDE baz.tt %])[% baz %]" => '(42)'); +process_ok("[% SET baz = 21 %]([% INCLUDE baz.tt %])[% baz %]" => '(42)21'); + +###----------------------------------------------------------------### +### PROCESS + +process_ok("([% PROCESS bar.tt %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% PROCESS \$file %])" => '(BAR)'); +process_ok("([% SET file = 'bar.tt' %][% PROCESS \${file} %])" => '(BAR)') if ! $is_tt; +process_ok("([% SET file = 'bar.tt' %][% PROCESS \"\$file\" %])" => '(BAR)'); +process_ok("([% SET file = 'bar' %][% PROCESS \"\$file.tt\" %])" => '(BAR)') if ! $is_tt; + +process_ok("([% PROCESS baz.tt %])" => '(42)'); +process_ok("([% PROCESS baz.tt %])[% baz %]" => '(42)42'); +process_ok("[% SET baz = 21 %]([% PROCESS baz.tt %])[% baz %]" => '(42)42'); + +###----------------------------------------------------------------### +### WRAPPER + +process_ok("([% WRAPPER wrap.tt %])" => ''); +process_ok("([% WRAPPER wrap.tt %] one [% END %])" => '(Hi one there)'); diff --git a/t/8_auth_00_base.t b/t/8_auth_00_base.t new file mode 100644 index 0000000..90e6e51 --- /dev/null +++ b/t/8_auth_00_base.t @@ -0,0 +1,120 @@ +# -*- Mode: Perl; -*- + +=head1 NAME + +8_auth_00_base.t - Testing of the CGI::Ex::Auth module. + +=cut + +use strict; +use Test::More tests => 33; + +use_ok('CGI::Ex::Auth'); + +{ + package Auth; + use base qw(CGI::Ex::Auth); + use strict; + use vars qw($printed $set_cookie $deleted_cookie); + + sub login_print { $printed = 1 } + sub set_cookie { $set_cookie = 1 } + sub delete_cookie { $deleted_cookie = 1 } + sub get_pass_by_user { '123qwe' } + sub script_name { $0 } + sub no_cookie_verify { 1 } + sub secure_hash_keys { ['aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', 'bbbbbbbbbbbbbbbbbbbbbbbbbbb', 'ccc'] } +} + +{ + package Aut2; + use base qw(Auth); + use vars qw($crypt); + BEGIN { $crypt = crypt('123qwe', 'SS') }; + sub use_crypt { 1 } + sub get_pass_by_user { $crypt } +} + +my $token = Auth->new->generate_token({user => 'test', real_pass => '123qwe', use_base64 => 1}); + +my $form_bad = { cea_user => 'test', cea_pass => '123qw' }; +my $form_good = { cea_user => 'test', cea_pass => '123qwe' }; +my $form_good2 = { cea_user => $token }; +my $form_good3 = { cea_user => 'test/123qwe' }; +my $cookie_bad = { cea_user => 'test/123qw' }; +my $cookie_good = { cea_user => 'test/123qwe' }; +my $cookie_good2 = { cea_user => $token }; + +sub form_good { Auth->get_valid_auth({form => {%$form_good}, cookies => {} }) } +sub form_good2 { Auth->get_valid_auth({form => {%$form_good2}, cookies => {} }) } +sub form_good3 { Aut2->get_valid_auth({form => {%$form_good3}, cookies => {} }) } +sub form_bad { Auth->get_valid_auth({form => {%$form_bad}, cookies => {} }) } +sub cookie_good { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good} }) } +sub cookie_good2 { Auth->get_valid_auth({form => {}, cookies => {%$cookie_good2}}) } +sub cookie_bad { Auth->get_valid_auth({form => {}, cookies => {%$cookie_bad} }) } + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(form_good(), "Got good auth"); +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(form_good2(), "Got good auth"); +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(form_good3(), "Got good auth"); +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(! form_bad(), "Got bad auth"); +ok($Auth::printed, "Printed was set"); +ok(! $Auth::set_cookie, "set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(cookie_good(), "Got good auth"); +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(cookie_good2(), "Got good auth"); +ok(! $Auth::printed, "Printed was not set"); +ok($Auth::set_cookie, "Set_cookie called"); +ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); + +$Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; +ok(! cookie_bad(), "Got bad auth"); +ok($Auth::printed, "Printed was set"); +ok(! $Auth::set_cookie, "Set_cookie was not called"); +ok($Auth::deleted_cookie, "deleted_cookie was not called"); + + +SKIP: { + skip("Crypt::Blowfish not found", 4) if ! eval { require Crypt::Blowfish }; + + { + package Aut3; + use base qw(Auth); + sub use_blowfish { "This_is_my_key" } + sub use_base64 { 0 } + sub use_plaintext { 1 } + } + + my $token2 = Aut3->new->generate_token({user => 'test', real_pass => '123qwe'}); + my $form_good4 = { cea_user => $token2 }; + + sub form_good4 { Aut3->get_valid_auth({form => {%$form_good4}, cookies => {} }) } + + $Auth::printed = $Auth::set_cookie = $Auth::deleted_cookie = 0; + ok(form_good4(), "Got good auth"); + ok(! $Auth::printed, "Printed was not set"); + ok($Auth::set_cookie, "Set_cookie called"); + ok(! $Auth::deleted_cookie, "deleted_cookie was not called"); +}; -- 2.45.2
+ + +
YAML text
+
+
ProducesShould look like
+
+
+
Dump:
+[obj].0.foo=bar
+[obj].1.0=baz
+[obj].1.1=bee
+[obj].2.hem=haw
+
+
+ +