CGI-FormBuilder-3.10/0000755000175000017500000000000012754724222013556 5ustar davidpdavidpCGI-FormBuilder-3.10/META.yml0000644000175000017500000000077212754724222015035 0ustar davidpdavidp--- abstract: 'Easily generate and process stateful forms' author: - 'Nate Wiger (nate@wiger.org)' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.143240' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: CGI-FormBuilder no_index: directory: - t - inc requires: CGI: '0' version: '3.10' CGI-FormBuilder-3.10/Changes0000644000175000017500000004241712754722337015066 0ustar davidpdavidp 3.10, 2016-08-17 David Precious (BIGPRESH) taking over maintainership, kind thanks to Nate (NWIGER) for handing over the reins. [ BUG FIXES] - Avoid CGI.pm warning if param() used in list context (GH-5, netangel) --- David Precious (BIGPRESH) took over maintainership at this point. The current version on CPAN at that time was 3.09, but there were no changelog entries for versions between 3.06 and 3.09. --- VERSION 3.06 Maintenance release with a couple new features: support for "charset: utf8" in "Source::File", add_before_option/add_after_option c/o Victor Porton, and support for HTML5 type names c/o Wolfgang Radke. VERSION 3.0501 Bugfix release to repair a memory leak and a few "other" field edge cases. VERSION 3.05 Just a short time after 3.04, several new features evolved very quickly: Fieldset support A new "fieldsets" option to "new()" and a "fieldset" option to the "field()" method can be used to organize your form into sections. Currently works with the built-in "" and new "
" renderer only, but template support is in the works. Div rendering In addition to the builtin "
" rendering module, a new "Div" rendering template has been included as well. If you select this, you get a table-free form which you can manipulate using stylesheets: $form->new(template => {type => 'div'}); This provides a couple additional benefits, like separate divs for every submit button. Additional classes A couple additional CSS classes were added, wrapping around the fields as a unit for better styling. The "" tag now gets a ".fb_form" style as well. Fixed HTML::Template support A couple bugs were introduced in 3.04 that have been fixed, and more tests added. VERSION 3.04 In addition to the below features, a new Catalyst FormBuilder plugin is available on CPAN, "Catalyst::Plugin::FormBuilder". New $form->prepare() method You can now use "$form->prepare()" to get back an expanded hashref just before "$form->render()" is called. This allows you to use FormBuilder with Catalyst or other frameworks more easily, where the rendering is done elsewhere: my %expansion = $form->prepare; This could be passed directly to, say, Template Toolkit without having to use FormBuilder's Template Toolkit support. New "inflate" option to field() This is used the convert fields on the fly into objects or other values. For example, you could convert a "date" field into a DateTime object. Nice patch from Mark Hedges, check it out. Turkish messages Thanks to Recai Oktas. Added "missing" property for fields This can be queried in templates. To see if a field is missing altogether, you can check "field.missing" or "missing-field" depending on your template engine of choice. Removal of custom "puke" and "belch" FormBuilder now uses "Carp" and @CARP_NOT to handle its errors. As such, you will probably notice some differences in error output. The benefit is that setting "debug" will give you a stack trace on fatal errors. CGI::FormBuilder::Template::Builtin Moved the "render_builtin()" method to the above module, to unify the rendering schemes. New FORMBUILDER_DEBUG environment variable Setting this has the same effect as using the "debug" option. Removal of excess documentation Removed all the stub docs from "Field::*" and "Messages::*" to make CPAN happy. VERSION 3.0302 This is a bugfix release to repair these main items: - optgroups bugfix for complex arrays - removal of HTML::Entities support due to utf8 issues - new es_ES Messages module with better translations - a patch from Mark Hedges to enable plugin modules for mailresults() The rest of the features remain the same as below. VERSION 3.03 Subclassable Fields Each field is now rendered by its own class, named for the field type. For example, text fields are rendered by "CGI::FormBuilder::Field::text". This allows you to create custom field types and plugging them in by creating your own "CGI::FormBuilder::Field::whatever_you_want" module. Thanks to Peter Eichman for his contributions to this scheme. Messages Localization All messages are now handled in a similar way to field types: They are delegated to "CGI::FormBuilder::Messages::locale" where "locale" is the appropriate string such as "en_US" or "da_DK". A number of localizations are included as part of the standard distribution. There are two ways to use these messages: Either the 'auto' messages mode or by specifying a specific locale: my $form = CGI::FormBuilder->new(messages => 'auto'); # check client my $form = CGI::FormBuilder->new(messages => ':da_DK'); # specified You can create your own messages by copying "_example.pm" and modifying it for your language. When using messages in this way, the HTTP Charset is changed to "utf-8". Select optgroup support By using the "field()" option "optgroups", you can now cause select fields to automatically generate optgroup tags: $form->field(name => 'browser', options => \@opt, optgroups => 1); See the documentation on "optgroups" for more details. Data::FormValidator Support Thanks to another great patch from Peter Eichman, "Data::FormValidator" is supported as a validation option to "new()", just by passing it in as an object. See the documentation on "validate" for more information. Option sorting by LABELNAME or LABELNUM You can now sort options by "LABELNAME" or "LABELNUM", similar to the value-based sorting of "NAME" and "NUM". See the documentation for more details. XHTML Compliance Generated code now validates against . This includes stuff like lowercase "get" and "post" methods, lowercase "onchange" and "onsubmit" actions, and so on. VERSION 3.02 Multi-Page Form Support A new module, "CGI::FormBuilder::Multi", has been added to handle the navigation and state of multi-page forms. A multi-page form is actually composed of several individual forms, tied together with the special CGI param "_page": my $multi = CGI::FormBuilder::Multi->new( # first args are hashrefs per-form \%form1_opts, \%form2_opts, \%form3_opts, # remaining options apply to all forms header => 1, method => 'POST', ); my $form = $multi->form; # current form if ($form->submitted && $form->validate) { # you write this do_data_update($form->fields); # last page? if ($multi->page == $multi->pages) { print $form->confirm; exit; } $multi->page++; # next page counter $form = $multi->form; # fetch next page's form } print $form->render; For more details, see CGI::FormBuilder::Multi. External Source File Inspired by Peter Eichman's "Text::FormBuilder", the new "source" option has been added to "new()" which enables the use of an external config file to initialize FormBuilder. This file takes the format: # sample config file method: POST header: 1 submit: Update, Delete fields: fname: label: First Name size: 50 validate: NAME lname: label: Last Name size: 40 validate: NAME sex: label: Gender options: M=Male, F=Female jsclick: javascript:alert("Change your mind??"); validate: M,F required: ALL messages: form_invalid_text: Please correct the following fields: form_required_text: Please fill in all bold fields. You can even pre-parse this file, and generate a module from it which you can then reuse in multiple scripts using the "write_module()" function. For more details, see CGI::FormBuilder::Source::File. "Other" Fields The new "other" option has been added to "field()". If specified, a text box will be added to the right of the field, and its value will be used if the main field is not filled in. It will be subject to the same required and validation checks as the main field: $form->field(name => 'favorite_color', options => [qw(Red Green Blue)], validate => 'NAME', other => 1); # allow "other" This would create HTML something like this: Favorite Color: []Red []Green []Blue []Other: [____________] The text "Other:" is controlled by the message "form_other_default". Growable Fields Thanks to a patch from Peter Eichman, "field()" now also accepts a "growable" option. This option enables some JavaScript hooks that add an "Additional [label]" button on text and file fields: Data File: [______________] [Additional Data File] When you click on the "Additional Data File" button, another box will be appended, allowing you to add more files. The values are then retrieved in the usual fashion: my @files = $form->field('data_file'); Like "other" fields, all elements are subject to validation checks. The text "Additional %s" is controlled by the message "form_grow_default". Support for "CGI::FastTemplate" Thanks once again to Peter Eichman (busy guy), the module "CGI::FormBuilder::Template::Fast" has been included. This adds the template type "Fast" as an interface to "CGI::FastTemplate": my $form = CGI::FormBuilder->new( template => { type => 'Fast', define => { form => 'form.tmpl', field => 'field.tmpl', } } See CGI::FormBuilder::Template::Fast for more details. Thanks again Peter! Subclassable Templates and tmpl_param() The 2.x "tmpl_param()" method has been reimplemented finally. In addition, the included template modules are now completely subclassable, meaning that you can create an entire template engine with something like this: package My::HTML::Template; use CGI::FormBuilder::Template::HTML; use base 'CGI::FormBuilder::Template::HTML'; # new() is inherited sub render { my $self = shift; my $form = shift; # complete form object # do any special actions here $self->SUPER::render; } For more details, see CGI::FormBuilder::Template. Message Changes All messages were reworded to make them shorter and easier to read. The phrase "You must" was removed from all of them. To see the new messages, cut-and-paste this code: perl -MCGI::FormBuilder::Messages \ -e 'CGI::FormBuilder::Messages->messages' In addition, the "form_submit_default" and "form_reset_default" messages were not even being used, and field labels were not being properly highlighted on error. These problems have been fixed. Autoloaded Fields The 2.x feature of "$form->$fieldname()" has been reimplemented, but using it requires the "fieldsubs" option: my $form = CGI::FormBuilder->new(fields => \@f, fieldsubs => 1); Read the docs for some caveats. Disabled Form Similar to a static form, you can set "disabled => 1" in "new()" or "render()" to display a form with grayed-out input boxes. You can also set this on a per-field basis using "field()". Verbatim HTML Options If you want to include HTML in your field options, set "cleanopts" to 0 in "field()" (for one field) or "new()" (for all fields). Compatibility Methods For compatibility with other modules, FormBuilder now includes "param()", "query_string()", "self_url()", and "script_name()". VERSION 3.01 This was a bugfix release, including the following changes: - fixed major problems with keepextras, including a reversed ismember test - added debug messages to keepextras and changed a few other debugs - added patch from Peter Eichman to fix scalar $field->tag and $field->tag_value - converted most all XHTML generation methods to only returning scalars - fixed the columns option which was totally broken for radio buttons - added a feature to plop in {border => 0} in columns as well - added the 2.x 'override' alias for field() 'force' which was missing - also added a 'defaults' alias for field() 'value' for CGI.pm happiness - more tests since there were way too many bugs In addition there were many documentation updates and changes. VERSION 3.00 Internals The internals have been completely rewritten, nearly from the ground up. All of the major functions have been split into methods, and objects have been created for the form, fields, messages, CGI params, and so on. Several new sub-modules have been created, including: CGI::FormBuilder::Field CGI::FormBuilder::Messages CGI::FormBuilder::Template CGI::FormBuilder::Template::HTML CGI::FormBuilder::Template::Text CGI::FormBuilder::Template::TT2 Many of these modules can be subclassed and overridden if desired. In addition, the template engine has been rewritten to allow "plugging in" of additional template modules, simply by specifying the name of the module to the 'template' option in new(). For more details, see the man pages for the individual modules above. Style Sheets Stylesheets are now generated if the "stylesheet" option is specified to FormBuilder. This can either be 1 to turn it on, or a full path to a style sheet to include. When used, all tags are then output with a "class" attribute, named "styleclass" plus the name of the tag: my $form = CGI::FormBuilder->new( fields => [qw/name email/], styleclass => 'myFB', # default is "fb_" stylesheet => 1, # turn on style ); print $form->render; # HTML will include # # Compliant XHTML The output should be fully-compliant XHTML finally. Really. Maybe. Attributes and Field Objects Individual accessors have been added for every attribute that FormBuilder maintains. For example, here's a snippet of code to demonstrate: if ($form->stylesheet) { # loop thru fields, changing class for ($form->fields) { next if /_date$/; # skip fields named "XXX_date" # each field is a stringifiable object with accessors if ($_->options) { # has options $_->class('my_opt_style'); } else { # plain text box $_->class('my_text_style'); } } } This code checks to see if the "stylesheet" property has been set on the main $form. If so, then it loops thru all the fields, skipping those named "XXX_date". Of the remaining fields, those that have options have their "class" attribute changed to "my_opt_style", and those without options have it set to "my_text_style". In addition, you can individually render every part of the form yourself. by calling the appropriate method. For example: print $form->header; # just the header print $form->script; # opening JavaScript print $form->title; # form title print $form->start; # opening tag for ($form->fields) { print $_->label; # each field's human label print $_->tag; # each field's tag } print $form->end; # closing tag For a complete list of accessors, see the documentation for both CGI::FormBuilder and CGI::FormBuilder::Field. Messages Many messages have been reworded, and several new messages were added to make it easier to customize individual text. In addition, you can now specify messages to individual fields: $form->field(name => 'email', message => 'Please enter a valid email address'); For more details, see "CGI::FormBuilder::Messages". HTML::Entities encoding HTML character encoding is now dispatched to "HTML::Entities", if available. This can be downloaded as part of the "HTML::Parser" module set on CPAN. Documentation Documentation has been updated and somewhat reorganized, which was long overdue. AUTHOR Copyright (c) Nate Wiger . All Rights Reserved. This module is free software; you may copy this under the terms of the GNU General Public License, or the Artistic License, copies of which should have accompanied your Perl kit. CGI-FormBuilder-3.10/META.json0000644000175000017500000000156212754724222015203 0ustar davidpdavidp{ "abstract" : "Easily generate and process stateful forms", "author" : [ "Nate Wiger (nate@wiger.org)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.143240", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CGI-FormBuilder", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "CGI" : "0" } } }, "release_status" : "stable", "version" : "3.10" } CGI-FormBuilder-3.10/README0000644000175000017500000001103112754705612014434 0ustar davidpdavidpNAME README - README for FormBuilder 3.0, please also see Changes DESCRIPTION I hate form generation and validation because the majority of the process is tedious and mindless. In addition to being boring, there is too much room for simple error, which could render your application insecure or just plain useless. So I wrote FormBuilder to try and get rid rid of the stoopid parts, as well as take care of some tricky parts. As a result, you can build a complete application with something like this: use CGI::FormBuilder; # Assume we did a DBI query to get existing values my $dbval = $sth->fetchrow_hashref; # First create our form my $form = CGI::FormBuilder->new( fields => [qw(name email phone gender)], header => 1, method => 'POST', values => $dbval, validate => { email => 'EMAIL', phone => '/^1?-?\d{3}-?\d{3}-?\d{4}$/', }, required => 'ALL', stylesheet => '/path/to/style.css', ); # Change gender field to have options $form->field(name => 'gender', options => [qw(Male Female)] ); if ($form->submitted && $form->validate) { # Get form fields as hashref my $fields = $form->fields; # Do something to update your data (you would write this) do_data_update($fields->{name}, $fields->{email}, $fields->{phone}, $fields->{gender}); # Show confirmation screen print $form->confirm; } else { # Print out the form print $form->render; } That simple bit of code would print out an entire form, laid out in a table. Your default database values would be filled in from the DBI hashref. It would also handle stickiness across multiple submissions correctly, and it will also be able to tell if it's been submitted. Finally, it will do both JavaScript and server-side validation too. KEY FEATURES Here's the main stuff that I think is cool: Input field abstraction You simply define your fields and their values, and this module will take care of figuring out the rest. FormBuilder will automatically generate the appropriate input fields (input, select, radio, etc), even changing any JavaScript actions appropriately. Easy handling of defaults Just specify a hash of values to use as the defaults for your fields. This will be searched case-insensitively and displayed in the form. What's more, if the user enters something via the CGI that overrides a default, when you use the "field()" method to get the data you'll get the correct value. Correct stickiness Stickiness is a PITA. FormBuilder correctly handles even multiple values selected in a multiple select list, integrated with proper handling of defaults. Multiple submit mode support Related to the above, FormBuilder allows you to reliably tell whether the person clicked on the "Update" or "Delete" button of your form, normally a big pain. Robust field validation Form validation sucks, and this is where FormBuilder is a big help. It has tons of builtin patterns, and will even generate gobs of JavaScript validation code for you. You can specify your own regexps as well, and FormBuilder will correctly check even multivalued inputs. Template driver support FormBuilder can natively "drive" several major templating engines, including "HTML::Template", "Template Toolkit", and "Text::Template". if you want to build a form application with a template in less that 20 lines of Perl, FormBuilder is for you. SUPPORT If this is your first time using FormBuilder, you should check out the website for tutorials and examples at . You should also consider joining the google group at . There are some pretty smart people on the list that can help you out. Have fun! INSTALLATION For details on installation, please read the file "INSTALL". AUTHOR Copyright (c) Nate Wiger . All Rights Reserved. This module is free software; you may copy this under the terms of the GNU General Public License, or the Artistic License, copies of which should have accompanied your Perl kit. CGI-FormBuilder-3.10/Makefile.PL0000644000175000017500000000416512754704556015546 0ustar davidpdavidpuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. use vars qw($real); sub modcheck () { # check to see if our template modules are present, as they're optional my($failed, $ok) = ('',''); print "\nDoing FormBuilder pre-req checks...\n\n"; for ('HTML::Template 2.06 (for CGI::FormBuilder::Template::HTML)', 'Text::Template 1.43 (for CGI::FormBuilder::Template::Text)', 'Template 2.08 (for CGI::FormBuilder::Template::TT2)', 'CGI::FastTemplate 1.09 (for CGI::FormBuilder::Template::Fast)', 'CGI::SSI 0.92 (for CGI::FormBuilder::Template::CGI_SSI)', 'CGI::Session 3.95 (for CGI::FormBuilder::Multi)' ) { my($mod,$ver) = split; eval "use $mod $ver"; if ($@) { my($err) = split / at | \(/, $@; $failed .= sprintf " %-18s $ver (%s)\n", $mod, $err; } else { eval "require $mod; \$real = \$$mod\::VERSION"; (my $t = $_) =~ s/\d+\.\d+/sprintf "%-4s", $real/e; $ok .= " $t\n"; } } if ($ok) { print < 'CGI::FormBuilder', VERSION_FROM => 'lib/CGI/FormBuilder/Util.pm', # finds $VERSION PREREQ_PM => { CGI => 0 }, CONFIGURE => \&modcheck, ($] >= 5.005 ? (ABSTRACT_FROM => 'lib/CGI/FormBuilder.pod', # abstract from POD AUTHOR => 'Nate Wiger (nate@wiger.org)') : () ), ); CGI-FormBuilder-3.10/INSTALL0000644000175000017500000000172712754705612014620 0ustar davidpdavidpNAME INSTALL - how to install FormBuilder 3.0 DESCRIPTION To install in your root Perl tree: perl Makefile.PL make make test make install If you want to relocate it elsewhere, say for testing, you need to change several "MakeMaker" variables: perl Makefile.PL PREFIX=~/lib \ INSTALLMAN1DIR=~/man/man1 \ INSTALLMAN3DIR=~/man/man3 \ INSTALLARCHLIB=~/lib \ INSTALLPRIVLIB=~/lib \ INSTALLSITELIB=~/lib \ INSTALLSITEARCH=~/lib Note: This is true for CPAN modules and is not specific to FormBuilder. AUTHOR Copyright (c) Nate Wiger . All Rights Reserved. This module is free software; you may copy this under the terms of the GNU General Public License, or the Artistic License, copies of which should have accompanied your Perl kit. CGI-FormBuilder-3.10/t/0000755000175000017500000000000012754724222014021 5ustar davidpdavidpCGI-FormBuilder-3.10/t/3a-test14.html0000644000175000017500000000145512754704556016351 0ustar davidpdavidp
Multiopt
CGI-FormBuilder-3.10/t/3a-test07.html0000644000175000017500000000342612754704556016353 0ustar davidpdavidpContent-type: text/html Econ 101

