# Copyright (c) 2001-2002 Nathan Wiger # Use "perldoc FormBuilder.pm" for documentation package CGI::FormBuilder; =head1 NAME CGI::FormBuilder - Easily generate and process stateful forms =head1 SYNOPSIS use CGI::FormBuilder; # Let's assume we did a DBI query to get existing values my $dbval = $sth->fetchrow_hashref; my $form = CGI::FormBuilder->new( method => 'POST', fields => [qw/name email phone gender/], values => $dbval, validate => { email => 'EMAIL', phone => 'PHONE' }, required => 'ALL', ); # Change gender field to have options $form->field(name => 'gender', options => [qw/Male Female/]); if ($form->submitted && $form->validate) { my $fields = $form->field; # get form fields as hashref # Do something to update your data (you would write this) do_data_update($fields->{name}, $fields->{email}, $fields->{phone}, $fields->{gender}); print $form->confirm(header => 1); # confirmation screen $form->mailconfirm(to => $fields->{email}); } else { print $form->render(header => 1); # print out the form } =cut use Carp; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); $VERSION = do { my @r=(q$Revision: 2.6 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r }; # use CGI for stickiness (prefer CGI::Minimal for _much_ better speed) # we try the faster one first, since they're compatible for our needs my $CGIMOD = 'CGI::Minimal'; eval { require CGI::Minimal }; if ($@) { require CGI; $CGIMOD = 'CGI'; } my $CGI = ''; # For debug(), the value is set in new() my $DEBUG; # Catches for special validation patterns # These are semi-Perl patterns; they must be usable by JavaScript # as well so they do not take advantage of features JS can't use # If the value is an arrayref, then the second arg is a tag to # spit out at the person after the field label to help with format my %VALID = ( WORD => '/^\w+$/', NAME => '/^[a-zA-Z]+$/', NUM => '/^-?\s*[0-9]+\.?[0-9]*$|^-?\s*\.[0-9]+$/', # 1, 1.25, .25 INT => '/^-?\s*[0-9]+$/', FLOAT => '/^-?\s*[0-9]+\.[0-9]+$/', PHONE => ['/^\d{3}\-\d{3}\-\d{4}$|^\(\d{3}\)\s+\d{3}\-\d{4}$/', '123-456-7890'], INTPHONE => ['/^\+\d+[\s\-][\d\-\s]+$/', '+prefix local-number'], EMAIL => ['/^[\w\-\+\.]+\@[a-zA-Z0-9][-a-zA-Z0-9\.]*\.[a-zA-Z]+$/', 'name@host.domain'], CARD => '/^\d{4}[\- ]?\d{4}[\- ]?\d{4}[\- ]?\d{4}$|^\d{4}[\- ]?\d{6}[\- ]?\d{5}$/', MMYY => ['/^\d{1,2}\/?\d{2}$/', 'MM/YY'], MMYYYY=> ['/^\d{1,2}\/?\d{4}$/', 'MM/YYYY'], DATE => ['/^\d{1,2}\/\d{1,2}\/\d{4}$/', 'MM/DD/YYYY'], #DATE => '/^\d{1,2}\/\d{1,2}\/\d{4}$|^\d{1,2}\/\d{4}$|^\d{1,2}\/\d{2}$/', ZIPCODE=> '/^\d{5}$|^\d{5}\-\d{4}$/', STATE => ['/^[a-zA-Z]{2}$/', 'two-letter abbr'], IPV4 => '/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/', # not strictly correct (allows 555.555) NETMASK => '/^(\d{1,3}\.){0,3}\d{1,3}$/', FILE => ['/^[\/\w\.\-]+$/', 'UNIX format'], WINFILE => ['/^[a-zA-Z]:\\[\\\w\s\.\-]+$/', 'Windows format'], MACFILE => ['/^[:\w\.\-]+$/', 'Mac format'], USER => ['/^[-a-zA-Z0-9]{4,8}$/', '4-8 characters'], # require a 4-8 char username HOST => '/^[a-zA-Z0-9][-a-zA-Z0-9]*$/', DOMAIN=> '/^[a-zA-Z0-9][-a-zA-Z0-9\.]*\.[a-zA-Z]+$/', # mostly correct, but allows "dom.c-o.uk" ETHER => '/^[\da-f]{1,2}[\.:]?[\da-f]{1,2}[\.:]?[\da-f]{1,2}[\.:]?[\da-f]{1,2}[\.:]?[\da-f]{1,2}[\.:]?[\da-f]{1,2}$/i', # Many thanks to Mark Belanger for these additions FNAME => '/^[a-zA-Z]+[- ][a-zA-Z]+$/', LNAME => '/^[a-zA-Z]+-?[a-zA-Z]+\s*,?(?:[a-zA-Z]+|[a-zA-Z]+\.)?$/', CCMM => '/^0[1-9]|1[012]$/', CCYY => '/^[1-9]{2}$/', ); # To clean up the HTML, instead of just allowing the HTML tags that # we interpret are "valid", instead we yank out all the options and # stuff that we use internally. This allows arbitrary tags to be # specified in the generation of HTML tags, and also means that this # module doesn't go out of date when the HTML spec changes. my @OURATTR = qw( attr body checknum comment debug fieldattr fields fieldtype font force header invalid javascript keepextras label labels lalign linebreaks multiple nameopts options params radionum required reset selectnum smartness sortopts static sticky submit table template text title validate valign value_orig values ); # trick for speedy lookup my %OURATTR = map { $_ => 1 } @OURATTR; sub debug { return unless $DEBUG >= $_[0]; # first arg is debug level shift; # using $_[0] directly above is just a little faster... my($func) = (caller(1))[3]; warn "[$func] (debug) ", @_, "\n"; } sub belch (@) { my($func) = (caller(1))[3]; carp "[$func] Warning: ", @_; } sub puke (@) { my($func) = (caller(1))[3]; croak "[$func] Fatal: ", @_; } sub _args (;@) { belch "Odd number of arguments passed into ", (caller(1))[3] unless (@_ % 2 == 0); # strip off any leading '-opt' crap my @args; while (@_) { (my $k = shift) =~ s/^-//; push @args, $k, shift; } return @args; } sub _data ($) { # auto-derefs appropriately my $data = shift; if (my $ref = ref $data) { if ($ref eq 'ARRAY') { return wantarray ? @{$data} : $data; } elsif ($ref eq 'HASH') { return wantarray ? %{$data} : $data; } else { puke "Sorry, can't handle odd data ref '$ref'"; } } else { return $data; # return as-is } } sub _ismember ($@) { # returns 1 if is in set, undef otherwise # do so case-insensitively my $test = lc shift; for (@_) { return 1 if $test eq lc $_; } return; } sub _indent (;$) { # return proper spaces to indent x 4 return " " x shift(); } sub _toname ($) { # creates a name from a var/file name (like file2name) my $name = shift; $name =~ s!\.\w+$!!; # lose trailing ".cgi" or whatever $name =~ s![^a-zA-Z0-9.-/]+! !g; $name =~ s!\b(\w)!\u$1!g; return $name; } sub _opt ($) { # This creates and returns the options needed based # on an $opt array/hash shifted in my $opt = shift; # "options" are the options for our select list my @opt = (); if (my $ref = ref $opt) { # we turn any data into ( ['key', 'val'], ['key', 'val'] ) # have to check sub-data too, hence why this gets a little nasty @opt = ($ref eq 'HASH') ? map { [$_, $opt->{$_}] } keys %{$opt} : map { (ref $_ eq 'HASH') ? [each %{$_}] : $_ } _data $opt; #: map { (ref $_ eq 'HASH') ? [each %{$_}] : $_ #: ( (ref $_ eq 'ARRAY') ? $_ : [$_, $_] ) } _data $opt; } else { # this code should not be reached, but is here for safety @opt = ($opt); } return @opt; } sub _sort (\@$) { # pass in the sort and ref to opts my @opt = @{ shift() }; my $sort = shift; if ($sort eq 'alpha') { @opt = sort { (_data($a))[0] cmp (_data($b))[0] } @opt; # currently type is ignored } elsif ($sort eq 'numeric') { @opt = sort { (_data($a))[0] <=> (_data($b))[0] } @opt; } else { puke "Unsupported sort type '$sort' specified - must be 'alpha' or 'numeric'"; } # return our options return @opt; } sub _initfields { # Resolve the fields and values, called by new() as: # # $self->_initfields(fields => [array ref], values => {hash or obj ref}); # # OR # # $self->_initfields(fields => {hash ref of key/val pairs}); # # The values are *always* taken to be the assigned values of # the thingy. If you need to assign other options, you need # to do so via the field() method. my $self = shift; my %args = _args(@_); my %val = (); my @val = (); # Safety catch $self->{fields} ||= {}; $self->{field_names} ||= []; # check to see if 'fields' is a hash or array ref if (ref $args{fields} eq 'HASH') { # with a hash ref, we setup keys/values $self->{field_names} = [ sort keys %{$args{fields}} ]; while(my($k,$v) = each %{$args{fields}}) { $k = lc $k; # must lc to ignore case $val{$k} = [_data $v]; } # now we lie about what $args{fields} contained so # that the below data struct assembly works $args{fields} = $self->{field_names}; } elsif ($args{fields}) { # setup our ordering $self->{field_names} = [ _data $args{fields} ]; } else { # not resetting our fields; we're just setting up values $args{fields} = $self->{field_names} || [keys %{$args{values} || {}}]; } # 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. if ($args{values}) { debug 2, "args{values} = $args{values}"; if (UNIVERSAL::can($args{values}, 'param')) { # it's a blessed CGI ref or equivalent, so use its param() method for my $key ($args{values}->param) { # always assume an arrayref of values... $val{$key} = [ $args{values}->param($key) ]; debug 1, "retrieved values from param(): $key => @{$val{$key}}"; } } elsif (ref $args{values} eq '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 = _data($args{values}); while (@v) { my $key = lc shift @v; $val{$key} = [_data shift @v]; debug 1, "walking values from HASH: $key => @{$val{$key}}"; } } elsif (ref $args{values} eq 'ARRAY') { # also accept an arrayref which is walked sequentially below @val = _data $args{values}; } else { puke "Unsupported operand to 'values' attribute - must be hashref or object"; } } # Now setup our data structure. Hmm, is this the right way to # do this? I mean, philosophically speaking... for my $k (_data($args{fields})) { # We no longer "pre-catch" CGI. Instead, we allow stickiness # meaning that CGI values override our default values from above my @v = (); @v = $CGI->param($k) if $CGI; # get it from CGI if object exists if (grep { length $_ } @v) { # must do this extensive check; otherwise, we get value="" in our # form which causes unique problems for browsers in some instances debug 2, "CGI yielded $k = @v"; $self->{fields}{$k}{value} = \@v; $self->{field_cgivals}{$k} = 1; } elsif (! $self->{field_inited}{$k}) { # we do not set the value here if it's already been # manually initialized, say through a field() call if (keys %val) { # 'values' hashref arg $self->{fields}{$k}{value} = $val{lc($k)}; } elsif (@val) { # now accept an arrayref to 'values' as well; walk sequentially $self->{fields}{$k}{value} = [_data shift @val]; } # first time around, save "original" value; this is used # later to resolve conflicts between sticky => 0 and values => $ref $self->{fields}{$k}{value_orig} ||= $self->{fields}{$k}{value}; } debug 2, "set value $k = " . join ', ', @{$self->{fields}{$k}{value}} if $self->{fields}{$k}{value}; } # Finally, if the user asked for "realsmart", then we try to automatically # figure out some validation stuff (among other things)... if ($self->{opt}{smartness} && $self->{opt}{smartness} >= 2) { for my $field (@{$self->{field_names}}) { next if $self->{opt}{validate}{$field}; if ($field =~ /email/i) { $self->{opt}{validate}{$field} = 'EMAIL'; } elsif ($field =~ /phone/i) { $self->{opt}{validate}{$field} = 'PHONE'; } elsif ($field =~ /date/i) { $self->{opt}{validate}{$field} = 'DATE'; } elsif ($field =~ /credit.*card/i) { $self->{opt}{validate}{$field} = 'CARD'; } elsif ($field =~ /^zip(?:code)?$/i) { $self->{opt}{validate}{$field} = 'ZIPCODE'; } elsif ($field =~ /^state$/i) { $self->{opt}{validate}{$field} = 'STATE'; # the options are the names of the US states + DC (51) $self->{fields}{$field}{options} = [qw(AL AK AZ AR CA CO CT DE DC FL GE HI ID IL IN IA KS KY LA ME MD MA MI MN MS MO MT NE NV NH NJ NM NY NC ND OH OK OR PA RI SC SD TN TX UT VT VA WA WV WI WY)]; debug 2, "via 'smartness' auto-determined options for '$field' field"; } elsif ($field =~ /^file/i) { # guess based on the OS we're running! if ($^O =~ /win|dos/i) { $self->{opt}{validate}{$field} = 'WINFILE'; } elsif ($^O =~ /mac/i) { $self->{opt}{validate}{$field} = 'MACFILE'; } else { $self->{opt}{validate}{$field} = 'FILE'; } } elsif ($field =~ /^domain/i) { $self->{opt}{validate}{$field} = 'DOMAIN'; } elsif ($field =~ /^host|host$/i) { $self->{opt}{validate}{$field} = 'HOST'; } elsif ($field =~ /^user|user$/i) { $self->{opt}{validate}{$field} = 'USER'; } else { next; # skip below message } debug 2, "via 'smartness' set validation for '$field' field ", "to '$self->{opt}{validate}{$field}'"; } } return 1; } sub _escapeurl ($) { # minimalist, not 100% correct, URL escaping my $toencode = shift; $toencode =~ s!([^a-zA-Z0-9_,.-/])!sprintf("%%%02x",ord($1))!eg; return $toencode; } sub _escapehtml ($) { my $toencode = shift; # must do these in order or the browser won't decode right $toencode =~ s!&!&!g; $toencode =~ s!!>!g; $toencode =~ s!"!"!g; return $toencode; } sub _tag ($;@) { # called as _tag('tagname', %attr) # creates an HTML tag on the fly, quick and dirty my $name = shift || return; my @tag; while (@_) { # this cleans out all the internal junk kept in each data # element, returning everything else (for an html tag) my $key = shift; #if (_ismember($key, @OURATTR)) { if ($OURATTR{$key}) { # faster for common case shift; next; } #my $val = _escapeurl shift; # too much gets escaped my $val = _escapehtml shift; # minimalist HTML escaping push @tag, qq($key="$val"); } return '<' . join(' ', $name, sort @tag) . '>'; } sub _expreqd ($$) { # As of v1.97, our 'required' option semantics have become much more # complicated. We now have to create an intersection between required # and validate. To do so, we make it so that required has a list of # the required fields, which is then used by validate. my %need = (); my $self = shift; my $reqd = shift; my $vald = shift || {}; if ($reqd) { if ($reqd eq 'ALL') { $reqd = $self->{field_names}; # point to field_names } elsif ($reqd eq 'NONE') { $reqd = []; } unless (ref $reqd eq 'ARRAY') { puke("Argument to 'required' option must be an arrayref, 'ALL', or 'NONE'"); } # create a hash for easy lookup $need{$_} = 1 for @{$reqd}; } else { $need{$_} = 1 for keys %{$vald}; } return wantarray ? %need : \%need; } sub new { my $class = shift; # handle ->new($method) and ->new(method => $method) my $method = shift unless (@_ % 2 == 0); my %args = _args(@_); $args{method} ||= $method if $method; # Warning belch "You won't be able to get at any form values unless you specify 'fields' to new()" unless $args{fields}; $DEBUG ||= delete $args{debug} || 0; # recall that delete returns the val deleted # Redo our magical CGI object if specified # This is the *only* option that must be specified in new and not render if (my $r = delete $args{params}) { # in mod_perl, we can't do anything without a manual params => arg # since otherwise POST params magically disappear puke "Argument to 'params' option must be an object with a param() method" unless UNIVERSAL::can($r, 'param'); $CGI = $r; } else { # initialize our CGI object #my $CGI = ($ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/) ? '' : $CGIMOD->new; $CGI = $CGIMOD->new; } # Now bless all our options into ourself my $self = bless {}, ref($class) || $class; $self->{opt} = \%args; # Process any fields specified, if applicable if (my $fields = delete $self->{opt}{fields}) { $self->_initfields(fields => $fields, values => delete $self->{opt}{values}); } elsif (my $values = $self->{opt}{values}) { $self->_initfields(values => $values); } return $self; } *fields = \&field; sub field { my $self = shift; debug 2, "called \$form->field(@_)"; # handle either ->field($name) or ->field(name => $name) my $name = shift unless (@_ % 2 == 0); my %args = (); if (@_ == 2) { # assumed it's "legacy" name => value $args{name} = shift; $args{value} = shift; } else { %args = _args(@_); $args{name} ||= $name; } # must catch this here each time $self->{fields} ||= {}; $self->{field_names} ||= []; # no name - return ala $cgi->param unless ($args{name}) { # return an array of the names in list context, and a # hashref of name/value pairs in a scalar context if (wantarray) { return @{$self->{field_names}}; } else { # Unfortunately, this only returns a single value my %ret = map { $_ => scalar $self->field($_) } @{$self->{field_names}}; return \%ret; } } # push onto our order only if we don't have yet... also init # the field value from CGI if it exists... if (! defined $self->{fields}{"$args{name}"} && keys(%args) > 1) { local $^W = 0; # length() triggers uninit, too slow to catch if ($CGI && length $CGI->param($args{name})) { debug 1, "sticky $args{name} from CGI = " . $CGI->param($args{name}); $self->{fields}{"$args{name}"}{value_orig} ||= $self->{fields}{"$args{name}"}{value}; $self->{fields}{"$args{name}"}{value} = [ $CGI->param($args{name}) ]; $self->{field_cgivals}{"$args{name}"} = 1; } push @{$self->{field_names}}, $args{name}; } # we use this to mess around with a single field while(my($k,$v) = each %args) { next if $k eq 'name'; # special catch for value debug 2, "walking field() args: $k => $v"; if ($k eq 'value') { # don't set value if CGI already has! next if $self->{field_cgivals}{"$args{name}"} && ! $args{force}; debug 1, "manually forced field $args{name} value => $v"; $self->{field_inited}{"$args{name}"} = 1; $self->{fields}{"$args{name}"}{value_orig} ||= $self->{fields}{"$args{name}"}{value}; $v = [_data $v]; } $self->{fields}{"$args{name}"}{$k} = $v; } # return the value my @v = _data($self->{fields}{"$args{name}"}{value}); debug 2, "return field($args{name})"; return wantarray ? @v : $v[0]; } # force return of a hash from above field function sub values { puke "Sorry, CGI::FormBuilder->values is not currently supported"; my $href = scalar shift()->field; # Now setup all our values my @ret; while(my($k,$v) = each %{$href}) { push @ret, $k, join $", @{$v->{value} || []}; } return wantarray ? @ret : \@ret; } *output = \&render; # unpublished, but works sub render { my $self = shift; # lose fucking uninitialized warnings local $^W = 0; # We create our hash based on the variables set from our # global options, followed by those from our local sub call my %args = ( %{$self->{opt}}, _args(@_) ); # Thanks to Randy Kobes for this patch fixing $0 on Win32 my($basename) = ($^O =~ /Win32/i) ? ($0 =~ m!.*\\(.*)\??!) : ($0 =~ m!.*/(.*)\??!); # We manually set these to the "defaults" because browers suck unless ($args{action} ||= $ENV{SCRIPT_NAME}) { $args{action} = $basename; } delete $args{action} unless $args{action}; $args{method} ||= 'GET'; puke "You can only specify the 'params' option to ".__PACKAGE__."->new" if $args{params}; # These options default to 1 for my $def2one (qw/sticky labels smartness/) { $args{$def2one} = 1 unless exists $args{$def2one}; } # Per request of Peter Billam, auto-determine javascript setting # based on user agent if (! exists $args{javascript} || $args{javascript} eq 'auto') { if (exists $ENV{HTTP_USER_AGENT} && $ENV{HTTP_USER_AGENT} =~ /lynx|mosaic/i) { # Turn off for old/non-graphical browsers $args{javascript} = 0; } else { # 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. $args{javascript} = 1; } } # Process any fields specified, if applicable $self->{opt}{smartness} = $args{smartness}; # XXX kludge if (my $fields = delete $args{fields}) { $self->_initfields(fields => $fields, values => delete $args{values}); } elsif (my $values = $args{values}) { $self->_initfields(values => $values); } # Defaults for native HTML unless($args{title}) { # Here we generate the title based on the executable! nifty! $args{title} = _toname($basename); debug 1, "auto-created title as '$args{title}' from script name ($basename)"; } $args{text} ||= ''; # shut up "uninit in concat" in heredoc $args{body} ||= { bgcolor => 'white' }; # Thresholds for radio, checkboxes, and selects (in # of items) carp "Warning: 'radionum' option is deprecated and will be ignored" if $args{radionum}; $args{selectnum} ||= 5; my %tmplvar = %{$self->{tmplvar} || {}}; # holds stuff for HTML::Template my $outhtml = ''; my $font = $args{font} ? _tag('font', face => $args{font}) : ''; # XXX This is a major fucking hack. the only way that we # XXX can reliably keep state is by saving the whole # XXX fields part of the object and restoring it later, # XXX since this sub currently alters it. Yeeeesh! # XXX Yes, this has to be anonymous so it ends up a copy my $oldfn = [ @{$self->{field_names} ||= []} ]; my $oldfv = { %{$self->{fields} ||= {}} }; # we can also put stuff inside a table if so requested... my($to, $tc, $tdl, $tdo, $td2, $tdc, $tro, $trc, $co, $cc) = ('' x 9); unless (exists $args{table}) { $args{table} = 1 if @{$self->{field_names}} > 1; } if ($args{table}) { # Strictly speaking, these should all use _tag, but this is faster. # Currently, table/tr/td attrs are not supported. Should they be? # Or should we just tell people to use a fucking template? $to = ''; $tc = '
'; $tdl = '' . $font; $tdo = '' . $font; $td2 = '' . $font; $tdc = ''; # we cannot use _tag() for , because @OURATTR filters # out valign (otherwise all tags would have it) $tro = ''; $trc = ''; $co = '
'; $cc = '
'; } else { # Forge some of the table markers as spacers instead $tdc = ' '; } # Auto-sense linebreaks if not set $args{linebreaks} = 1 if $args{table}; # How to handle line breaks - include
only if not a table my $br = $args{linebreaks} ? ($args{table} ? "\n" : "
\n") : ''; # For holding the JavaScript validation code my $jsfunc = ''; my $jsname = $args{name} ? "validate_$args{name}" : 'validate'; if ($args{javascript} && $args{validate} || $args{required}) { $jsfunc .= "\n" . _tag('script', language => 'JavaScript1.2') . "\n

); # setup our form onSubmit # needs to be ||= so user can overrride w/ own tag $args{onSubmit} ||= "return $jsname(this);"; } # handle the submit/reset buttons # 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, $reset) = ('', ''); unless ($args{static}) { if ($args{submit} || ! exists $args{submit}) { if (ref $args{submit} eq 'ARRAY') { # multiple buttons + JavaScript - here we go! for my $s (_data $args{submit}) { my $js = $args{submit} ? qq( onClick="this.form.submit.value = this.value;") : ''; $submit .= _tag("input$js", type => 'submit', name => '_submit', value => $s); } } else { # show the text on the button $submit = _tag('input', type => 'submit', name => '_submit', value => ($args{submit} || 'Submit')); } } if ($args{reset} || ! exists $args{reset}) { $reset = _tag('input', type => 'reset', name => '_reset', value => ($args{reset} || 'Reset')); } } $outhtml .= $tro . $td2 . $co . $reset . $submit . $cc . $tdc . $trc . $tc . $br; # closing tag $outhtml .= ""; # and body/html $outhtml .= "\n" if $args{header}; # hidden trailer. if you perceive this as annoying, let me know and I # may remove it. it's supposed to help. my $copy = $::TESTING ? '' : "\n"; # opening

tag: this is reversed, because our JavaScript might # have added an onSubmit attr. as such we have to add to the front # we also include a couple special state tracking tags, _submitted # and _sessionid. my $formtag = _tag('form', %args) . $copy; my($sid, $smv) = (0, 0); # suffix _submitted w/ form name if present my $smtag = '_submitted' . ($args{name} ? "_$args{name}" : ''); if ($CGI) { $sid = $CGI->param('_sessionid') || ''; $smv = ($CGI->param($smtag) || 0) + 1; } $formtag .= _tag('input', type => 'hidden', name => $smtag, value => $smv) . _tag('input', type => 'hidden', name => '_sessionid', value => $sid); # 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 if ($args{keepextras} && $CGI) { for my $k ($CGI->param) { # skip leading underscore fields, previously-defined fields, and submit/reset next if $self->{fields}{$k} || $k =~ /^_/ || $k eq 'submit' || $k eq 'reset'; for my $v ($CGI->param($k)) { $formtag .= _tag('input', type => 'hidden', name => $k, value => $v); } } } # Now assemble the top of the form $outhtml = $formtag . $to . $br . $outhtml; # FINAL STEP # If we're using a template, then we "simply" setup a bunch of vars # in %tmplvar (which is also accessible via $form->tmpl_param) and # then use $h->output to render the template. Otherwise, we "print" # the HTML we generated above verbatim by returning as a scalar. # # NOTE: added code to handle Template Toolkit, abw November 2001 my $header = $args{header} ? "Content-type: text/html\n\n" : ''; if ($args{template}) { my (%tmplopt, $tmpltype) = (); if (ref $args{template} eq 'HASH') { %tmplopt = %{$args{template}}; $tmpltype = $tmplopt{type} || 'HTML'; } else { %tmplopt = (filename => $args{template}, die_on_bad_params => 0); $tmpltype = 'HTML'; } if ($tmpltype eq 'HTML') { eval { require HTML::Template }; puke "Can't use templates because HTML::Template is not installed!" if $@; my $h = HTML::Template->new(%tmplopt); # a couple special fields $tmplvar{'form-start'} = $formtag; $tmplvar{'form-submit'} = $submit; $tmplvar{'form-reset'} = $reset; $tmplvar{'form-end'} = '
'; $tmplvar{'js-head'} = $jsfunc; # loop thru each field we have and set the tmpl_param while(my($param, $tag) = each %tmplvar) { $h->param($param => $tag); } # prepend header to template rendering $outhtml = $header . $h->output; } elsif ($tmpltype eq 'TT2') { eval { require Template }; puke "Can't use templates because the Template Toolkit is not installed!" if $@; my ($tt2engine, $tt2template, $tt2data, $tt2var, $tt2output); $tt2engine = $tmplopt{engine} || { }; $tt2engine = Template->new($tt2engine) || puke $Template::ERROR unless UNIVERSAL::isa($tt2engine, 'Template'); $tt2template = $tmplopt{template} || puke "tt2 template not specified"; $tt2data = $tmplopt{data} || { }; $tt2var = $tmplopt{variable}; # special fields $tmplvar{'start'} = $formtag; $tmplvar{'submit'} = $submit; $tmplvar{'reset'} = $reset; $tmplvar{'end'} = ''; $tmplvar{'jshead'} = $jsfunc; $tmplvar{'invalid'} = $self->{state}{invalid}; $tmplvar{'fields'} = [ map $tmplvar{field}{$_}, @{ $self->{field_names} } ]; if ($tt2var) { $tt2data->{$tt2var} = \%tmplvar; } else { $tt2data = { %$tt2data, %tmplvar }; } $tt2engine->process($tt2template, $tt2data, \$tt2output) || puke $tt2engine->error(); $outhtml = $header . $tt2output; } else { puke "Invalid template type '$tmpltype' specified - can be 'HTML' or 'TT2'"; } } else { my $body = _tag('body', %{$args{body}}); # assemble header HTML-compliantly $jsfunc = "$args{title}$jsfunc" . "$body$font