Econ 101

Supply
Demand
CGI-FormBuilder-3.10/t/2d-test02.html0000644000175000017500000000225712754704556016351 0ustar davidpdavidp User Info Please update your info and hit "Submit".
Name Fuck off Mom Size Fuck me?
CGI-FormBuilder-3.10/t/1b-test25.html0000644000175000017500000000103212754704556016341 0ustar davidpdavidp CGI-FormBuilder-3.10/t/1a-test20.html0000644000175000017500000002103612754704556016341 0ustar davidpdavidpContent-type: text/html Finalize Your Order

Finalize Your Order

Fields that are highlighted are required.

First Name
Last Name
Email
Send Me Emails
Address
State
Zipcode
Credit Card
Expiration
CGI-FormBuilder-3.10/t/3b-multi-page.t0000644000175000017500000001151512754724074016564 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 3b-multi-page.t - test C::FB::Multi support package Stub; sub new { return bless {}, shift } sub AUTOLOAD { 1 } package main; use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { unshift @INC, "$FindBin::Bin/../lib"; my $numtests = 42; plan tests => $numtests; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Fake a submission request $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk&_submitted=1&blank=&two=&two=&_page=2&_submitted_p2=2'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Multi; use CGI::FormBuilder::Test; # separate forms my $form1 = { name => 'p1', title => 'Page 1', fields => [qw(name email phone address city state zip extra)], }; my $form2 = { name => 'p2', title => 'Numero Dos', fields => 'ticket', }; my $form3 = { name => 'p3', title => 'Tres Tacos', fields => [qw(replacement ticket action)], # undocumented hooks fieldopts => { replacement => { options => [qw(TRUE FALSE MAYBE)], value => 'FALSE', label => 'MikeZ is Da"Bomb"' }, ticket => { comment => 'master mister', value => '-1million', force => 1, }, action => { label => ' JackSUN ', value => "Your mom if I'm lucky", type => 'PASSWORD', misc => 'ellaneous', }, }, header => 1, }; my $multi = CGI::FormBuilder::Multi->new( $form1, $form2, $form3, header => 0, method => 'Post', action => '/page.pl', debug => $DEBUG, columns => 1, navbar => 0, ); my $form = $multi->form; ok($form->name, 'p2'); #1 ok($multi->page, 2); #2 ok($multi->pages, 3); #3 ok(--$multi->page, 1); #4 $form = $multi->form; ok($form->name, 'p1'); #5 ok($form->title, 'Page 1'); #6 ok(keys %{$form->field}, 8); #7 ok($form->field('email'), 'pete@peteson.com'); #8 ok($form->submitted, 0); # 9 ok($form->action, '/page.pl'); #10 ok($form->field('blank'), undef); #11 ok($multi->page++, 1); #12 ok($multi->page, 2); #13 ok($form = $multi->form); #14 ok(++$multi->page, $multi->pages); #15 ok($form = $multi->form); #16 ok(++$multi->page, $multi->pages+1); #17 eval { $form = $multi->form }; # should die ok($@); #18 ^^^ from die ok($multi->page = $multi->pages, 3); #19 ok($form = $multi->form); #20 ok($form->field('replacement'), 'TRUE'); # 21 # hack my $ren = $form->render; if ($LOGNAME eq 'nwiger') { open(REN, ">/tmp/fb.2.html"); print REN $ren; close(REN); } ok($ren, outfile(22)); #22 ok($form->field('action'), 'Unsubscribe'); #23 ok($form->field('ticket'), '-1million'); #24 ok(--$multi->page, 2); #25 ok($form = $multi->form); #26 ok($form->field('ticket'), 111); #27 ok($form->field('extra'), undef); #28 - not a form field ok($multi->page(1), 1); #29 ok($form = $multi->form); #30 ok($form->field('ticket'), undef); #31 - not a form field ok($form->field('extra'), 'junk'); #32 # Session twiddling - must use page 3 ok($multi->page(3), 3); #33 ok($form = $multi->form); #34 # Try to bootstrap CGI::Session and skip otherwise my $session; eval <<'EOE'; use Cwd; my $pwd = cwd; require CGI::Session; $session = CGI::Session->new("driver:File", undef, {Directory => $pwd}); EOE # Placeholders so code can continue $session ||= new Stub; our $NOSESSION = $@ ? 'skip: CGI::Session not installed here' : 0; skip($NOSESSION, $form->sessionid($session->id), $session->id); #35 # Trick ourselves into producing a header w/ cookie my $c; { local $TESTING = 0; ($c) = $form->header =~ /Set-Cookie: (\S+)/; } skip($NOSESSION, $c, '_sessionid='.$session->id.';'); #36 # Empty return value? $session->save_param($form) unless $NOSESSION; skip($NOSESSION, $session->param('ticket'), $form->field('ticket'));#37 skip($NOSESSION, $session->param('name'), $form->field('name')); #38 # reset name forcibly ok($form->field(name => 'name', value => 'Tater Salad', force => 1)); #39 skip($NOSESSION, $session->param('name', $form->field('name'))); #40 skip($NOSESSION, $session->param('name'), 'Tater Salad'); #41 skip($NOSESSION, $session->param('email'), undef); #42 # cleanup undef $session; system 'rm -f cgisess*'; CGI-FormBuilder-3.10/t/3a-test18.html0000644000175000017500000000167212754704556016356 0ustar davidpdavidp
Refsort
CGI-FormBuilder-3.10/t/1a-test13.html0000644000175000017500000000313112754704556016337 0ustar davidpdavidp
Earth
Wind
Fire
Water
CGI-FormBuilder-3.10/t/2d-test01.html0000644000175000017500000000365112754704556016347 0ustar davidpdavidp User Info Please update your info and hit "Submit".
Name Best Color Sex Size CGI-FormBuilder-3.10/t/1a-test11.html0000644000175000017500000000110312754704556016332 0ustar davidpdavidp

Fields that are highlighted are required.

Email
First Name
CGI-FormBuilder-3.10/t/2c-test02.html0000644000175000017500000000325112754704556016343 0ustar davidpdavidp TEST
Name
Mom
Size
Fuck me?
CGI-FormBuilder-3.10/t/1a-test26.html0000644000175000017500000000167312754704556016354 0ustar davidpdavidp
Acct
Phone
Taco
Salad
CGI-FormBuilder-3.10/t/2a-test00.html0000644000175000017500000000071612754704556016342 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is
CGI-FormBuilder-3.10/t/1a-test33.html0000644000175000017500000000671112754704556016350 0ustar davidpdavidp

Fields that are highlighted are required.

Account Information
Ticket
Part Information
Email
User
Part Number
CGI-FormBuilder-3.10/t/3a-test21.html0000644000175000017500000000636712754704556016356 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/1a-test14.html0000644000175000017500000000145512754704556016347 0ustar davidpdavidp
Multiopt
CGI-FormBuilder-3.10/t/3b-test22.html0000644000175000017500000000312712754704556016347 0ustar davidpdavidpContent-type: text/html Tres Tacos

Tres Tacos

MikeZ is Da"Bomb"
Ticket master mister
JackSUN
CGI-FormBuilder-3.10/t/3a-test27.html0000644000175000017500000000107712754704556016355 0ustar davidpdavidp
Text1
Text2
Textthree
CGI-FormBuilder-3.10/t/1a-test12.html0000644000175000017500000000121512754704556016337 0ustar davidpdavidp
Earth
Wind
Fire
Water
CGI-FormBuilder-3.10/t/3a-test03.html0000644000175000017500000000075212754704556016346 0ustar davidpdavidp
First Name
Last Name
CGI-FormBuilder-3.10/t/1a-test22.html0000644000175000017500000000241712754704556016345 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/1a-test04.html0000644000175000017500000000114212754704556016337 0ustar davidpdavidpContent-type: text/html TEST

TEST

First Name
Last Name
CGI-FormBuilder-3.10/t/2e-test02.html0000644000175000017500000000065712754704556016354 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is 8
CGI-FormBuilder-3.10/t/3a-source-file.t0000644000175000017500000001571112754724074016736 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 3a-source-file.t - test C::FB::Source::File support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { my $numtests = 20; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # For testing sortopts in test 18 sub refsort { $_[0] <=> $_[1] } sub getopts { return [99,9,8,83,7,73,6,61,66,5,4,104,3,2,10,1,101]; } # What options we want to use, and what we expect to see my @test = ( #1 { str => ' fields: name email sticky: 0 ', }, #2 { str => ' # comment fields: Upper: type: password Case: value: 3 values: Upper: 1 Case: 0 ', }, #3 { str => ' # test three fields: first_name last_name submit: Update reset: 0 ', }, #4 { str => ' fields: first_name last_name: type: text submit: Update reset: 0 header: 1 body: bgcolor: black ', }, #5 { str => ' # rewritten fields hash # as a set of values fields: email: required: 0 first_name: required: 1 values: first_name: Nate email: nate@wiger.org validate: email: EMAIL sticky: 0 ', }, #6 { # utilize our query_string to test stickiness str => ' fields: ticket user part_number method: post keepextras: 1 validate: ticket: /^\d+$/ submit: Update,Delete,Cancel ', }, #7 { # max it out, baby str => ' fields: supply, demand options: supply: 0=A,1=B,2=C,3,4,5,6,7=D,8=E,9=F demand: 0=A,1=B,2=C,3,4,5,6,7=D,8=E,9=F values: supply: 0,1,2,3,4 demand: 5,6,7,8,9 method: put title: Econ 101 header name: econ font: arial,helvetica,courier stylesheet: 1 fieldtype: select ', }, #8 { str => ' fields: db:name,db:type,db:tab,ux:user,ux:name static: 1 ', }, #9 { # single-line search thing ala Yahoo! str => "fields: search \r\n submit: Go \n\r reset: 0 \r table: 0", }, #10 { str => ' fields: hostname domain header: 1 # will come out (ticket,user) b/c of QUERY_STRING keepextras: user,ticket values: localhost,localdomain validate: hostname: HOST domain: DOMAIN ', }, #11 { str => ' fields: email: value: nate@wiger.org first_name: value: Nate validate: email: EMAIL required: first_name javascript: 0 ', }, #12 { str => ' fields: earth, wind, fire, water fieldattr: type: TEXT ', }, #13 { str => ' fields: earth wind columns: 1 fire water notafield options: wind: , , fire: &&MURDEROUS", &&HOT", &&WARM", &&COLD", &&CHILLY", &&OUT" values: water: >>&c0ld&<< earth: Wind >> fire: &&MURDEROUS", &&HOT" ', }, #14 - option maxing { str => ' fields: multiopt values: multiopt: 1,2,6,9 options: multiopt: 1 = One, 2 = Two , 3 = Three, 7 = Seven, 8 = Eight, 9 = Nine, 4 = Four, 5 = Five, 6 = Six, 10 = Ten sortopts: NUM, ', }, #15 - obscure features { str => ' fields: plain, jane, mane nameopts: 1 # Style is important stylesheet: /my/own/style.css styleclass: yo. body: ignore: me javascript: 0 jsfunc:// missing labels: plain:AAA jane: BBB options: mane: ratty,nappy,mr_happy selectnum: 0 title: Bobby header: On ', }, #16 { str => ' fields: name: comment: Hey buddy email: comment: No email >> address?? sticky: 0 ', }, #17 { str => ' fields: won: jsclick: taco_punch = 1, taco_salad = "yummy" too: options: 0,1,2 jsclick: this.salami.value = "delicious" columns: 1 many: options: 0,1,2,3,4,5,6,7,8,9 jsclick: this.ham.value = "it\'s a pig, man!" columns: 1 cb_input: type: checkbox label: Option options: active=Have this item active ', }, #18 { str => ' fields: refsort: sortopts: \&refsort options: \&getopts ', }, #19 - table attr and field columns { str => ' fields: a: options: 0,1,2,3 columns: 2 value: 1,2 b: options: 4,5,6,7,8,9 columns: 3 comment: Please fill these in c lalign: today table: border: 1 td: taco: beef align: right tr: valign: top th: ignore: this selectnum: 10 ', mod => { a => { options => [0..3], columns => 2, value => [1..2] }, b => { options => [4..9], columns => 3, comment => "Please fill these in" }, }, }, #20 - order.cgi from manpage (big) { str => ' name: order method: post fields: first_name last_name email send_me_emails: options: 1=Yes,0=No columns: 1 value: 0 address state: options: JS,IW,KS,UW,JS,UR,EE,DJ,HI,YK,NK,TY sortopts: NAME columns: 1 zipcode credit_card expiration header: 1, title: Finalize Your Order submit: Place Order, Cancel reset: 0 validate: email: EMAIL zipcode: ZIPCODE credit_card: CARD expiration: MMYY messages: form_invalid_text: You fucked up. Check it: form_required_text: Don\'t fuck up, it causes me work. Fuck,try again, ok? js_invalid_input: - Enter shit in the "%s" field required: ALL jsfunc: < {type => 'File', source => \"$_->{str}"}); $conf{action} = 'TEST'; my $form = CGI::FormBuilder->new(%conf); $form->{title} = 'TEST' unless $form->{title}; # just compare the output of render with what's expected my $ren = $form->render; my $out = outfile($seq++); my $ok = ok($ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } CGI-FormBuilder-3.10/t/1a-test23.html0000644000175000017500000000361712754704556016351 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/1b-test24.html0000644000175000017500000000103612754704556016344 0ustar davidpdavidp CGI-FormBuilder-3.10/t/3a-test11.html0000644000175000017500000000110312754704556016334 0ustar davidpdavidp

Fields that are highlighted are required.

Email
First Name
CGI-FormBuilder-3.10/t/2c-test03.html0000644000175000017500000000654412754704556016354 0ustar davidpdavidp TEST
Name
Color
Email
glass EYE fucker
Size
CGI-FormBuilder-3.10/t/1a-test17.html0000644000175000017500000000271312754704556016350 0ustar davidpdavidp
Won
Too
Many
CGI-FormBuilder-3.10/t/1a-test03.html0000644000175000017500000000075212754704556016344 0ustar davidpdavidp
First Name
Last Name
CGI-FormBuilder-3.10/t/3a-test01.html0000644000175000017500000000071412754704556016342 0ustar davidpdavidp
Name
Email
CGI-FormBuilder-3.10/t/1a-test15.html0000644000175000017500000000224512754704556016346 0ustar davidpdavidpContent-type: text/html Bobby

Bobby

AAA
BBB
Mane
CGI-FormBuilder-3.10/t/2a-test03.html0000644000175000017500000000400312754704556016336 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is (unknown)
CGI-FormBuilder-3.10/t/1a-test30.html0000644000175000017500000000332412754704556016342 0ustar davidpdavidp
Browser
Select2
Select3
CGI-FormBuilder-3.10/t/1a-test16.html0000644000175000017500000000075412754704556016352 0ustar davidpdavidp
Name Hey buddy
Email No email >> address??
CGI-FormBuilder-3.10/t/2d-template-fast.t0000644000175000017500000001305712754724074017272 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 2d-template-fast.t - test CGI::FastTemplate support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded our $SKIP; BEGIN { my $numtests = 4; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # try to load template engine so absent template does # not cause all tests to fail eval "require CGI::FastTemplate"; $SKIP = $@ ? 'skip: CGI::FastTemplate not installed here' : 0; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # Create our template and store it in a scalarref my $template = <<'EOT'; User Info Please update your info and hit "Submit". $JS_HEAD $START_FORM $FIELDS $SUBMIT $FORM_END EOT my $fieldtmpl = <<'EOT'; $LABEL$FIELD $COMMENT EOT my $fieldinv = <<'EOT'; $LABEL$FIELD $COMMENT $ERROR EOT # What options we want to use, and what we expect to see my @test = ( { opt => { fields => [qw/name color/], submit => 'No esta una button del resetto', template => { type => 'Fast', define_nofile => { form => $template, field => $fieldinv, field_invalid => $fieldinv, } }, validate => { name => 'NAME' }, }, mod => { color => { options => [qw/red green blue/], label => 'Best Color', value => 'red' }, size => { value => 42 }, sex => { options => [[M=>'Male'],[F=>'Female']] } }, }, { opt => { fields => [qw/name color size/], template => { type => 'Fast', define_nofile => { form => $template, field => $fieldinv, field_invalid => $fieldinv, } }, values => {color => [qw/purple/], size => 8}, submit => 'Start over, boob!', }, mod => { color => { options => [[white=>'White'],[black=>'Black'],[red=>'Green']], label => 'Mom', }, name => { size => 80, maxlength => 80, comment => 'Fuck off' }, sex => { options => [[1=>'Yes'], [0=>'No'], [2=>'Maybe']], label => 'Fuck me?
' }, }, }, { opt => { fields => [qw/name color email/], submit => [qw/Update Delete/], reset => 0, template => { type => 'Fast', define_nofile => { form => $template, field => $fieldinv, field_invalid => $fieldinv, } }, values => {color => [qw/yellow green orange/]}, validate => { sex => [qw(1 3 5)] }, }, mod => { color => {options => [[red => 1], [blue => 2], [yellow => 3], [pink => 4]] }, size => {comment => '(unknown)', value => undef, force => 1 } , sex => {label => 'glass EYE fucker', options => [[1,2],[3,4],[5,6]] }, }, }, ); # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }, ); # the ${mod} key twiddles fields while(my($f,$o) = each %{$_->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # # Just compare the output of render with what's expected # the correct string output is now in external files. # The seemingly extra eval is required so that failures # to import the template modules do not kill the tests. # (since render is called regardless of whether $SKIP is set) # my $out = outfile($seq++); my $ren; eval '$ren = $form->render'; warn $@ if $@ && ! $SKIP; my $ok = skip($SKIP, $ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } # MORE TESTS DOWN HERE # from eszpee for tmpl_param skip($SKIP, do{ my $form2 = CGI::FormBuilder->new( template => { type => 'Fast', define_nofile => { form => '$TEST', } }, ); $form2->tmpl_param(TEST => "this message should appear"); eval '$form2->render'; }, 'this message should appear'); CGI-FormBuilder-3.10/t/1a-test19.html0000644000175000017500000000350112754704556016346 0ustar davidpdavidp
A
B
Please fill these in
C
CGI-FormBuilder-3.10/t/3a-test22.html0000644000175000017500000000240412754704556016343 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/3a-test16.html0000644000175000017500000000075412754704556016354 0ustar davidpdavidp
Name Hey buddy
Email No email >> address??
CGI-FormBuilder-3.10/t/1a-test10.html0000644000175000017500000000416612754704556016345 0ustar davidpdavidpContent-type: text/html TEST

TEST

Fields that are highlighted are required.

Hostname
Domain
CGI-FormBuilder-3.10/t/2e-test03.html0000644000175000017500000000344412754704556016352 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is (unknown)
CGI-FormBuilder-3.10/t/3a-test06.html0000644000175000017500000000434012754704556016346 0ustar davidpdavidp

Fields that are highlighted are required.

Ticket
User
Part Number
CGI-FormBuilder-3.10/t/1b-fields.t0000644000175000017500000002742712754724074015775 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 1b-fields.t - test Field generation/handling use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; use File::Find; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { unshift @INC, "$FindBin::Bin/../lib"; my $numtests = 26; plan tests => $numtests; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Fake a submission request $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk&_submitted=1&blank=&two=&two=&other_test=_other_other_test&_other_other_test=42&other_test_2=_other_other_test_2&_other_other_test_2=nope'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # jump to a test if specified for debugging (goto eek!) my $t = shift; if ($t) { eval sprintf("goto T%2.2d", $t); die; } # Now manually try a whole bunch of things #1 T01: ok(do { my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email/]); if ($form->submitted) { 1; } else { 0; } }, 1); exit if $t; #2 T02: ok(do { my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email/], validate => { email => 'EMAIL' } ); if ($form->submitted && $form->validate) { 1; } else { 0; } }, 1); exit if $t; #3 T03: ok(do { # this should fail since we are saying our email should be a netmask my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email/], validate => { email => 'NETMASK' } ); if ($form->submitted && $form->validate) { 0; # failure } else { 1; } }, 1); exit if $t; #4 T04: ok(do { # this should also fail since the submission key will be _submitted_magic, # and our query_string only has _submitted in it my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email/], name => 'magic'); if ($form->submitted) { 0; # failure } else { 1; } }, 1); exit if $t; #5 T05: ok(do { # CGI should override default values my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email/], values => { user => 'jim' } ); if ($form->submitted && $form->field('user') eq 'pete') { 1; } else { 0; } }, 1); exit if $t; #6 T06: ok(do { # test a similar thing, by with mixed-case values my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/user name email Addr/], values => { User => 'jim', ADDR => 'Hello' } ); if ($form->submitted && $form->field('Addr') eq 'Hello') { 1; } else { 0; } }, 1); exit if $t; #7 T07: ok(do { # test a similar thing, by with mixed-case values my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => { User => 'jim', ADDR => 'Hello' } ); if ($form->submitted && ! $form->field('Addr') && $form->field('ADDR') eq 'Hello') { 1; } else { 0; } }, 1); exit if $t; #8 T08: ok(do { my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => []); # no fields! if ($form->submitted) { if ($form->field('name') || $form->field('extra')) { # if we get here, this means that the restrictive field # masking is not working, and all CGI params are available -1; } elsif ($form->cgi_param('name')) { 1; } else { 0; } } else { 0; } }, 1); exit if $t; #9 T09: ok(do { # test if required does what v1.97 thinks it should (should fail) my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => { user => 'nwiger', pass => '' }, validate => { user => 'USER' }, required => [qw/pass/]); if ($form->submitted && $form->validate) { 0; } else { 1; } }, 1); exit if $t; #10 T10: ok(do { # YARC (yet another 'required' check) my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/name email phone/], validate => {email => 'EMAIL', phone => 'PHONE'}, required => [qw/name email/], ); if ($form->submitted && $form->validate) { 1; } else { 0; } }, 1); exit if $t; #11 T11: ok(do { # test of proper CGI precendence when manually setting values my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/name email action/], validate => {email => 'EMAIL'}, required => [qw/name email/], ); $form->field(name => 'action', options => [qw/Subscribe Unsubscribe/], value => 'Subscribe'); if ($form->submitted && $form->validate && $form->field('action') eq 'Unsubscribe') { 1; } else { 0; } }, 1); exit if $t; #12 T12: ok(do { # test of proper CGI precendence when manually setting values my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/name email blank notpresent/], values => {blank => 'DEF', name => 'DEF'} ); if (defined($form->field('blank')) && ! $form->field('blank') && $form->field('name') eq 'Pete Peteson' && ! defined($form->field('notpresent')) ) { 1; } else { 0; } }, 1); exit if $t; #13 T13: ok(do { # test of proper CGI precendence when manually setting values my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/name email blank/], keepextras => 0, # should still get value action => 'TEST', ); if (! $form->field('extra') && $form->cgi_param('extra') eq 'junk') { 1; } else { 0; } }, 1); exit if $t; #14 T14: ok(do{ my $form = CGI::FormBuilder->new(debug => $DEBUG, fields => [qw/name color dress_size taco:punch/]); $form->field(name => 'blank', value => 175, force => 1); $form->field(name => 'user', value => 'bob'); if ($form->field('blank') eq 175 && $form->field('user') eq 'pete') { 1; } else { 0; } }, 1); exit if $t; #15 T15: ok(do{ my $form = CGI::FormBuilder->new( debug => $DEBUG, smartness => 0, javascript => 0, ); $form->field(name => 'blank', value => 'aoe', type => 'text'); $form->field(name => 'extra', value => '24', type => 'hidden', override => 1); $form->field(name => 'two', value => 'one'); my @v = $form->field('two'); if ($form->submitted && $form->validate && defined($form->field('blank')) && ! $form->field('blank') && $form->field('extra') eq 24 && @v == 2) { 1; } else { 0; } }, 1); exit if $t; #16 T16: ok(do{ my $form = CGI::FormBuilder->new(debug => $DEBUG); $form->fields([qw/one two three/]); my @v; if (@v = $form->field('two') and @v == 2) { 1; } else { 0; } }, 1); exit if $t; #17 T17: ok(do{ my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/one two three/], fieldtype => 'TextAREA', ); $form->field(name => 'added_later', label => 'Yo'); my $ok = 1; for ($form->fields) { $ok = 0 unless $_->render =~ /textarea/i; } $ok; }, 1); exit if $t; #18 T18: ok(do{ my $form = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/a b c/], fieldattr => {type => 'TOMATO'}, values => {a => 'Ay', b => 'Bee', c => 'Sea'}, ); $form->values(a => 'a', b => 'b', c => 'c'); my $ok = 1; for ($form->fields) { $ok = 0 unless $_->value eq $_; } $ok; }, 1); exit if $t; #19 T19: ok(do{ my $form = CGI::FormBuilder->new( fields => [qw/name user/], required => 'ALL', sticky => 0, ); my $ok = 1; my $name = $form->field('name'); $ok = 0 unless $name eq 'Pete Peteson'; my $user = $form->field('user'); $ok = 0 unless $user eq 'pete'; for ($form->fields) { $ok = 0 unless $_->tag eq qq(); } $ok; }, 1); exit if $t; #20 - other field values T20: ok(do{ my $form = CGI::FormBuilder->new; $form->field(name => 'other_test', other => 1, type => 'select'); $form->field(name => 'other_test_2', other => 0, value => 'nope'); my $ok = 1; $ok = 0 unless $form->field('other_test') eq '42'; $ok = 0 unless $form->field('other_test_2') eq '_other_other_test_2'; $ok; }, 1); exit if $t; #21 - inflate coderef T21: ok(do{ my $form = CGI::FormBuilder->new; $form->field( name => 'inflate_test', value => '2003-04-05 06:07:08', inflate => sub { return [ split /\D+/, shift ] }, ); my $ok = 1; my $val = $form->field('inflate_test'); $ok = 0 unless ref $val eq 'ARRAY'; my $i = 0; $ok = 0 if grep { ($val->[$i++] != $_) } 2003, 4, 5, 6, 7, 8; $ok; }, 1); #22 - don't tell anyone this works T22: ok(do{ my $form = CGI::FormBuilder->new; my $val = $form->field( name => 'forty-two', value => 42 ); $val == 42; }, 1); #23 - try to catch bad \%opt destruction errors T23: ok(do{ my $opt = { source => {type => 'File', source => \"name: one\nfields:a,b"}, values => {a=>1,b=>2,c=>3,d=>4}, options => {a=>[1,2,3], d=>[4..10]}, submit => 'Yeah', }; my $form1 = CGI::FormBuilder->new($opt); my $render1 = $form1->render; my $form2 = CGI::FormBuilder->new($opt); my $render2 = $form2->render; $opt->{source} = { type => 'File', source => \"name: two\nmethod:post\nfields:c,d", }; my $form3 = CGI::FormBuilder->new($opt); $render1 eq $render2 && ! $form3->{fieldrefs}{a} && ! $form3->{fieldrefs}{b}; #warn "RENDER1 = $render1"; #warn "RENDER3 = " . $form3->render; }, 1); #24 - fucking rt.cpan shit T24: ok(do{ my $form = CGI::FormBuilder->new; $form->field(name => 'other_test', other => 1, type => 'select', options => [1..5], value => 6); my $ok = 1; # you know what? fuck Perl $form->script; # internals thing my($f) = grep /^other_test$/, $form->field; my $h = $f->tag . "\n"; $h eq outfile(24) ? 1 : 0; }, 1); #25 - fucking rt.cpan shit T25: ok(do{ my $form = CGI::FormBuilder->new; $form->field(name => 'butter_test', other => 1, type => 'select', options => [1..5]); # no value my $ok = 1; # you know what? fuck Perl $form->script; # internals thing my($f) = grep /^butter_test$/, $form->field; my $h = $f->tag . "\n"; $h eq outfile(25) ? 1 : 0; }, 1); #26 - fucking rt.cpan shit T26: ok(do{ my $form = CGI::FormBuilder->new; $form->field(name => 'butter_test', other => 1, type => 'select', options => [1..5], value => undef); # undef value my $ok = 1; # you know what? fuck Perl $form->script; # internals thing my($f) = grep /^butter_test$/, $form->field; my $h = $f->tag . "\n"; $h eq outfile(26) ? 1 : 0; }, 1); CGI-FormBuilder-3.10/t/2b-test01.html0000644000175000017500000000274112754704556016344 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: Select your Best Color: Sex = Male
Female
FYI, your dress size is 42
CGI-FormBuilder-3.10/t/2a-test99.html0000644000175000017500000000126412754704556016363 0ustar davidpdavidp Test :

CGI-FormBuilder-3.10/t/1a-test31.html0000644000175000017500000000746512754704556016355 0ustar davidpdavidpContent-type: text/html TEST

TEST

1 error(s) were encountered with your submission. Please correct the fields highlighted below.

Full Name
Sex
It's one or the other
Favy Colour
-select- Red Green Blue Orange Yellow Purple Select an option from this list Choose just one, even if you have more than one
Things you love
CGI-FormBuilder-3.10/t/2b-test02.html0000644000175000017500000000130412754704556016337 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: Fuck off Select your Mom: Fuck me?
= Yes
No
Maybe
FYI, your dress size is 8
CGI-FormBuilder-3.10/t/3a-test24.html0000644000175000017500000000057512754704556016354 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/3a-test23.html0000644000175000017500000000360412754704556016347 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/1a-test34.html0000644000175000017500000000503112754704556016343 0ustar davidpdavidp

Fields that are highlighted are required.

Name
Favorite Color
CGI-FormBuilder-3.10/t/3a-test02.html0000644000175000017500000000074412754704556016346 0ustar davidpdavidp
Upper
Case
CGI-FormBuilder-3.10/t/3a-test26.html0000644000175000017500000000166012754704556016352 0ustar davidpdavidp
Acct
Phone
Taco
Salad
CGI-FormBuilder-3.10/t/2e-test00.html0000644000175000017500000000055612754704556016350 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is
CGI-FormBuilder-3.10/t/1a-test35.html0000644000175000017500000000117412754704556016350 0ustar davidpdavidp

Name Pete Peteson
Email pete@peteson.com
Color
CGI-FormBuilder-3.10/t/2e-test04.html0000644000175000017500000000107412754704556016350 0ustar davidpdavidp Test
test form page:

CGI-FormBuilder-3.10/t/1a-test06.html0000644000175000017500000000446412754704556016353 0ustar davidpdavidp

Fields that are highlighted are required.

Ticket
User
Part Number
CGI-FormBuilder-3.10/t/3a-test17.html0000644000175000017500000000323412754704556016351 0ustar davidpdavidp
Won
Too
Many
Option
CGI-FormBuilder-3.10/t/3a-test28.html0000644000175000017500000000713612754704556016360 0ustar davidpdavidp TEST

TEST

1 error(s) were encountered with your submission. Please correct the fields highlighted below.

Full Name
Sex
It's one or the other
Favy Colour Select an option from this list
Choose just one, even if you have more than one
Things you love
CGI-FormBuilder-3.10/t/2d-test03.html0000644000175000017500000000542112754704556016346 0ustar davidpdavidp User Info Please update your info and hit "Submit".
Name Color Email glass EYE fucker Size (unknown) CGI-FormBuilder-3.10/t/1a-test18.html0000644000175000017500000000167212754704556016354 0ustar davidpdavidp
Refsort
CGI-FormBuilder-3.10/t/3a-test15.html0000644000175000017500000000206512754704556016350 0ustar davidpdavidpContent-type: text/html Bobby

Bobby

AAA
BBB
Mane
CGI-FormBuilder-3.10/t/2c-test04.html0000644000175000017500000000401712754704556016346 0ustar davidpdavidp TEST
Yomomma
Mymomma
CGI-FormBuilder-3.10/t/1a-test36.html0000644000175000017500000000256512754704556016356 0ustar davidpdavidp
Name Pete Peteson
Color
Tummy
CGI-FormBuilder-3.10/t/1a-test21.html0000644000175000017500000000643012754704556016343 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/2a-template-html.t0000644000175000017500000001103712754724074017272 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) 2000-2006 Nathan Wiger . # All Rights Reserved. If you're reading this, you're bored. # 2a-template-html.t - test HTML::Template support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded our $SKIP; BEGIN { my $numtests = 5; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # try to load template engine so absent template does # not cause all tests to fail eval "require HTML::Template"; $SKIP = $@ ? 'skip: HTML::Template not installed here' : 0; # eval failed, skip all tests # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # Grab our template from our test00.html file my $template = outfile(0); my $kurtlidl = outfile(99); # What options we want to use, and what we expect to see my @test = ( { opt => { fields => [qw/name color/], submit => 0, reset => 'No esta una button del submito', template => { scalarref => \$template }, validate => { name => 'NAME' }, }, mod => { color => { options => [qw/red green blue/], nameopts => 1 }, size => { value => 42 } }, }, { opt => { fields => [qw/name color size/], template => { scalarref => \$template }, values => {color => [qw/purple/], size => 8}, reset => 'Start over, boob!', validate => {}, # should be empty }, mod => { color => { options => [qw/white black other/] }, name => { size => 80 } }, }, { opt => { fields => [qw/name color email/], submit => [qw/Update Delete/], reset => 0, template => { scalarref => \$template }, values => {color => [qw/yellow green orange/]}, validate => { color => [qw(red blue yellow pink)] }, }, mod => { color => {options => [[red => 1], [blue => 2], [yellow => 3], [pink => 4]] }, size => {value => '(unknown)' } }, }, { opt => { fields => [qw/field1 field2/], method => 'post', title => 'test form page', header => 0, template => { scalarref => \$kurtlidl }, }, mod => { field1 => { value => 109, comment => 'Hello' }, field2 => { type => 'submit', value => "1 < 2 < 3", label => "Reefer", comment => 'goodbyE@' }, field3 => { type => 'button', value => "<>", comment => 'onSubmit' }, }, }, ); # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }, ); # the ${mod} key twiddles fields while(my($f,$o) = each %{$_->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # # Just compare the output of render with what's expected # the correct string output is now in external files. # The seemingly extra eval is required so that failures # to import the template modules do not kill the tests. # (since render is called regardless of whether $SKIP is set) # my $out = outfile($seq++); my $ren = $SKIP ? '' : $form->render; my $ok = skip($SKIP, $ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { #use Data::Dumper; #die Dumper($form); open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } # MORE TESTS DOWN HERE # from eszpee for tmpl_param skip($SKIP, do{ my $form2 = CGI::FormBuilder->new( template => { scalarref => \'' } ); $form2->tmpl_param(test => "this message should appear"); eval '$form2->render'; }, 'this message should appear'); CGI-FormBuilder-3.10/t/2e-test99.html0000644000175000017500000000102212754704556016357 0ustar davidpdavidp Test :

CGI-FormBuilder-3.10/t/1a-test08.html0000644000175000017500000000123112754704556016342 0ustar davidpdavidp
Db Name
Db Type
Db Tab
Ux User
Ux Name
CGI-FormBuilder-3.10/t/2a-test02.html0000644000175000017500000000115212754704556016337 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is 8
CGI-FormBuilder-3.10/t/1a-test28.html0000644000175000017500000000735612754704556016362 0ustar davidpdavidpContent-type: text/html TEST

TEST

1 error(s) were encountered with your submission. Please correct the fields highlighted below.

Full Name
Sex
It's one or the other
Favy Colour Select an option from this list Choose just one, even if you have more than one
Things you love
CGI-FormBuilder-3.10/t/1a-test32.html0000644000175000017500000000774212754704556016354 0ustar davidpdavidp
Account Information
First Name
Last Name
Email
Sex
User Preferences
Call Me
Email Me
Phone Number(s)
Home Phone
Work Phone
Inline Created
New Set
Outside 1
Outside 2
Outside 3
CGI-FormBuilder-3.10/t/2b-test00.html0000644000175000017500000000154712754704556016346 0ustar davidpdavidp User Info Please update your info and hit "Submit". <% $jshead %>

<% $start %><% $state %> Enter your name: <% $field{name}{field}.$field{name}{comment} %> Select your <% $field{color}{label} %>: <% my $ret = "$field{sex}{label} = "; for (@{$field{sex}{options}}) { $ret .= qq($_->[1]
); } $ret; %> FYI, your dress size is <% $field{size}{value}.$field{size}{comment} %>
<% $submit %> <% $end %> CGI-FormBuilder-3.10/t/3a-test09.html0000644000175000017500000000037212754704556016352 0ustar davidpdavidp

Search
CGI-FormBuilder-3.10/t/3a-test04.html0000644000175000017500000000114212754704556016341 0ustar davidpdavidpContent-type: text/html TEST

TEST

First Name
Last Name
CGI-FormBuilder-3.10/t/2c-test01.html0000644000175000017500000000466112754704556016350 0ustar davidpdavidp TEST
Name
Best Color
Sex
Size
CGI-FormBuilder-3.10/t/2e-test01.html0000644000175000017500000000230712754704556016345 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is 42
CGI-FormBuilder-3.10/t/3a-test20.html0000644000175000017500000001732012754704556016344 0ustar davidpdavidpContent-type: text/html Finalize Your Order

Finalize Your Order

Don't fuck up it causes me work. Fuck try again ok?

First Name
Last Name
Email
Send Me Emails
Address
State
Zipcode
Credit Card
Expiration
CGI-FormBuilder-3.10/t/2c-test00.html0000644000175000017500000000136312754704556016343 0ustar davidpdavidp [% form.title %] [% form.jshead %] [% form.start %] [% FOREACH field = form.fields %] [% END %]
[% field.required ? "$field.label" : field.label %] [% IF field.invalid %] Missing or invalid entry, please try again.
[% END %] [% field.field %]
[% form.submit %] [% form.reset %]
[% form.end %] CGI-FormBuilder-3.10/t/1a-test29.html0000644000175000017500000000420512754704556016351 0ustar davidpdavidp

Fields that are highlighted are required.

Name
Email
User
CGI-FormBuilder-3.10/t/1a-test05.html0000644000175000017500000000405112754704556016342 0ustar davidpdavidp

Fields that are highlighted are required.

Email
First Name
CGI-FormBuilder-3.10/t/1d-messages.t0000644000175000017500000001052312754724074016325 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 1d-messages.t - messages and localization use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; use File::Find; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded my @pm; my %messages; BEGIN { die $! unless -d "$FindBin::Bin/../lib"; unshift @INC, "$FindBin::Bin/../lib"; %messages = ( form_invalid_text => 'You fucked up', js_invalid_text => 'Yep, shit sucks!', form_select_default => '*<- choose ->*', taco_salad => 'is delicious', parade => [1,2,3], form_invalid_text => '%s', form_invalid_input => 'Invalid entry', form_invalid_select => 'Select an option from this list', form_invalid_checkbox => 'Check one or more options', form_invalid_radio => 'Choose an option', form_invalid_password => 'Invalid entry', form_invalid_textarea => 'Please fill this in', form_invalid_file => 'Invalid filename', form_invalid_default => 'Invalid entry', ); # try to load all the messages .pm files find(sub{ push @pm, $File::Find::name if -f $_ && $File::Find::name =~ m#Messages/[a-z]+_[A-Z]+\.pm$#; }, "$FindBin::Bin/../lib"); die "Found 0 Messages.pm files in $FindBin::Bin/../lib, this is wrong" if @pm == 0; # die "pm = @pm"; # # There are 34 keys, times the number of modules, plus one load of the module. # Then, also add in our custom tests as well, which is two passes over # the %messages hash (above) plus 4 charset/dtd checks # require CGI::FormBuilder::Messages::default; my %hash = CGI::FormBuilder::Messages::default->messages; my $numkeys = keys %hash; my $numtests = ($numkeys * @pm) + @pm + (keys(%messages) * 2) + 4; plan tests => $numtests; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Messages, both inline and file my $locale = "fb_FAKE"; my $messages = "messages.$locale"; open(M, ">$messages") || warn "Can't write $messages: $!"; while (my($k,$v) = each %messages) { print M join(' ', $k, ref($v) ? @$v : $v), "\n"; } close(M); # Fake a submission request $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk&_submitted=1&blank=&two=&two='; use CGI::FormBuilder 3.10; # Now manually try a whole bunch of things my $hash = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/user name email/], messages => \%messages ); for my $k (sort keys %messages) { #local $" = ', '; ok($hash->messages->$k, ref($messages{$k}) ? "@{$messages{$k}}" : $messages{$k}); } my $file = CGI::FormBuilder->new( debug => $DEBUG, fields => [qw/user name email/], messages => $messages, ); for my $k (sort keys %messages) { #local $" = ', '; ok($file->messages->$k, ref($messages{$k}) ? "@{$messages{$k}}" : $messages{$k}); } unlink $messages; # Check to ensure our lang and charset work correctly { local $TESTING = 0; ok($file->charset, 'iso-8859-1'); ok($file->lang, 'en_US'); ok($file->dtd, < EOD ok($file->charset('yo.momma'), 'yo.momma'); } # Final test set is to just make sure we have all the keys for all modules require CGI::FormBuilder::Messages::default; my %need = CGI::FormBuilder::Messages::default->messages; my @keys = keys %need; for my $pm (@pm) { my($lang) = $pm =~ /([a-z]+_[A-Z]+)/; my $skip = $lang ? undef : "skip: Can't get language from $pm"; my $form; eval { $form = CGI::FormBuilder->new(messages => ":$lang"); }; skip($skip, !$@); for (@keys) { skip($skip, $form->{messages}->$_) || warn "Locale $lang: missing $_\n"; } } CGI-FormBuilder-3.10/t/1a-test09.html0000644000175000017500000000037212754704556016350 0ustar davidpdavidp
Search
CGI-FormBuilder-3.10/t/2e-template-ssi.t0000644000175000017500000001111512754724074017125 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 2e-template-ssi.t - test CGI::SSI support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded our $SKIP; BEGIN { my $numtests = 5; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # try to load template engine so absent template does # not cause all tests to fail eval "require CGI::SSI"; $SKIP = $@ ? 'skip: CGI::SSI not installed here' : 0; # eval failed, skip all tests # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # Grab our template from our test00.html file my $template = outfile(0); my $kurtlidl = outfile(99); # What options we want to use, and what we expect to see my @test = ( { opt => { fields => [qw/name color/], submit => 0, reset => 'No esta una button del submito', template => { type=>'CGI_SSI', string => $template }, validate => { name => 'NAME' }, }, mod => { color => { options => [qw/red green blue/], nameopts => 1 }, size => { value => 42 } }, }, { opt => { fields => [qw/name color size/], template => { type=>'CGI_SSI', string => $template }, values => {color => [qw/purple/], size => 8}, reset => 'Start over, boob!', validate => {}, # should be empty }, mod => { color => { options => [qw/white black other/] }, name => { size => 80 } }, }, { opt => { fields => [qw/name color email/], submit => [qw/Update Delete/], reset => 0, template => { type=>'CGI_SSI', string => $template }, values => {color => [qw/yellow green orange/]}, validate => { color => [qw(red blue yellow pink)] }, }, mod => { color => {options => [[red => 1], [blue => 2], [yellow => 3], [pink => 4]] }, size => {value => '(unknown)' } }, }, { opt => { fields => [qw/field1 field2/], method => 'post', title => 'test form page', header => 0, template => { type=>'CGI_SSI', string => $kurtlidl }, }, mod => { field1 => { value => 109, comment => 'Hello' }, field2 => { type => 'submit', value => "1 < 2 < 3", label => "Reefer", comment => 'goodbyE@' }, field3 => { type => 'button', value => "<>", comment => 'onSubmit' }, }, }, ); # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }, ); # the ${mod} key twiddles fields while(my($f,$o) = each %{$_->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # # Just compare the output of render with what's expected # the correct string output is now in external files. # The seemingly extra eval is required so that failures # to import the template modules do not kill the tests. # (since render is called regardless of whether $SKIP is set) # my $out = outfile($seq++); my $ren = $SKIP ? '' : $form->render; my $ok = skip($SKIP, $ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { #use Data::Dumper; #die Dumper($form); open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } # MORE TESTS DOWN HERE # from eszpee for tmpl_param skip($SKIP, do{ my $form2 = CGI::FormBuilder->new( template => { type=>'CGI_SSI', string => '' } ); $form2->tmpl_param(test => "this message should appear"); eval '$form2->render'; }, 'this message should appear'); CGI-FormBuilder-3.10/t/3a-test13.html0000644000175000017500000000316012754704556016343 0ustar davidpdavidp
Earth
Wind
Fire
Water
CGI-FormBuilder-3.10/t/1a-test25.html0000644000175000017500000000173112754704556016346 0ustar davidpdavidpContent-type: text/html TEST

TEST

Acct #:
Phone
Taco
Salad
CGI-FormBuilder-3.10/t/3a-test25.html0000644000175000017500000000166512754704556016356 0ustar davidpdavidp TEST

TEST

Acct #:
Phone
Taco
Salad
CGI-FormBuilder-3.10/t/1a-test24.html0000644000175000017500000000061012754704556016340 0ustar davidpdavidp
Favorite Color
CGI-FormBuilder-3.10/t/1a-test02.html0000644000175000017500000000074012754704556016340 0ustar davidpdavidp
Upper
Case
CGI-FormBuilder-3.10/t/3a-test12.html0000644000175000017500000000121512754704556016341 0ustar davidpdavidp
Earth
Wind
Fire
Water
CGI-FormBuilder-3.10/t/2a-test01.html0000644000175000017500000000257412754704556016347 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: FYI, your dress size is 42
CGI-FormBuilder-3.10/t/1a-test07.html0000644000175000017500000000343612754704556016352 0ustar davidpdavidpContent-type: text/html Econ 101

Econ 101

Supply
Demand
CGI-FormBuilder-3.10/t/3a-test05.html0000644000175000017500000000357112754704556016352 0ustar davidpdavidp

Fields that are highlighted are required.

Email
First Name
CGI-FormBuilder-3.10/t/3a-test19.html0000644000175000017500000000350112754704556016350 0ustar davidpdavidp
A
B
Please fill these in
C
CGI-FormBuilder-3.10/t/1a-test27.html0000644000175000017500000000107512754704556016351 0ustar davidpdavidp
Text1
Text2
Textthree
CGI-FormBuilder-3.10/t/1a-test01.html0000644000175000017500000000071412754704556016340 0ustar davidpdavidp
Name
Email
CGI-FormBuilder-3.10/t/2b-test03.html0000644000175000017500000000415512754704556016347 0ustar davidpdavidp User Info Please update your info and hit "Submit".

Enter your name: Select your Color: glass EYE fucker = 2
4
6
FYI, your dress size is (unknown)
CGI-FormBuilder-3.10/t/1a-generate.t0000644000175000017500000004471212754724074016314 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 1a-generate.t - test FormBuilder generation of forms use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { unshift @INC, "$FindBin::Bin/../lib"; my $numtests = 36; plan tests => $numtests + 1; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk&other_test=_other_other_test&_other_other_test=42'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # What options we want to use, and what we expect to see my @test = ( #1 { opt => { fields => [qw/name email/], sticky => 0 }, }, #2 { opt => { fields => [qw/Upper Case/], values => { Upper => 1, Case => 0 }, table => 1 }, }, #3 { opt => { fields => [qw/first_name last_name/], submit => 'Update', reset => 0 }, }, #4 { opt => { fields => [qw/first_name last_name/], submit => 'Update', reset => 0, header => 1, body => {bgcolor => 'black'} }, }, #5 { opt => { fields => {first_name => 'Nate', email => 'nate@wiger.org' }, validate => {email => 'EMAIL'}, required => [qw/first_name/], stylesheet => 1, sticky => 0 }, }, #6 { # utilize our query_string to test stickiness opt => { fields => [qw/ticket user part_number/], method => 'post', keepextras => 1, validate => { ticket => '/^\d+$/' }, submit => [qw/Update Delete Cancel/], lalign => 'left', }, }, #7 { # max it out, baby opt => { fields => [qw/supply demand/], options => { supply => [0..9], demand => [0..9] }, values => { supply => [0..4], demand => [5..9] }, method => 'PuT', title => 'Econ 101', action => '/nowhere.cgi', header => 1, name => 'econ', font => 'arial,helvetica', fieldtype => 'select', stylesheet => 1 }, }, #8 { opt => { fields => [qw/db:name db:type db:tab ux:user ux:name/], static => 1 }, }, #9 { # single-line search thing ala Yahoo! opt => { fields => 'search', submit => 'Go', reset => 0, table => 0, fieldtype => 'textarea' }, }, #10 { opt => { fields => [qw/hostname domain/], header => 1, keepextras => [qw/user ticket/], values => [qw/localhost localdomain/], validate => {hostname => 'HOST', domain => 'DOMAIN'}, }, }, #11 { opt => { fields => {first_name => 'Nate', email => 'nate@wiger.org' }, validate => {email => 'EMAIL'}, required => [qw/first_name/], javascript => 0 }, }, #12 { opt => { fields => [qw/earth wind fire water/], fieldattr => {type => 'TEXT'}}, }, #13 { opt => { fields => [qw/earth wind fire water/], options => { wind => [qw/ /], fire => [qw/&&MURDEROUS" &&HOT" &&WARM" &&COLD" &&CHILLY" &&OUT"/], }, values => { water => '>>&c0ld&<<', earth => 'Wind >>' }, columns => 1, }, }, #14 - option maxing { opt => { fields => [qw/multiopt/], values => {multiopt => [1,2,6,9]}, options => { multiopt => [ [1 => 'One'], {2 => 'Two'}, {3 => 'Three'}, {7 => 'Seven'}, [8 => 'Eight'], [9 => 'Nine'], {4 => 'Four'}, {5 => 'Five'}, [6 => 'Six'], [10 => 'Ten'] ], }, sortopts => 'NUM', }, }, #15 - obscure features { opt => { fields => [qw/plain jane mane/], nameopts => 1, stylesheet => '/my/own/style.css', styleclass => 'style_bitch', body => {ignore => 'me'}, javascript => 0, jsfunc => " // -- user jsfunc option --\n", labels => {plain => 'AAA', jane => 'BBB'}, options => {mane => [qw/ratty nappy mr_happy/]}, selectnum => 0, title => 'Bobby', header => 1, }, }, #16 { opt => { fields => [qw/name email/], sticky => 0 }, mod => { name => {comment => 'Hey buddy'}, email => {comment => 'No email >> address??'} }, }, #17 { opt => { fields => [qw/won too many/], columns => 1 }, mod => { won => { jsclick => 'taco_punch = 1'}, too => { options => [0..2], jsclick => 'this.salami.value = "delicious"'}, many => { options => [0..9], jsclick => 'this.ham.value = "it\'s a pig, man!"'}, }, }, #18 { opt => { fields => [qw/refsort/] }, mod => { refsort => { sortopts => \&refsort, options => [qw/99 9 8 83 7 73 6 61 66 5 4 104 3 2 10 1 101/] } }, }, #19 - table attr and field columns { opt => { fields => [qw/a b c/], table => { border => 1 }, td => { taco => 'beef', align => 'right' }, tr => { valign => 'top' }, th => { ignore => 'this' }, lalign => 'today', selectnum => 10, }, mod => { a => { options => [0..3], columns => 2, value => [1..2] }, b => { options => [4..9], columns => 3, comment => "Please fill these in" }, }, }, #20 - order.cgi from manpage (big) { opt => { method => 'post', stylesheet => 1, # test 20 styleclass => 'shop', name => 'order', fields => [ qw(first_name last_name email send_me_emails address state zipcode credit_card expiration) ], header => 1, title => 'Finalize Your Order', submit => ['Place Order', 'Cancel'], reset => 0, columns => 1, validate => { email => 'EMAIL', zipcode => 'ZIPCODE', credit_card => 'CARD', expiration => 'MMYY', }, required => 'ALL', jsfunc => < { state => { options => [qw(JS IW KS UW JS UR EE DJ HI YK NK TY)], sortopts=> 'NAME' }, send_me_emails => { options => [[1 => 'Yes'], [0 => 'No']], value => 0, # "No" }, }, }, #21 - "other" fields { opt => { javascript => 1, columns => 1, }, mod => { favorite_color => { name => 'favorite_color', options => [qw(red green blue yellow)], validate => 'NAME', other => 1 } }, }, #22 - "other" fields { opt => { javascript => 0, method => "post", columns => 1, }, mod => { favorite_color => { name => 'favorite_color', options => [qw(red green blue yellow)], validate => 'NAME', other => 1 } }, }, #23 - growable fields { opt => {}, mod => { favorite_color => { name => 'favorite_color', growable => 1 } }, }, #24 - growable fields { opt => {javascript => 0}, mod => { favorite_color => { name => 'favorite_color', growable => 1 } }, }, #25 - sessionids and fieldopts { opt => { sessionid => 'H8N0TAC5', header => 1, fields => [qw(acct: phone() taco.punch salad$)], fieldopts => { 'acct:' => { true => 'false', label => 'Acct #:' }, 'phone()' => { options => [1], columns => 1, }, missing => { value => 'not here', force => 1} }, }, }, #26 - disabled forms { opt => { disabled => 'YES', cleanopts => 0, columns => 1, fields => [qw(acct phone taco salad)], fieldopts => {acct => {type => 'radio', options => [qw(on OFF)]}} }, }, #27 - autofill fields { opt => { fields => [qw(text1 text2 textthree)], columns => 1, fieldopts => {text2 => { id => 'mommy' }}, }, }, #28 - new stylesheets to test all variations { opt => { stylesheet => 'fbstyle.css', submit => [qw(Update Delete)], reset => 'Showme', method => 'POST', fields => [qw(fullname gender fav_color lover)], # need hash order header => 1, columns => 1, messages => 'auto', }, mod => { fullname => { label => 'Full Name', type => 'text', required => 1, }, gender => { label => 'Sex', options => [qw(M F)], comment => "It's one or the other", }, fav_color => { label => 'Favy Colour', options => [qw(Red Green Blue Orange Yellow Purple)], comment => 'Choose just one, even if you have more than one', invalid => 1, # tricky }, lover => { label => 'Things you love', options => [qw(Sex Drugs Rock+Roll)], multiple => 1, }, }, }, #29 - sticky in render() { opt => { fields => [qw(name email user)], values => {name => '_name_', email => '_email_', user => '_user_'}, sticky => 0, required => 0, javascript => 0, }, ren => { sticky => 1, required => 'ALL', javascript => 'auto', }, }, #30 - optgroups and selectname { opt => { fields => [qw(browser)], fieldtype => 'select', }, mod => { browser => { selectname => 1, options => [ [ '', '' ], [ '1', 'C', '' ], [ '10', 'D1', '' ], [ '9', 'D2', '' ], [ '7', 'Option 1', 'D3' ], [ '8', 'Option 2', 'D3' ], [ '2', 'H', '' ], [ '3', 'I', '' ], [ '4', 'Option 1', 'J' ], [ '40', 'Option 2', 'J' ], [ '29', 'A', 'S' ], [ '27', 'C', 'S' ], [ '12', 'E', 'S' ], [ '14', 'F', 'S' ], [ '13', 'G', 'S' ], [ '30', 'O', 'S' ], [ '28', 'P', 'S' ], [ '6', 'T', '' ], [ '22', 'V A', '' ], [ '16', 'Option 1', 'V1' ], [ '17', 'Option 2', 'V2' ], [ '18', 'Option 3', 'V2' ], [ '5', 'W', '' ] ], optgroups => { J => 'Jerky', S => 'Shoddy', }, }, select2 => { selectname => 0, options => [qw(a b)], }, select3 => { selectname => 'choosey2', options => [qw(a b)], }, }, }, #31 - Backbase tagname support (experiemental) { opt => { stylesheet => 'fbstyle.css', submit => [qw(Update Delete)], reset => 'Showme', method => 'POST', fields => [qw(fullname gender fav_color lover)], # need hash order header => 1, columns => 1, messages => 'auto', tagnames => { name => 'b:name', select => 'b:select', value => 'b:value', option => 'b:option', input => 'b:input', table => 'div', tr => 'div', th => 'div', td => 'div', }, }, mod => { fullname => { label => 'Full Name', type => 'text', required => 1, }, gender => { label => 'Sex', options => [qw(M F)], comment => "It's one or the other", }, fav_color => { label => 'Favy Colour', options => [qw(Red Green Blue Orange Yellow Purple)], comment => 'Choose just one, even if you have more than one', invalid => 1, # tricky }, lover => { label => 'Things you love', options => [qw(Sex Drugs Rock+Roll)], multiple => 1, }, }, }, #32 - fieldsets { opt => { name => 'account', fieldsets => [[acct=>'Account Information'], [prefs=>'User Preferences'], [phone=>'Phone Number(s)']], stylesheet => 1, fields => [qw/first_name last_name outside_1 email home_phone new_set work_phone call_me email_me outside_2 sex outside_3/], }, mod => { first_name => { fieldset => 'acct' }, last_name => { fieldset => 'acct' }, email => { fieldset => 'acct' }, home_phone => { fieldset => 'phone' }, work_phone => { fieldset => 'phone' }, new_set => { fieldset => 'Inline Created' }, call_me => { fieldset => 'prefs' }, email_me => { fieldset => 'prefs' }, first_name => { fieldset => 'acct' }, sex => { fieldset => 'acct', options => [qw/Yes No/] }, }, }, #33 - builtin Div.pm "template" support { opt => { name => 'parts', fields => [qw/ticket user email part_number/], fieldsets => [[acct=>'Account Information'], [prefs=>'Part Information']], method => 'post', keepextras => 1, validate => { ticket => '/^\d+$/' }, submit => [qw/Update Delete Cancel/], lalign => 'left', template => {type => 'div'}, stylesheet => 1, }, mod => { ticket => { fieldset => 'acct' }, email => { fieldset => 'prefs' }, }, }, # Older tests moved from 1b-fields #34 - misc checkboxes { opt => { fields => [qw/name color/], labels => {color => 'Favorite Color'}, validate => {email => 'EMAIL'}, required => [qw/name/], sticky => 0, columns => 1, action => 'TEST', title => 'TEST', }, mod => { color => { options => [qw(red> green& blue")], multiple => 1, cleanopts => 0, }, name => { options => [qw(lower UPPER)], nameopts => 1, }, }, }, #35 { # check individual fields as static opt => { fields => [qw/name email color/], action => 'TEST', columns => 1 }, mod => { name => { static => 1 }, email => { type => 'static' }, }, }, #36 { opt => { fields => [qw/name color hid1 hid2/], action => 'TEST', columns => 1, values => { hid1 => 'Val1a' }, }, mod => { name => { static => 1, type => 'text' }, hid1 => { type => 'hidden', value => 'Val1b' }, # should replace Val1a hid2 => { type => 'hidden', value => 'Val2' }, color => { value => 'blew', options => [qw(read blew yell)] }, Tummy => { value => [qw(lg xxl)], options => [qw(sm med lg xl xxl xxxl)] }, }, }, ); sub refsort { $_[0] <=> $_[1] } # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; $ENV{HTTP_ACCEPT_LANGUAGE} = 'en_US'; # To test local %TAGNAMES $CGI::FormBuilder::Util::TAGNAMES{name} = 'yellow'; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, header => $ENV{HEADER} || 0, action => 'TEST', # testing title => 'TEST', %{ $_->{opt} } ); # the ${mod} key twiddles fields for my $f ( sort keys %{$_->{mod} || {}} ) { my $o = $_->{mod}{$f}; $o->{name} = $f; $form->field(%$o); } # just compare the output of render with what's expected # the correct string output is now in external files my $out = outfile($seq++); my $ren = $form->render(%{$_->{ren} || {}}); my $ok = ok($ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } ok($CGI::FormBuilder::Util::TAGNAMES{name}, 'yellow'); CGI-FormBuilder-3.10/t/2a-test04.html0000644000175000017500000000222712754704556016345 0ustar davidpdavidp Test
test form page:
Field1 Hello
Reefer goodbyE@
Field3 onSubmit

CGI-FormBuilder-3.10/t/2b-template-text.t0000644000175000017500000001070512754724074017314 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) 2000-2006 Nathan Wiger . # All Rights Reserved. If you're reading this, you're bored. # 2b-template-text.t - test Text::Template support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded our $SKIP; BEGIN { my $numtests = 4; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # try to load template engine so absent template does # not cause all tests to fail eval "require Text::Template"; $SKIP = $@ ? 'skip: Text::Template not installed here' : 0; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # Create our template and store it in a scalarref my $template = outfile(0); # What options we want to use, and what we expect to see my @test = ( { opt => { fields => [qw/name color/], submit => 'No esta una button del resetto', template => { type => 'Text', TYPE => 'STRING', template => $template, }, validate => { name => 'NAME' }, }, mod => { color => { options => [qw/red green blue/], label => 'Best Color', value => 'red' }, size => { value => 42 }, sex => { options => [[M=>'Male'],[F=>'Female']] } }, }, { opt => { fields => [qw/name color size/], template => { type => 'Text', TYPE => 'STRING', template => $template, }, values => {color => [qw/purple/], size => 8}, submit => 'Start over, boob!', }, mod => { color => { options => [[white=>'White'],[black=>'Black'],[red=>'Green']], label => 'Mom', }, name => { size => 80, maxlength => 80, comment => 'Fuck off' }, sex => { options => [[1=>'Yes'], [0=>'No'], [-1=>'Maybe']], label => 'Fuck me?
' }, }, }, { opt => { fields => [qw/name color email/], submit => [qw/Update Delete/], reset => 0, template => { type => 'Text', TYPE => 'STRING', template => $template, }, values => {color => [qw/yellow green orange/]}, validate => { sex => [qw(1 3 5)] }, }, mod => { color => {options => [[red => 1], [blue => 2], [yellow => 3], [pink => 4]] }, size => {comment => '(unknown)', value => undef, force => 1 } , sex => {label => 'glass EYE fucker', options => [[1,2],[3,4],[5,6]] }, }, }, ); # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }, ); # the ${mod} key twiddles fields while(my($f,$o) = each %{$_->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # # Just compare the output of render with what's expected # the correct string output is now in external files. # The seemingly extra eval is required so that failures # to import the template modules do not kill the tests. # (since render is called regardless of whether $SKIP is set) # my $out = outfile($seq++); my $ren = $SKIP ? '' : $form->render; my $ok = skip($SKIP, $ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } # MORE TESTS DOWN HERE # from eszpee for tmpl_param skip($SKIP, do{ my $form2 = CGI::FormBuilder->new( template => { type => 'Text', engine => {TYPE => 'STRING', SOURCE => '<% $test %>'} } ); $form2->tmpl_param(test => "this message should appear"); eval '$form2->render'; }, 'this message should appear'); CGI-FormBuilder-3.10/t/2c-template-tt2.t0000644000175000017500000001074112754724074017042 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) 2000-2006 Nathan Wiger . # All Rights Reserved. If you're reading this, you're bored. # 2c-template-tt2.t - test Template AssKit support use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded our $SKIP; BEGIN { my $numtests = 4; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # try to load template engine so absent template does # not cause all tests to fail eval "require Template"; $SKIP = $@ ? 'skip: Template Toolkit not installed here' : 0; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'ticket=111&user=pete&replacement=TRUE'; use CGI::FormBuilder 3.10; use CGI::FormBuilder::Test; # Create our template and store it in a scalarref my $template = outfile(0); # What options we want to use, and what we expect to see my @test = ( { opt => { fields => [qw/name color/], submit => 'No esta una button del resetto', template => { type => 'TT2', template => \$template, variable => 'form' }, validate => { name => 'NAME' }, }, mod => { color => { options => [qw/red green blue/], label => 'Best Color', value => 'red' }, size => { value => 42 }, sex => { options => [[M=>'Male'],[F=>'Female']] } }, }, { opt => { fields => [qw/name color size/], template => { type => 'TT2', template => \$template, variable => 'form' }, values => {color => [qw/purple/], size => 8}, submit => 'Start over, boob!', }, mod => { color => { options => [[white=>'White'],[black=>'Black'],[red=>'Green']], label => 'Mom', }, name => { size => 80, maxlength => 80, comment => 'Fuck off' }, sex => { options => [[1=>'Yes'], [0=>'No'], [-1=>'Maybe']], label => 'Fuck me?
' }, }, }, { opt => { fields => [qw/name color email/], submit => [qw/Update Delete/], reset => 0, template => { type => 'TT2', template => \$template, variable => 'form' }, values => {color => [qw/yellow green orange/]}, validate => { sex => [qw(1 3 5)] }, }, mod => { color => {options => [[red => 1], [blue => 2], [yellow => 3], [pink => 4]] }, size => {comment => '(unknown)', value => undef, force => 1 } , sex => {label => 'glass EYE fucker', options => [[1,2],[3,4],[5,6]] }, }, }, { opt => { fields => [qw/yomomma mymomma/], submit => [qw/Remove Dance_With/], reset => 1, template => { type => 'TT2', template => \$template, variable => 'form' }, values => {mymomma => [qw/medium large xxl/]}, validate => { yomomma => 'NAME' }, }, mod => {}, }, ); # Perl 5 is sick sometimes. @test = @test[$ARGV[0] - 1] if @ARGV; my $seq = $ARGV[0] || 1; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }, ); # the ${mod} key twiddles fields for my $f ( sort keys %{$_->{mod} || {}} ) { my $o = $_->{mod}{$f}; $o->{name} = $f; $form->field(%$o); } # # Just compare the output of render with what's expected # the correct string output is now in external files. # The seemingly extra eval is required so that failures # to import the template modules do not kill the tests. # (since render is called regardless of whether $SKIP is set) # my $out = outfile($seq++); my $ren = $SKIP ? '' : $form->render; my $ok = skip($SKIP, $ren, $out); if (! $ok && $LOGNAME eq 'nwiger') { open(O, ">/tmp/fb.1.html"); print O $out; close O; open(O, ">/tmp/fb.2.html"); print O $ren; close O; system "diff /tmp/fb.1.html /tmp/fb.2.html"; exit 1; } } CGI-FormBuilder-3.10/t/1c-validate.t0000644000175000017500000001150012754724074016302 0ustar davidpdavidp#!/usr/bin/perl # Copyright (c) Nate Wiger http://nateware.com. # All Rights Reserved. If you're reading this, you're bored. # 1c-validate.t - test validation use strict; our $TESTING = 1; our $DEBUG = $ENV{DEBUG} || 0; our $LOGNAME = $ENV{LOGNAME} || ''; our $VERSION; BEGIN { $VERSION = '3.10'; } use Test; use FindBin; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { my $numtests = 13; unshift @INC, "$FindBin::Bin/../lib"; plan tests => $numtests; # success if we said NOTEST if ($ENV{NOTEST}) { ok(1) for 1..$numtests; exit; } } # Need to fake a request or else we stall $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = '_submitted=1&submit=ClickMe&blank=&hiphop=Early+East+Coast'; use CGI::FormBuilder 3.10; sub is_number { my $v = shift; return $v =~ /^\d+$/; } # What options we want to use, and data to validate my @test = ( #1 { opt => { fields => [qw/first_name email/], validate => {email => 'EMAIL'}, required => [qw/first_name/] , values => { first_name => 'Nate', email => 'nate@wiger.org' }, }, pass => 1, }, #2 { # max it out, baby opt => { fields => [qw/supply demand/], options => { supply => [0..9], demand => [0..9] }, values => { supply => [0..4], demand => [5..7] }, validate => { supply => [5..9], demand => [0..9] }, }, pass => 0, }, #3 { # max it out, baby opt => { fields => [qw/supply tag/], options => { supply => [0..9], }, values => { supply => [0..4], tag => ['Johan-Sebastian', 'Bach'] }, validate => { supply => 'NUM', tag => 'NAME' }, }, pass => 0, }, #4 { opt => { fields => [qw/date time ip_addr name time_confirm/], validate => { date => 'DATE', time => 'TIME', ip_addr => 'IPV4', time_confirm => 'eq $form->field("time")' }, values => { date => '03/30/2003', time => '1:30', ip_addr => '129.153.53.1', time_confirm => '1:30' }, }, pass => 1, }, #5 { opt => { fields => [qw/security_test/], validate => { security_test => 'ne 42' }, values => { security_test => "'; print join ':', \@INC; return; '" }, }, pass => 1, }, #6 { opt => { fields => [qw/security_test2/], validate => { security_test2 => 'ne 42' }, values => { security_test2 => 'foo\';`cat /etc/passwd`;\'foo' }, }, pass => 1, }, #7 { opt => { fields => [qw/subref_num/], values => {subref_num => [0..9]}, validate => {subref_num => \&is_number}, }, pass => 1, }, #8 { opt => { fields => [qw/blank/], values => {blank => '1@2.com'}, validate => {blank => 'EMAIL'}, required => 'NONE', }, pass => 1, }, #9 { opt => { fields => [qw/blank/], values => {blank => '1@2.com'}, validate => {blank => 'EMAIL'}, required => [qw/blank/], }, pass => 0, # should fail }, #10 { opt => { fields => [qw/tomato potato/], values => {tomato => 'TomaTo', potato => '~SQUASH~'}, validate => {tomato => {perl => '=~ /^TomaTo$/', javascript => 'placeholder'}, potato => {perl => 'VALUE', javascript => 'placeholder'}, }, }, pass => 1, }, #11 { opt => { fields => [qw/have you seen/], values => { you => 'me', seen => 'OB', have => "Nothing" }, validate => { have => '/^Not/' }, required => 'ALL' }, pass => 1, }, #12 { opt => { fields => [qw/required_zero required_space/], values => { required_zero => '0', required_space => ' ' }, required => 'ALL' }, pass => 1, }, #13 { opt => { fields => [qw/required_empty/], values => { required_empty => '' }, required => 'ALL' }, pass => 0, }, ); # Cycle thru and try it out for my $t (@test) { my $form = CGI::FormBuilder->new( %{ $t->{opt} }, debug => $DEBUG ); while(my($f,$o) = each %{$t->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # just try to validate ok($form->validate, $t->{pass} || 0); } CGI-FormBuilder-3.10/t/3a-test08.html0000644000175000017500000000123112754704556016344 0ustar davidpdavidp
Db Name
Db Type
Db Tab
Ux User
Ux Name
CGI-FormBuilder-3.10/t/1b-test26.html0000644000175000017500000000103212754704556016342 0ustar davidpdavidp CGI-FormBuilder-3.10/t/3a-test10.html0000644000175000017500000000416612754704556016347 0ustar davidpdavidpContent-type: text/html TEST

TEST

Fields that are highlighted are required.

Hostname
Domain
CGI-FormBuilder-3.10/MANIFEST0000644000175000017500000001007612754724222014713 0ustar davidpdavidpChanges INSTALL MANIFEST Makefile.PL Makefile.PL README lib/CGI/FormBuilder.pm lib/CGI/FormBuilder.pod lib/CGI/FormBuilder/Field.pm lib/CGI/FormBuilder/Field/button.pm lib/CGI/FormBuilder/Field/checkbox.pm lib/CGI/FormBuilder/Field/date.pm lib/CGI/FormBuilder/Field/datetime.pm lib/CGI/FormBuilder/Field/datetime_local.pm lib/CGI/FormBuilder/Field/email.pm lib/CGI/FormBuilder/Field/file.pm lib/CGI/FormBuilder/Field/hidden.pm lib/CGI/FormBuilder/Field/image.pm lib/CGI/FormBuilder/Field/number.pm lib/CGI/FormBuilder/Field/password.pm lib/CGI/FormBuilder/Field/radio.pm lib/CGI/FormBuilder/Field/select.pm lib/CGI/FormBuilder/Field/static.pm lib/CGI/FormBuilder/Field/submit.pm lib/CGI/FormBuilder/Field/text.pm lib/CGI/FormBuilder/Field/textarea.pm lib/CGI/FormBuilder/Field/time.pm lib/CGI/FormBuilder/Field/url.pm lib/CGI/FormBuilder/Messages.pm lib/CGI/FormBuilder/Messages/C.pm lib/CGI/FormBuilder/Messages/_example.pm lib/CGI/FormBuilder/Messages/base.pm lib/CGI/FormBuilder/Messages/da.pm lib/CGI/FormBuilder/Messages/da_DK.pm lib/CGI/FormBuilder/Messages/de.pm lib/CGI/FormBuilder/Messages/de_DE.pm lib/CGI/FormBuilder/Messages/default.pm lib/CGI/FormBuilder/Messages/en.pm lib/CGI/FormBuilder/Messages/en_US.pm lib/CGI/FormBuilder/Messages/es.pm lib/CGI/FormBuilder/Messages/es_ES.pm lib/CGI/FormBuilder/Messages/fr.pm lib/CGI/FormBuilder/Messages/fr_FR.pm lib/CGI/FormBuilder/Messages/ja.pm lib/CGI/FormBuilder/Messages/ja_JP.pm lib/CGI/FormBuilder/Messages/no.pm lib/CGI/FormBuilder/Messages/no_NO.pm lib/CGI/FormBuilder/Messages/ru.pm lib/CGI/FormBuilder/Messages/ru_RU.pm lib/CGI/FormBuilder/Messages/sv.pm lib/CGI/FormBuilder/Messages/sv_SE.pm lib/CGI/FormBuilder/Messages/tr.pm lib/CGI/FormBuilder/Messages/tr_TR.pm lib/CGI/FormBuilder/Multi.pm lib/CGI/FormBuilder/Source.pm lib/CGI/FormBuilder/Source/File.pm lib/CGI/FormBuilder/Template.pm lib/CGI/FormBuilder/Template/Builtin.pm lib/CGI/FormBuilder/Template/CGI_SSI.pm lib/CGI/FormBuilder/Template/Div.pm lib/CGI/FormBuilder/Template/Fast.pm lib/CGI/FormBuilder/Template/HTML.pm lib/CGI/FormBuilder/Template/TT2.pm lib/CGI/FormBuilder/Template/Text.pm lib/CGI/FormBuilder/Test.pm lib/CGI/FormBuilder/Util.pm pod/Changes.pod pod/INSTALL.pod pod/README.pod t/1a-generate.t t/1a-test01.html t/1a-test02.html t/1a-test03.html t/1a-test04.html t/1a-test05.html t/1a-test06.html t/1a-test07.html t/1a-test08.html t/1a-test09.html t/1a-test10.html t/1a-test11.html t/1a-test12.html t/1a-test13.html t/1a-test14.html t/1a-test15.html t/1a-test16.html t/1a-test17.html t/1a-test18.html t/1a-test19.html t/1a-test20.html t/1a-test21.html t/1a-test22.html t/1a-test23.html t/1a-test24.html t/1a-test25.html t/1a-test26.html t/1a-test27.html t/1a-test28.html t/1a-test29.html t/1a-test30.html t/1a-test31.html t/1a-test32.html t/1a-test33.html t/1a-test34.html t/1a-test35.html t/1a-test36.html t/1b-fields.t t/1b-test24.html t/1b-test25.html t/1b-test26.html t/1c-validate.t t/1d-messages.t t/2a-template-html.t t/2a-test00.html t/2a-test01.html t/2a-test02.html t/2a-test03.html t/2a-test04.html t/2a-test99.html t/2b-template-text.t t/2b-test00.html t/2b-test01.html t/2b-test02.html t/2b-test03.html t/2c-template-tt2.t t/2c-test00.html t/2c-test01.html t/2c-test02.html t/2c-test03.html t/2c-test04.html t/2d-template-fast.t t/2d-test01.html t/2d-test02.html t/2d-test03.html t/2e-template-ssi.t t/2e-test00.html t/2e-test01.html t/2e-test02.html t/2e-test03.html t/2e-test04.html t/2e-test99.html t/3a-source-file.t t/3a-test01.html t/3a-test02.html t/3a-test03.html t/3a-test04.html t/3a-test05.html t/3a-test06.html t/3a-test07.html t/3a-test08.html t/3a-test09.html t/3a-test10.html t/3a-test11.html t/3a-test12.html t/3a-test13.html t/3a-test14.html t/3a-test15.html t/3a-test16.html t/3a-test17.html t/3a-test18.html t/3a-test19.html t/3a-test20.html t/3a-test21.html t/3a-test22.html t/3a-test23.html t/3a-test24.html t/3a-test25.html t/3a-test26.html t/3a-test27.html t/3a-test28.html t/3b-multi-page.t t/3b-test22.html META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) CGI-FormBuilder-3.10/lib/0000755000175000017500000000000012754724222014324 5ustar davidpdavidpCGI-FormBuilder-3.10/lib/CGI/0000755000175000017500000000000012754724222014726 5ustar davidpdavidpCGI-FormBuilder-3.10/lib/CGI/FormBuilder.pm0000644000175000017500000015111312754724074017505 0ustar davidpdavidp ########################################################################### # Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved. # Please visit http://formbuilder.org for tutorials, support, and examples. ########################################################################### # Note: Documentation has grown so massive it is now in FormBuilder.pod package CGI::FormBuilder; use Carp; use strict; use warnings; no warnings 'uninitialized'; use Scalar::Util qw(weaken); use CGI::FormBuilder::Util; use CGI::FormBuilder::Field; use CGI::FormBuilder::Messages; our $VERSION = '3.10'; our $AUTOLOAD; # Default options for FormBuilder our %DEFAULT = ( sticky => 1, method => 'get', submit => 1, reset => 0, header => 0, body => { }, text => '', table => { }, tr => { }, th => { }, td => { }, div => { }, jsname => 'validate', jsprefix => 'fb_', # prefix for JS tags sessionidname => '_sessionid', submittedname => '_submitted', pagename => '_page', template => '', # default template debug => 0, # can be 1 or 2 javascript => 'auto', # 0, 1, or 'auto' cookies => 1, cleanopts => 1, render => 'render', # render sub name smartness => 1, # can be 1 or 2 selectname => 1, # include -select-? selectnum => 5, stylesheet => 0, # use stylesheet stuff? styleclass => 'fb', # style class to use # For translating tag names (experimental) tagnames => { }, # I don't see any reason why these are variables formname => '_form', submitname => '_submit', resetname => '_reset', bodyname => '_body', tabname => '_tab', rowname => '_row', labelname => '_label', fieldname => '_field', # equiv of buttonname => '_button', errorname => '_error', othername => '_other', growname => '_grow', statename => '_state', extraname => '_extra', dtd => <<'EOD', # modified from CGI.pm EOD ); # Which options to rearrange from new() into field() our %REARRANGE = qw( options options optgroups optgroups labels label validate validate required required selectname selectname selectnum selectnum sortopts sortopts nameopts nameopts cleanopts cleanopts sticky sticky disabled disabled columns columns ); *redo = \&new; sub new { local $^W = 0; # -w sucks my $self = shift; # A single arg is a source; others are opt => val pairs my %opt; if (@_ == 1) { %opt = UNIVERSAL::isa($_[0], 'HASH') ? %{ $_[0] } : ( source => shift() ); } else { %opt = arghash(@_); } # Pre-check for an external source if (my $src = delete $opt{source}) { # check for engine type my $mod; my $sopt; # opts returned from parsing my $ref = ref $src; unless ($ref) { # string filename; redo format (ala $self->{template}) $src = { type => 'File', source => $src, # pass catalyst class for \&validate refs ($opt{c} && $opt{c}->action) ? (caller => $opt{c}->action->class) : () }; $ref = 'HASH'; # tricky debug 2, "rewrote 'source' option since found filename"; } debug 1, "creating form from source ", $ref || $src; if ($ref eq 'HASH') { # grab module $mod = delete $src->{type} || 'File'; # user can give 'Their::Complete::Module' or an 'IncludedTemplate' $mod = join '::', __PACKAGE__, 'Source', $mod unless $mod =~ /::/; debug 1, "loading $mod for 'source' option"; eval "require $mod"; puke "Bad source module $mod: $@" if $@; my $sob = $mod->new(%$src); $sopt = $sob->parse; } elsif ($ref eq 'CODE') { # subroutine wrapper $sopt = &{$src->{source}}($self); } elsif (UNIVERSAL::can($src->{source}, 'parse')) { # instantiated object $sopt = $src->{source}->parse($self); } elsif ($ref) { puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ parse()"; } # per-instance variables win while (my($k,$v) = each %$sopt) { $opt{$k} = $v unless exists $opt{$k}; } } if (ref $self) { # cloned/original object debug 1, "rewriting existing FormBuilder object"; while (my($k,$v) = each %opt) { $self->{$k} = $v; } } else { debug 1, "constructing new FormBuilder object"; # damn deep copy this is SO damn annoying while (my($k,$v) = each %DEFAULT) { next if exists $opt{$k}; if (ref $v eq 'HASH') { $opt{$k} = { %$v }; } elsif (ref $v eq 'ARRAY') { $opt{$k} = [ @$v ]; } else { $opt{$k} = $v; } } $self = bless \%opt, $self; } # Create our CGI object if not present unless (ref $self->{params}) { require CGI; $CGI::USE_PARAM_SEMICOLONS = 0; # fuck ; in urls $self->{params} = CGI->new($self->{params}); } # XXX not mod_perl safe $CGI::FormBuilder::Util::DEBUG = $ENV{FORMBUILDER_DEBUG} || $self->{debug}; # And a messages delegate if not existent # Handle 'auto' mode by trying to detect from request # Can't do this in ::Messages because it has no CGI knowledge if (lc($self->{messages}) eq 'auto') { my $lang = $self->{messages}; # figure out the messages from our params object if (UNIVERSAL::isa($self->{params}, 'CGI')) { $lang = $self->{params}->http('Accept-Language'); } elsif (UNIVERSAL::isa($self->{params}, 'Apache')) { $lang = $self->{params}->headers_in->get('Accept-Language'); } elsif (UNIVERSAL::isa($self->{params}, 'Catalyst::Request')) { $lang = $self->{params}->headers->header('Accept-Language'); } else { # last-ditch effort $lang = $ENV{HTTP_ACCEPT_LANGUAGE} || $ENV{LC_MESSAGES} || $ENV{LC_ALL} || $ENV{LANG}; } $lang ||= 'default'; $self->{messages} = CGI::FormBuilder::Messages->new(":$lang"); } else { # ref or filename (::Messages will decode) $self->{messages} = CGI::FormBuilder::Messages->new($self->{messages}); } # Initialize form fields (probably a good idea) if ($self->{fields}) { debug 1, "creating fields list"; # check to see if 'fields' is a hash or array ref my $ref = ref $self->{fields}; if ($ref && $ref eq 'HASH') { # with a hash ref, we setup keys/values debug 2, "got fields list from HASH"; while(my($k,$v) = each %{$self->{fields}}) { $k = lc $k; # must lc to ignore case $self->{values}{$k} = [ autodata $v ]; } # reset main fields to field names $self->{fields} = [ sort keys %{$self->{fields}} ]; } else { # rewrite fields to ensure format debug 2, "assuming fields list from ARRAY"; $self->{fields} = [ autodata $self->{fields} ]; } } if (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) { debug 2, "got a Data::FormValidator for validate"; # we're being a bit naughty and peeking inside the DFV object $self->{required} = $self->{validate}{profiles}{fb}{required}; } else { # Catch the intersection of required and validate if (ref $self->{required}) { # ok, will handle itself automatically below } elsif ($self->{required}) { # catches for required => 'ALL'|'NONE' if ($self->{required} eq 'NONE') { delete $self->{required}; # that's it } elsif ($self->{required} eq 'ALL') { $self->{required} = [ @{$self->{fields}} ]; } elsif ($self->{required}) { # required => 'single_field' catch $self->{required} = { $self->{required} => 1 }; } } elsif ($self->{validate}) { # construct a required list of all validated fields $self->{required} = [ keys %{$self->{validate}} ]; } } # Now, new for the 3.x series, we cycle thru the fields list and # replace it with a list of objects, which stringify to field names my @ftmp = (); for (@{$self->{fields}}) { my %fprop = %{$self->{fieldopts}{$_} || {}}; # field properties if (ref $_ =~ /^CGI::FormBuilder::Field/i) { # is an existing Field object, so update its properties $_->field(%fprop); } else { # init a new one $fprop{name} = "$_"; $_ = $self->new_field(%fprop); weaken($_->{_form}); } debug 2, "push \@(@ftmp), $_"; weaken($self->{fieldrefs}{"$_"} = $_); push @ftmp, $_; } # stringifiable objects (overwrite previous container) $self->{fields} = \@ftmp; # setup values $self->values($self->{values}) if $self->{values}; debug 1, "field creation done, list = (@ftmp)"; return $self; } *param = \&field; *params = \&field; *fields = \&field; sub field { local $^W = 0; # -w sucks my $self = shift; debug 2, "called \$form->field(@_)"; # Handle any of: # # $form->field($name) # $form->field(name => $name, arg => 'val') # $form->field(\@newlist); # return $self->new(fields => $_[0]) if ref $_[0] eq 'ARRAY' && @_ == 1; my $name = (@_ % 2 == 0) ? '' : shift(); my $args = arghash(@_); $args->{name} ||= $name; # no name - return ala $cgi->param unless ($args->{name}) { # sub fields # return an array of the names in list context, and a # hashref of name/value pairs in a scalar context if (wantarray) { # pre-scan for any "order" arguments, reorder, delete for my $redo (grep { $_->order } @{$self->{fields}}) { next if $redo->order eq 'auto'; # like javascript # kill existing order for (my $i=0; $i < @{$self->{fields}}; $i++) { if ($self->{fields}[$i] eq $redo) { debug 2, "reorder: removed $redo from \$fields->[$i]"; splice(@{$self->{fields}}, $i, 1); } } # put it in its new place debug 2, "reorder: moving $redo to $redo->{order}"; if ($redo->order <= 1) { # start unshift @{$self->{fields}}, $redo; } elsif ($redo->order >= @{$self->{fields}}) { # end push @{$self->{fields}}, $redo; } else { # middle splice(@{$self->{fields}}, $redo->order - 1, 0, $redo); } # kill subsequent reorders (unnecessary) delete $redo->{order}; } # list of all field objects debug 2, "return (@{$self->{fields}})"; return @{$self->{fields}}; } else { # this only returns a single scalar value for each field return { map { $_ => scalar($_->value) } @{$self->{fields}} }; } } # have name, so redispatch to field member debug 2, "searching fields for '$args->{name}'"; if ($args->{delete}) { # blow the thing away delete $self->{fieldrefs}{$args->{name}}; my @tf = grep { $_->name ne $args->{name} } @{$self->{fields}}; $self->{fields} = \@tf; return; } elsif (my $f = $self->{fieldrefs}{$args->{name}}) { delete $args->{name}; # segfault?? return $f->field(%$args); # set args, get value back } # non-existent field, and no args, so assume we're checking for it return unless keys %$args > 1; # if we're still in here, we need to init a new field # push it onto our mail fields array, just like initfields() my $f = $self->new_field(%$args); weaken($self->{fieldrefs}{"$f"} = $f); weaken($f->{_form}); weaken($f->{fieldrefs}{"$f"}); push @{$self->{fields}}, $f; return $f->value; } sub new_field { my $self = shift; my $args = arghash(@_); puke "Need a name for \$form->new_field()" unless exists $args->{name}; debug 1, "called \$form->new_field($args->{name})"; # extract our per-field options from rearrange while (my($from,$to) = each %REARRANGE) { next unless exists $self->{$from}; next if defined $args->{$to}; # manually set my $tval = rearrange($self->{$from}, $args->{name}); debug 2, "rearrange: \$args->{$to} = $tval;"; $args->{$to} = $tval; } $args->{type} = lc $self->{fieldtype} if $self->{fieldtype} && ! exists $args->{type}; if ($self->{fieldattr}) { # legacy while (my($k,$v) = each %{$self->{fieldattr}}) { next if exists $args->{$k}; $args->{$k} = $v; } } my $f = CGI::FormBuilder::Field->new($self, $args); debug 1, "created field $f"; return $f; # already set args above ^^^ } *fieldset = \&fieldsets; sub fieldsets { my $self = shift; if (@_) { if (ref($_[0]) eq 'ARRAY') { $self->{fieldsets} = shift; } elsif (@_ % 2) { # search for fieldset and update it, or add it # can't use optalign because must change in-place while (@_) { my($k,$v) = (shift,shift); for (@{$self->{fieldsets}||=[]}) { if ($k eq $_->[0]) { $_->[1] = $v; undef $k; # catch below } } # not found, so append if ($k) { push @{$self->{fieldsets}}, [$k,$v]; } } } else { puke "Invalid usage of \$form->fieldsets(name => 'Label')" } } # We look for all the fieldset definitions, checking the main # form for a "proper" legend ala our other settings. We then # divide up all the fields and group them in fieldsets. my(%legends, @sets); for (optalign($self->{fieldsets})) { my($o,$n) = optval($_); next if exists $legends{$o}; push @sets, $o; debug 2, "added fieldset $o (legend=$n) to \@sets"; $legends{$o} = $n; } # find *all* our fieldsets, even hidden in fields w/o Human Tags for ($self->field) { next unless my $o = $_->fieldset; next if exists $legends{$o}; push @sets, $o; debug 2, "added fieldset $o (legend=undef) to \@sets"; $legends{$o} = $o; # use fieldset as } return wantarray ? @sets : \%legends; } sub fieldlist { my $self = shift; my @fields = @_ ? @_ : $self->field; my(%saw, @ret); for my $set ($self->fieldsets) { # reorder fields for (@fields) { next if $saw{$_}; if ($_->fieldset && $_->fieldset eq $set) { # if this field is in this fieldset, regroup push @ret, $_; debug 2, "added field $_ to field order (fieldset=$set)"; $saw{$_} = 1; } } } # keep non-fieldset fields in order relative # to one another, appending them to the end # of the form for (@fields) { debug 2, "appended non-fieldset field $_ to form"; push @ret, $_ unless $saw{$_}; } return wantarray ? @ret : \@ret; } sub header { my $self = shift; $self->{header} = shift if @_; return unless $self->{header}; my %head; if ($self->{cookies} && defined(my $sid = $self->sessionid)) { require CGI::Cookie; $head{'-cookie'} = CGI::Cookie->new(-name => $self->{sessionidname}, -value => $sid); } # Set the charset for i18n $head{'-charset'} = $self->charset; # Forcibly require - no extra time in normal case, and if # using Apache::Request this needs to be loaded anyways. return "Content-type: text/html\n\n" if $::TESTING; require CGI; return CGI::header(%head); # CGI.pm MOD_PERL fanciness } sub charset { my $self = shift; $self->{charset} = shift if @_; return $self->{charset} || $self->{messages}->charset || 'iso8859-1'; } sub lang { my $self = shift; $self->{lang} = shift if @_; return $self->{lang} || $self->{messages}->lang || 'en_US'; } sub dtd { my $self = shift; $self->{dtd} = shift if @_; return '' if $::TESTING; # replace special chars in dtd by exec'ing subs my $dtd = $self->{dtd}; $dtd =~ s/\{(\w+)\}/$self->$1/ge; return $dtd; } sub title { my $self = shift; $self->{title} = shift if @_; return $self->{title} if exists $self->{title}; return toname(basename); } *script_name = \&action; sub action { local $^W = 0; # -w sucks (still) my $self = shift; $self->{action} = shift if @_; return $self->{action} if exists $self->{action}; return basename . $ENV{PATH_INFO}; } sub font { my $self = shift; $self->{font} = shift if @_; return '' unless $self->{font}; return '' if $self->{stylesheet}; # kill fonts for style # Catch for allowable hashref or string my $ret; my $ref = ref $self->{font} || ''; if (! $ref) { # string "arial,helvetica" $ret = { face => $self->{font} }; } elsif ($ref eq 'ARRAY') { # hack for array [arial,helvetica] from conf $ret = { face => join ',', @{$self->{font}} }; } else { $ret = $self->{font}; } return wantarray ? %$ret : htmltag('font', %$ret); } *tag = \&start; sub start { my $self = shift; my %attr = htmlattr('form', %$self); $attr{action} ||= $self->action; $attr{method} ||= $self->method; $attr{method} = lc($attr{method}); # xhtml $self->disabled ? $attr{disabled} = 'disabled' : delete $attr{disabled}; $attr{class} ||= $self->class($self->formname); # Bleech, there's no better way to do this...? belch "You should really call \$form->script BEFORE \$form->start" unless $self->{_didscript}; # A catch for lowercase actions belch "Old-style 'onSubmit' action found - should be 'onsubmit'" if $attr{onSubmit}; return $self->version . htmltag('form', %attr); } sub end { return ''; } # Need to wrap this or else AUTOLOAD whines (OURATTR missing) sub disabled { my $self = shift; $self->{disabled} = shift if @_; return $self->{disabled} ? 'disabled' : undef; } sub body { my $self = shift; $self->{body} = shift if @_; $self->{body}{bgcolor} ||= 'white' unless $self->{stylesheet}; return htmltag('body', $self->{body}); } sub class { my $self = shift; return undef unless $self->{stylesheet}; return join '', $self->{styleclass}, @_; # remainder is optional tag } sub idname { my $self = shift; $self->{id} = $self->{name} unless defined $self->{id}; return undef unless $self->{id}; return join '', $self->{id}, @_; # remainder is optional tag } sub table { my $self = shift; # single hashref kills everything; a list is temporary $self->{table} = shift if @_ == 1; return unless $self->{table}; # set defaults for numeric table => 1 $self->{table} = $DEFAULT{table} if $self->{table} == 1; my $attr = $self->{table}; if (@_) { # if still have args, create a temp hash my %temp = %$attr; while (my $k = shift) { $temp{$k} = shift; } $attr = \%temp; } return unless $self->{table}; # 0 or unset via table(0) $attr->{class} ||= $self->class; return htmltag('table', $attr); } sub tr { my $self = shift; # single hashref kills everything; a list is temporary $self->{tr} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH'); my $attr = $self->{tr}; if (@_) { # if still have args, create a temp hash my %temp = %$attr; while (my $k = shift) { $temp{$k} = shift; } $attr = \%temp; } # reduced formatting if ($self->{stylesheet}) { # extraneous - inherits from #$attr->{class} ||= $self->class($self->{rowname}); } else { $attr->{valign} ||= 'top'; } return htmltag('tr', $attr); } sub th { my $self = shift; # single hashref kills everything; a list is temporary $self->{th} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH'); my $attr = $self->{th}; if (@_) { # if still have args, create a temp hash my %temp = %$attr; while (my $k = shift) { $temp{$k} = shift; } $attr = \%temp; } # reduced formatting if ($self->{stylesheet}) { # extraneous - inherits from
#$attr->{class} ||= $self->class($self->{labelname}); } else { $attr->{align} ||= $self->{lalign} || 'left'; } return htmltag('th', $attr); } sub td { my $self = shift; # single hashref kills everything; a list is temporary $self->{td} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH'); my $attr = $self->{td}; if (@_) { # if still have args, create a temp hash my %temp = %$attr; while (my $k = shift) { $temp{$k} = shift; } $attr = \%temp; } # extraneous - inherits from
#$attr->{class} ||= $self->class($self->{fieldname}); return htmltag('td', $attr); } sub div { my $self = shift; # single hashref kills everything; a list is temporary $self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH'); my $attr = $self->{div}; if (@_) { # if still have args, create a temp hash my %temp = %$attr; while (my $k = shift) { $temp{$k} = shift; } $attr = \%temp; } return htmltag('div', $attr); } sub submitted { my $self = shift; my $smnam = shift || $self->submittedname; # temp smnam my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam; if ($self->{params}->param($smtag)) { # If we've been submitted, then we return the value of # the submit tag (which allows multiple submission buttons). # Must use an "|| 0E0" or else hitting "Enter" won't cause # $form->submitted to be true (as the button is only sent # across CGI when clicked). my $sr = $self->{params}->param($self->submitname) || '0E0'; debug 2, "\$form->submitted() is true, returning $sr"; return $sr; } return 0; } # This creates a modified self_url, just including fields (no sessionid, etc) sub query_string { my $self = shift; my @qstr = (); for my $f ($self->fields, $self->keepextras) { # get all values, but ONLY from CGI push @qstr, join('=', escapeurl($f), escapeurl($_)) for $self->cgi_param($f); } return join '&', @qstr; } sub self_url { my $self = shift; return join '?', $self->action, $self->query_string; } # must forcibly return scalar undef for CGI::Session easiness sub sessionid { my $self = shift; $self->{sessionid} = shift if @_; return $self->{sessionid} if $self->{sessionid}; return undef unless $self->{sessionidname}; my %cookies; if ($self->{cookies}) { require CGI::Cookie; %cookies = CGI::Cookie->fetch; } if (my $cook = $cookies{"$self->{sessionidname}"}) { return $cook->value; } else { return $self->{params}->param($self->{sessionidname}) || undef; } } sub statetags { my $self = shift; my @html = (); # get _submitted my $smnam = $self->submittedname; my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam; my $smval = $self->{params}->param($smnam) + 1; push @html, htmltag('input', name => $smtag, value => $smval, type => 'hidden'); # and how about _sessionid if (defined(my $sid = $self->sessionid)) { push @html, htmltag('input', name => $self->{sessionidname}, type => 'hidden', value => $sid); } # and what page (hooks for ::Multi) if (defined $self->{page}) { push @html, htmltag('input', name => $self->pagename, type => 'hidden', value => $self->{page}); } return wantarray ? @html : join "\n", @html; } *keepextra = \&keepextras; sub keepextras { local $^W = 0; # -w sucks my $self = shift; my @keep = (); my @html = (); # which ones do they want? $self->{keepextras} = shift if @_; return '' unless $self->{keepextras}; # If we set keepextras, then this means that any extra fields that # we've set that are *not* in our fields() will be added to the form my $ref = ref $self->{keepextras} || ''; if ($ref eq 'ARRAY') { @keep = @{$self->{keepextras}}; } elsif ($ref) { puke "Unsupported data structure type '$ref' passed to 'keepextras' option"; } else { # Set to "1", so must go thru all params, skipping # leading underscore fields and form fields for my $p ($self->{params}->param()) { next if $p =~ /^_/ || $self->{fieldrefs}{$p}; push @keep, $p; } } # In array context, we just return names we've resolved return @keep if wantarray; # Make sure to get all values for my $p (@keep) { my @values = $self->{params}->can('multi_param') ? $self->{params}->multi_param($p) : $self->{params}->param($p); for my $v (@values) { debug 1, "keepextras: saving hidden param $p = $v"; push @html, htmltag('input', name => $p, type => 'hidden', value => $v); } } return join "\n", @html; # wantarray above } sub javascript { my $self = shift; $self->{javascript} = shift if @_; # auto-determine javascript setting based on user agent if (lc($self->{javascript}) eq 'auto') { if (exists $ENV{HTTP_USER_AGENT} && $ENV{HTTP_USER_AGENT} =~ /lynx|mosaic/i) { # Turn off for old/non-graphical browsers return 0; } return 1; } return $self->{javascript} if exists $self->{javascript}; # Turn on for all other browsers by default. # I suspect this process should be reversed, only # showing JavaScript on those browsers we know accept # it, but maintaining a full list will result in this # module going out of date and having to be updated. return 1; } sub jsname { my $self = shift; return $self->{name} ? (join '_', $self->{jsname}, tovar($self->{name})) : $self->{jsname}; } sub script { my $self = shift; # get validate() function name my $jsname = $self->jsname || puke "Must have 'jsname' if 'javascript' is on"; my $jspre = $self->jsprefix || ''; # "counter" $self->{_didscript} = 1; return '' unless $self->javascript; # code for misc non-validate functions my $jsmisc = $self->script_growable # code to grow growable fields, if any . $self->script_otherbox; # code to enable/disable the "other" box # custom user jsfunc option for w/i validate() my $jsfunc = $self->jsfunc || ''; my $jshead = $self->jshead || ''; # expand per-field validation functions, but # only if we are not using Data::FormValidator unless (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) { for ($self->field) { $jsfunc .= $_->script; } } # skip out if we have nothing useful return '' unless $jsfunc || $jsmisc || $jshead; # prefix with opening code if ($jsfunc) { $jsfunc = < 0 || alertstr != '') { EOJ2 # Check to see if we have our own jserror callback on form failure # if not, then use the builtin one. Aka jsalert if (my $jse = $self->jserror) { $jsfunc .= " return $jse(form, invalid, alertstr, invalid_fields);\n"; } else { # Finally, close our JavaScript if it was opened, wrapping in "; } sub script_growable { my $self = shift; return '' unless my @growable = grep { $_->growable } $self->field; my $jspre = $self->jsprefix || ''; my $jsmisc = ''; my $grow = $self->growname; $jsmisc .= <= ${jspre}limit[baseID]) return; var base = document.getElementById(baseID + '_' + (${jspre}counter[baseID] - 1)); // we are inserting after the last field insertPoint = base.nextSibling; // line break base.parentNode.insertBefore(document.createElement('br'), insertPoint); var dup = base.cloneNode(true); dup.setAttribute('id', baseID + '_' + ${jspre}counter[baseID]); base.parentNode.insertBefore(dup, insertPoint); // add some padding space between the field and the "add field" button base.parentNode.insertBefore(document.createTextNode(' '), insertPoint); ${jspre}counter[baseID]++; // disable the "add field" button if we are at the limit if (${jspre}counter[baseID] >= ${jspre}limit[baseID]) { var addButton = document.getElementById('$grow' + '_' + baseID); addButton.setAttribute('disabled', 'disabled'); } } EOJS # initialize growable counters for (@growable) { my $count = scalar(my @v = $_->values); $jsmisc .= "${jspre}counter['$_'] = $count;\n" if $count > 0; # assume that values of growable > 1 provide limits my $limit = $_->growable; if ($limit && $limit ne 1) { $jsmisc .= "${jspre}limit['$_'] = $limit;\n"; } } return $jsmisc; } sub script_otherbox { my $self = shift; return '' unless my @otherable = grep { $_->other } $self->field; my $jspre = $self->jsprefix || ''; my $jsmisc = ''; $jsmisc .= <noscript" if @_; return '' unless $self->javascript; return ''; } sub submits { local $^W = 0; # -w sucks my $self = shift; # handle the submit button(s) # logic is a little complicated - if set but to a false value, # then leave off. otherwise use as the value for the tags. my @submit = (); my $sn = $self->{submitname}; my $sc = $self->class($self->{buttonname}); if (ref $self->{submit} eq 'ARRAY') { # multiple buttons + JavaScript - dynamically set the _submit value my @oncl = $self->javascript ? (onclick => "this.form.$sn.value = this.value;") : (); my $i=1; for my $subval (autodata $self->{submit}) { my $si = $i > 1 ? "_$i" : ''; # number with second one push @submit, { type => 'submit', id => "$self->{name}$sn$si", class => $sc, name => $sn, value => $subval, @oncl }; $i++; } } else { # show the text on the button my $subval = $self->{submit} eq 1 ? $self->{messages}->form_submit_default : $self->{submit}; push @submit, { type => 'submit', id => "$self->{name}$sn", class => $sc, name => $sn, value => $subval }; } return wantarray ? @submit : [ map { htmltag('input', $_) } @submit ]; } sub submit { my $self = shift; $self->{submit} = shift if @_; return '' if ! $self->{submit} || $self->static || $self->disabled; # no newline on buttons regardless of setting return join '', map { htmltag('input', $_) } $self->submits(@_); } sub reset { local $^W = 0; # -w sucks my $self = shift; $self->{reset} = shift if @_; return '' if ! $self->{reset} || $self->static || $self->disabled; my $sc = $self->class($self->{buttonname}); # similar to submit(), but a little simpler ;-) my $reset = $self->{reset} eq 1 ? $self->{messages}->form_reset_default : $self->{reset}; my $rn = $self->resetname; return htmltag('input', type => 'reset', id => "$self->{name}$rn", class => $sc, name => $rn, value => $reset); } sub text { my $self = shift; $self->{text} = shift if @_; # having any required fields changes the leading text my $req = 0; my $inv = 0; for ($self->fields) { $req++ if $_->required; $inv++ if $_->invalid; # failed validate() } unless ($self->static || $self->disabled) { # only show either invalid or required text return $self->{text} .'

'. sprintf($self->{messages}->form_invalid_text, $inv, $self->invalid_tag).'

' if $inv; return $self->{text} .'

'. sprintf($self->{messages}->form_required_text, $self->required_tag).'

' if $req; } return $self->{text}; } sub invalid_tag { my $self = shift; my $label = shift || ''; my @tags = $self->{stylesheet} ? (qq(), '') : ('', ''); return wantarray ? @tags : join $label, @tags; } sub required_tag { my $self = shift; my $label = shift || ''; my @tags = $self->{stylesheet} ? (qq(), '') : ('', ''); return wantarray ? @tags : join $label, @tags; } sub cgi_param { my $self = shift; $self->{params}->param(@_); } sub tmpl_param { my $self = shift; if (my $key = shift) { return @_ ? $self->{tmplvar}{$key} = shift : $self->{tmplvar}{$key}; } else { # return hash or key/value pairs my $hr = $self->{tmplvar} || {}; return wantarray ? %$hr : $hr; } } sub version { # Hidden trailer. If you perceive this as annoying, let me know and I # may remove it. It's supposed to help. return '' if $::TESTING; if (ref $_[0]) { return "\n\n"; } else { return "CGI::FormBuilder v$VERSION by Nate Wiger. All Rights Reserved.\n"; } } sub values { my $self = shift; if (@_) { $self->{values} = arghash(@_); my %val = (); my @val = (); # We currently make two passes, first getting the values # and storing them into a temp hash, and then going thru # the fields and picking up the values and attributes. local $" = ','; debug 1, "\$form->{values} = ($self->{values})"; # Using isa() allows objects to transparently fit in here if (UNIVERSAL::isa($self->{values}, 'CODE')) { # it's a sub; lookup each value in turn for my $key (&{$self->{values}}) { # always assume an arrayref of values... $val{$key} = [ &{$self->{values}}($key) ]; debug 2, "setting values from \\&code(): $key = (@{$val{$key}})"; } } elsif (UNIVERSAL::isa($self->{values}, 'HASH')) { # must lc all the keys since we're case-insensitive, then # we turn our values hashref into an arrayref on the fly my @v = autodata $self->{values}; while (@v) { my $key = lc shift @v; $val{$key} = [ autodata shift @v ]; debug 2, "setting values from HASH: $key = (@{$val{$key}})"; } } elsif (UNIVERSAL::isa($self->{values}, 'ARRAY')) { # also accept an arrayref which is walked sequentially below debug 2, "setting values from ARRAY: (walked below)"; @val = autodata $self->{values}; } else { puke "Unsupported operand to 'values' option - must be \\%hash, \\&sub, or \$object"; } # redistribute values across all existing fields for ($self->fields) { my $v = $val{lc($_)} || shift @val; # use array if no value $_->field(value => $v) if defined $v; } } } sub name { my $self = shift; @_ ? $self->{name} = shift : $self->{name}; } sub nameopts { my $self = shift; if (@_) { $self->{nameopts} = shift; for ($self->fields) { $_->field(nameopts => $self->{nameopts}); } } return $self->{nameopts}; } sub sortopts { my $self = shift; if (@_) { $self->{sortopts} = shift; for ($self->fields) { $_->field(sortopts => $self->{sortopts}); } } return $self->{sortopts}; } sub selectnum { my $self = shift; if (@_) { $self->{selectnum} = shift; for ($self->fields) { $_->field(selectnum => $self->{selectnum}); } } return $self->{selectnum}; } sub options { my $self = shift; if (@_) { $self->{options} = arghash(@_); my %val = (); # same case-insensitization as $form->values my @v = autodata $self->{options}; while (@v) { my $key = lc shift @v; $val{$key} = [ autodata shift @v ]; } for ($self->fields) { my $v = $val{lc($_)}; $_->field(options => $v) if defined $v; } } return $self->{options}; } sub labels { my $self = shift; if (@_) { $self->{labels} = arghash(@_); my %val = (); # same case-insensitization as $form->values my @v = autodata $self->{labels}; while (@v) { my $key = lc shift @v; $val{$key} = [ autodata shift @v ]; } for ($self->fields) { my $v = $val{lc($_)}; $_->field(label => $v) if defined $v; } } return $self->{labels}; } # Note that validate does not work like a true accessor sub validate { my $self = shift; if (@_) { if (ref $_[0]) { # this'll either be a hashref or a DFV object $self->{validate} = shift; } elsif (@_ % 2 == 0) { # someone passed a hash-as-list $self->{validate} = { @_ }; } elsif (@_ > 1) { # just one argument we'll interpret as a DFV profile name; # an odd number > 1 is probably a typo... puke "Odd number of elements passed to validate"; } } my $ok = 1; if (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) { my $profile_name = shift || 'fb'; debug 1, "validating fields via the '$profile_name' profile"; # hang on to the DFV results, for things like DBIx::Class::WebForm $self->{dfv_results} = $self->{validate}->check($self, $profile_name); # mark the invalid fields my @invalid_fields = ( $self->{dfv_results}->invalid, $self->{dfv_results}->missing, ); for my $field_name (@invalid_fields) { $self->field( name => $field_name, invalid => 1, ); } # validation failed $ok = 0 if @invalid_fields > 0; } else { debug 1, "validating all fields via \$form->validate"; for ($self->fields) { $ok = 0 unless $_->validate; } } debug 1, "validation done, ok = $ok (should be 1)"; return $ok; } sub confirm { # This is nothing more than a special wrapper around render() my $self = shift; my $date = $::TESTING ? 'LOCALTIME' : localtime(); $self->{text} ||= sprintf $self->{messages}->form_confirm_text, $date; $self->{static} = 1; return $self->render(@_); } # Prepare a template sub prepare { my $self = shift; debug 1, "Calling \$form->prepare(@_)"; # Build a big hashref of data that can be used by the template # engine. Templates then have the ability to expand this however # they see fit. my %tmplvar = $self->tmpl_param; # This is based on the original Template Toolkit render() for my $field ($self->field) { # Extract value since used often my @value = $field->tag_value; # Create a struct for each field $tmplvar{field}{"$field"} = { %$field, # gets invalid/missing/required field => $field->tag, value => $value[0], values => \@value, options => [$field->options], label => $field->label, type => $field->type, comment => $field->comment, nameopts => $field->nameopts, cleanopts => $field->cleanopts, }; # Force-stringify "$field" to get name() under buggy Perls $tmplvar{field}{"$field"}{error} = $field->error; } # Must generate JS first because it affects the others. # This is a bit action-at-a-distance, but I just can't # figure out a way around it. debug 2, "\$tmplvar{jshead} = \$self->script"; $tmplvar{jshead} = $self->script; debug 2, "\$tmplvar{title} = \$self->title"; $tmplvar{title} = $self->title; debug 2, "\$tmplvar{start} = \$self->start . \$self->statetags . \$self->keepextras"; $tmplvar{start} = $self->start . $self->statetags . $self->keepextras; debug 2, "\$tmplvar{submit} = \$self->submit"; $tmplvar{submit} = $self->submit; debug 2, "\$tmplvar{reset} = \$self->reset"; $tmplvar{reset} = $self->reset; debug 2, "\$tmplvar{end} = \$self->end"; $tmplvar{end} = $self->end; debug 2, "\$tmplvar{invalid} = \$self->invalid"; $tmplvar{invalid} = $self->invalid; debug 2, "\$tmplvar{required} = \$self->required"; $tmplvar{required} = $self->required; my $fieldsets = $self->fieldsets; for my $key (keys %$fieldsets) { $tmplvar{fieldset}{$key} = { name => $key, label => $fieldsets->{$key}, } } $tmplvar{fieldsets} = [ map $tmplvar{fieldset}{$_}, $self->fieldsets ]; debug 2, "\$tmplvar{fields} = [ map \$tmplvar{field}{\$_}, \$self->field ]"; $tmplvar{fields} = [ map $tmplvar{field}{$_}, $self->field ]; return wantarray ? %tmplvar : \%tmplvar; } sub render { local $^W = 0; # -w sucks my $self = shift; debug 1, "starting \$form->render(@_)"; # any arguments are used to make permanent changes to the $form if (@_) { puke "Odd number of arguments passed into \$form->render()" unless @_ % 2 == 0; while (@_) { my $k = shift; $self->$k(shift); } } # check for engine type my $mod; my $ref = ref $self->{template}; if (! $ref && $self->{template}) { # "legacy" string filename for HTML::Template; redo format # modifying $self object is ok because it's compatible $self->{template} = { type => 'HTML', filename => $self->{template}, }; $ref = 'HASH'; # tricky debug 2, "rewrote 'template' option since found filename"; } # Get ourselves ready $self->{prepare} = $self->prepare; # weaken($self->{prepare}); my $opt; if ($ref eq 'HASH') { # must copy to avoid destroying $opt = { %{ $self->{template} } }; $mod = ucfirst(delete $opt->{type} || 'HTML'); } elsif ($ref eq 'CODE') { # subroutine wrapper return &{$self->{template}}($self); } elsif (UNIVERSAL::can($self->{template}, 'render')) { # instantiated object return $self->{template}->render($self); } elsif ($ref) { puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ render()"; } # load user-specified rendering module, or builtin rendering $mod ||= 'Builtin'; # user can give 'Their::Complete::Module' or an 'IncludedAdapter' $mod = join '::', __PACKAGE__, 'Template', $mod unless $mod =~ /::/; debug 1, "loading $mod for 'template' option"; # load module eval "require $mod"; puke "Bad template engine $mod: $@" if $@; # create new object #CGI::FormBuilder::Template::Builtin my $tmpl = $mod->new($opt); # Experiemental: Alter tag names as we're rendering, to support # Ajaxian markup schemes that use their own tags (Backbase, Dojo, etc) local %CGI::FormBuilder::Util::TAGNAMES; while (my($k,$v) = each %{$self->{tagnames}}) { $CGI::FormBuilder::Util::TAGNAMES{$k} = $v; } # Call the engine's prepare too, if it exists # Give it the form object so it can do what it wants # This will have all of the prepared data in {prepare} anyways if ($tmpl && UNIVERSAL::can($tmpl, 'prepare')) { $tmpl->prepare($self); } # dispatch to engine, prepend header debug 1, "returning $tmpl->render($self->{prepare})"; my $ret = $self->header . $tmpl->render($self->{prepare}); #we have a circular reference but we need to kill it after setting up return weaken($self->{prepare}); return $ret; } # These routines should be moved to ::Mail or something since they're rarely used sub mail () { # This is a very generic mail handler my $self = shift; my $args = arghash(@_); # Where does the mailer live? Must be sendmail-compatible my $mailer = undef; unless ($mailer = $args->{mailer} && -x $mailer) { for my $sendmail (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/bin/sendmail)) { if (-x $sendmail) { $mailer = "$sendmail -t"; last; } } } unless ($mailer) { belch "Cannot find a sendmail-compatible mailer; use mailer => '/path/to/mailer'"; return; } unless ($args->{to}) { belch "Missing required 'to' argument; cannot continue without recipient"; return; } if ($args->{from}) { (my $from = $args->{from}) =~ s/"/\\"/g; $mailer .= qq( -f "$from"); } debug 1, "opening new mail to $args->{to}"; # untaint my $oldpath = $ENV{PATH}; $ENV{PATH} = '/usr/bin:/usr/sbin'; open(MAIL, "|$mailer >/dev/null 2>&1") || next; print MAIL "From: $args->{from}\n"; print MAIL "To: $args->{to}\n"; print MAIL "Cc: $args->{cc}\n" if $args->{cc}; print MAIL "Content-Type: text/plain; charset=\"" . $self->charset . "\"\n" if $self->charset; print MAIL "Subject: $args->{subject}\n\n"; print MAIL "$args->{text}\n"; # retaint $ENV{PATH} = $oldpath; return close(MAIL); } sub mailconfirm () { # This prints out a very generic message. This should probably # be much better, but I suspect very few if any people will use # this method. If you do, let me know and maybe I'll work on it. my $self = shift; my $to = shift unless (@_ > 1); my $args = arghash(@_); # must have a "to" return unless $args->{to} ||= $to; # defaults $args->{from} ||= 'auto-reply'; $args->{subject} ||= sprintf $self->{messages}->mail_confirm_subject, $self->title; $args->{text} ||= sprintf $self->{messages}->mail_confirm_text, scalar localtime(); debug 1, "mailconfirm() called, subject = '$args->{subject}'"; $self->mail($args); } sub mailresults () { # This is a wrapper around mail() that sends the form results my $self = shift; my $args = arghash(@_); if (exists $args->{plugin}) { my $lib = "CGI::FormBuilder::Mail::$args->{plugin}"; eval "use $lib"; puke "Cannot use mailresults() plugin '$lib': $@" if $@; eval { my $plugin = $lib->new( form => $self, %$args ); $plugin->mailresults(); }; puke "Could not mailresults() with plugin '$lib': $@" if $@; return; } # Get the field separator to use my $delim = $args->{delimiter} || ': '; my $join = $args->{joiner} || $"; my $sep = $args->{separator} || "\n"; # subject default $args->{subject} ||= sprintf $self->{messages}->mail_results_subject, $self->title; debug 1, "mailresults() called, subject = '$args->{subject}'"; if ($args->{skip}) { if ($args->{skip} =~ m#^m?(\S)(.*)\1$#) { ($args->{skip} = $2) =~ s/\\\//\//g; $args->{skip} =~ s/\//\\\//g; } } my @form = (); for my $field ($self->fields) { if ($args->{skip} && $field =~ /$args->{skip}/) { next; } my $v = join $join, $field->value; $field = $field->label if $args->{labels}; push @form, "$field$delim$v"; } my $text = join $sep, @form; $self->mail(%$args, text => $text); } sub DESTROY { 1 } # This is used to access all options after new(), by name sub AUTOLOAD { # This allows direct addressing by name local $^W = 0; my $self = shift; my($name) = $AUTOLOAD =~ /.*::(.+)/; # If fieldsubs => 1 set, then allow grabbing fields directly if ($self->{fieldsubs} && $self->{fieldrefs}{$name}) { return $self->field(name => $name, @_); } debug 3, "-> dispatch to \$form->{$name} = @_"; if (@_ % 2 == 1) { $self->{$name} = shift; if ($REARRANGE{$name}) { # needs to be splatted into every field for ($self->fields) { my $tval = rearrange($self->{$name}, "$_"); $_->$name($tval); } } } # Try to catch $form->$fieldname usage if ((! exists($self->{$name}) || @_) && ! $CGI::FormBuilder::Util::OURATTR{$name}) { if ($self->{fieldsubs}) { return $self->field(name => $name, @_); } else { belch "Possible field access via \$form->$name() - see 'fieldsubs' option" } } return $self->{$name}; } 1; __END__ CGI-FormBuilder-3.10/lib/CGI/FormBuilder.pod0000644000175000017500000026632212754704556017667 0ustar davidpdavidp=head1 NAME CGI::FormBuilder - Easily generate and process stateful forms =head1 SYNOPSIS use CGI::FormBuilder; # Assume we did a DBI query to get existing values my $dbval = $sth->fetchrow_hashref; # First create our form my $form = CGI::FormBuilder->new( name => 'acctinfo', method => 'post', stylesheet => '/path/to/style.css', values => $dbval, # defaults ); # Now create form fields, in order # FormBuilder will automatically determine the type for you $form->field(name => 'fname', label => 'First Name'); $form->field(name => 'lname', label => 'Last Name'); # Setup gender field to have options $form->field(name => 'gender', options => [qw(Male Female)] ); # Include validation for the email field $form->field(name => 'email', size => 60, validate => 'EMAIL', required => 1); # And the (optional) phone field $form->field(name => 'phone', size => 10, validate => '/^1?-?\d{3}-?\d{3}-?\d{4}$/', comment => 'optional'); # Check to see if we're submitted and valid if ($form->submitted && $form->validate) { # Get form fields as hashref my $field = $form->fields; # Do something to update your data (you would write this) do_data_update($field->{lname}, $field->{fname}, $field->{email}, $field->{phone}, $field->{gender}); # Show confirmation screen print $form->confirm(header => 1); } else { # Print out the form print $form->render(header => 1); } =head1 DESCRIPTION If this is your first time using B, you should check out the website for tutorials and examples at L. You should also consider joining the google group at L. There are some pretty smart people on the list that can help you out. =head2 Overview I hate generating and processing forms. Hate it, hate it, hate it, hate it. My forms almost always end up looking the same, and almost always end up doing the same thing. Unfortunately, there haven't really been any tools out there that streamline the process. Many modules simply substitute Perl for HTML code: # The manual way print qq(); # The module way print input(-name => 'email', -type => 'text', -size => '20'); The problem is, that doesn't really gain you anything - you still have just as much code. Modules like C are great for decoding parameters, but not for generating and processing whole forms. The goal of CGI::FormBuilder (B) is to provide an easy way for you to generate and process entire CGI form-based applications. Its main features are: =over =item Field Abstraction Viewing fields as entities (instead of just params), where the HTML representation, CGI values, validation, and so on are properties of each field. =item DWIMmery Lots of built-in "intelligence" (such as automatic field typing), giving you about a 4:1 ratio of the code it generates versus what you have to write. =item Built-in Validation Full-blown regex validation for fields, even including JavaScript code generation. =item Template Support Pluggable support for external template engines, such as C, C, C