$args{title}

\n" if $header; # Insert any text we may have specified my $text = $args{text} || $args{text} || ''; if (! $text) { if ($self->{state}{invalid}) { my $s = $self->{state}{invalid} == 1 ? '' : 's'; $text = qq(Your submission had $self->{state}{invalid} error$s. Please correct ) . qq(the red fields below.\n); } elsif (keys %need) { $text = qq(Fields shown in bold are required.); } } $outhtml = $header . $jsfunc . $text . $outhtml; } # XXX finally, reset our fields and field_names $self->{field_names} = $oldfn; $self->{fields} = $oldfv; return $outhtml; } sub confirm { # This is nothing more than a special wrapper around render() my $self = shift; my %args = _args(@_); my $date = localtime; $args{text} ||= qq(Success! Your submission has been received $date.); $args{static} = 1; return $self->render(%args); } sub mail { # This is a very generic mail handler my $self = shift; my %args = _args(@_); # Where does the mailer live? Must be sendmail-compatible my $mailer = ''; unless ($mailer = $args{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 to use"; return; } open(MAIL, "|$mailer") || next; print MAIL < 1); my %args = _args(@_); # must have a "to" return unless $args{to} ||= $to; # defaults $args{from} ||= 'auto-reply'; $args{subject} ||= "$self->{opt}{title} Submission Confirmation"; $args{text} ||= <mail(%args); } sub mailresults { # This is a wrapper around mail() that sends the form results my $self = shift; my %args = _args(@_); # Get the field separator to use my $delim = $args{delimiter} || ': '; my $join = $args{joiner} || $"; # subject default $args{subject} ||= "$self->{opt}{title} Submission Results"; my @form = (); for my $field ($self->fields) { my $v = join $join, $self->field($field); push @form, "$field$delim$v"; } my $text = join "\n", @form; $self->mail(%args, text => $text); } sub submitted { # this returns the value of the submit key, if any return unless $CGI; my $self = shift; my $smtag = shift || ('_submitted' . ($self->{opt}{name} ? "_$self->{opt}{name}" : '')); if ($CGI->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). return $CGI->param('_submit') || '0E0'; } else { return; } } sub sessionid { # checks for the _sessoinid parameter return unless $CGI; return $CGI->param('_sessionid'); } # This allows a crude method of delegation sub cgi_param { return unless $CGI; shift; $CGI->param(@_); } # This allows us to interface with our HTML::Template sub tmpl_param { my $self = shift; my $key = shift; @_ ? $self->{tmplvar}{$key} = shift : $self->{tmplvar}{$key}; } sub validate { # this function does all the validation on the Perl side # it doesn't generate JavaScript; see render() for that... my $self = shift; my $form = $self; # XXX alias for examples (paint-by-numbers) # Create our %valid hash which takes into account local args my %valid = (%{$self->{opt}{validate} || {}}, _args(@_)); # Get %need from expansion of our 'required' param to new() my %need = $self->_expreqd($self->{opt}{required}, \%valid); # Fail or success? my $bad = 0; for my $field (@{$self->{field_names}}) { # Get validation pattern if exists my $pattern = $valid{$field} || 'VALUE'; # fatal error if they try to validate nonexistent field puke "Attempt to validate non-existent field '$field'" unless $self->{fields}{$field}; # loop thru, and if something isn't valid, we tag it my $atleastone = 0; for my $value ($self->field($field)) { my $thisfail = 0; $atleastone++; # check for if $need{$field}; if not, next if blank if (! $need{$field}) { debug 2, "$field: is optional per 'required' param"; next if (! defined $value); debug 2, "$field: ...but is defined, so still checking"; } # Check our hash to see if it's a special pattern ($pattern) = _data($VALID{$pattern}) if $VALID{$pattern}; # pre-catch: hashref is a grouping per-language if (ref $pattern eq 'HASH') { $pattern = $pattern->{perl} || next; } debug 1, "$field: validating against pattern '$pattern'"; if ($pattern =~ m!^m?(.).*\1$!) { # it be a regexp debug 1, "$field: does '$value' =~ $pattern ?"; unless (eval qq('$value' =~ $pattern ? 1 : 0)) { $self->{fields}{$field}{invalid} = 1; $thisfail = ++$bad; } } elsif (ref $pattern eq 'ARRAY') { # must be w/i this set of values debug 1, "$field: is '$value' in (@{$pattern}) ?"; unless (_ismember($value, @{$pattern})) { $self->{fields}{$field}{invalid} = 1; $thisfail = ++$bad; } } elsif ($pattern eq 'VALUE') { # Not null local $^W = 0; # length() triggers uninit, too slow to catch debug 1, "$field: length '$value' > 0 ?"; unless (length $value) { $self->{fields}{$field}{invalid} = 1; $thisfail = ++$bad; } } else { # literal string is a literal comparison, but warn of typos... belch "Validation string '$pattern' may be a typo of a builtin pattern" if ($pattern =~ /^[A-Z]+$/); debug 1, "$field: '$value' $pattern ? 1 : 0"; unless (eval qq('$value' $pattern ? 1 : 0)) { $self->{fields}{$field}{invalid} = 1; $thisfail = ++$bad; } } # Just for debugging's sake $thisfail ? debug 2, "$field: validation FAILED" : debug 2, "$field: validation passed"; } # If not $atleastone and they asked for validation, then we # know that we have an error since this means no values unless ($atleastone) { $self->{fields}{$field}{invalid} = 1; $bad++; } } debug 2, "validation done, failures (\$bad) = $bad"; $self->{state}{invalid} = $bad; return $bad ? 0 : 1; } 1; __END__ =head1 DESCRIPTION =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 really haven't 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 the venerable C are great for processing parameters, but they don't save you much time when trying to generate and process forms. The goal of C (B) is to provide an easy way for you to generate and process CGI form-based applications. This module is designed to be smart in that it figures a lot of stuff out for you. As a result, B gives you about a B<4:1> ratio of the code it generates versus what you have to write. For example, if you have multiple values for a field, it sticks them in a radio, checkbox, or select group, depending on some factors. It will also automatically name fields for you in human-readable labels depending on the field names, and lay everything out in a nicely formatted table. It will even title the form based on the name of the script itself (C becomes "Order Form"). Plus, B provides you full-blown validation for your fields, including some useful builtin patterns. It will even generate JavaScript validation routines on the fly! And, of course, it maintains state ("stickiness") across submissions, with hooks provided for you to plugin your own sessionid module such as C. And though it's smart, it allows you to customize it as well. For example, if you really want something to be a checkbox, you can make it a checkbox. And, if you really want something to be output a specific way, you can even specify the name of an C or Template Toolkit (C