package CGI::FormBuilder; # Copyright (c) 2000-2006 Nathan Wiger . All Rights Reserved. # Please visit www.formbuilder.org for tutorials, support, and examples. # Use "perldoc FormBuilder.pm" for complete documentation. =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); } =cut use Carp; use strict; use CGI::FormBuilder::Util; use CGI::FormBuilder::Field; use CGI::FormBuilder::Messages; our $VERSION = '3.03'; our $AUTOLOAD; # Default options for FormBuilder our %DEFAULT = ( sticky => 1, method => 'get', submit => 1, reset => 0, header => 0, body => { }, text => '', table => { }, tr => { }, th => { }, td => { }, 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 # I don't see any reason why these are variables submitname => '_submit', resetname => '_reset', rowname => '_row', labelname => '_label', fieldname => '_field', # equiv of buttonname => '_button', errorname => '_error', othername => '_other', growname => '_grow', 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 = (ref $_[0] eq '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 }; $ref = 'HASH'; # tricky debug 2, "rewrote 'source' option since found filename"; } if ($ref eq 'HASH') { # grab module $mod = delete $src->{type} || 'HTML'; # 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 ($self->{params} && ref $self->{params} ne 'HASH') { require CGI; $CGI::USE_PARAM_SEMICOLONS = 0; # fuck ; in urls $self->{params} = CGI->new($self->{params}); } # XXX not mod_perl safe (problem) $CGI::FormBuilder::Util::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'); } 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 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, "got 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 = %{delete($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); } debug 2, "push \@(@ftmp), $_"; $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); $self->{fieldrefs}{"$f"} = $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 ^^^ } 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 '' 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->{styleclass} if $self->{stylesheet}; # 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 unless $self->{stylesheet}; return join '', $self->{styleclass}, @_; # 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}; $self->{table} = $DEFAULT{table} if $self->{table} == 1; my %attr = %{$self->{table}}; # if still have args, it's a temp hash if (@_) { while (my $k = shift) { $attr{$k} = shift; } } return unless $self->{table}; # 0 or unset $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; my %attr = %{$self->{tr}}; # if still have args, it's a temp hash if (@_) { while (my $k = shift) { $attr{$k} = shift; } } # 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; my %attr = %{$self->{th}}; # if still have args, it's a temp hash if (@_) { while (my $k = shift) { $attr{$k} = shift; } } # 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; my %attr = %{$self->{td}}; # if still have args, it's a temp hash if (@_) { while (my $k = shift) { $attr{$k} = shift; } } # extraneous - inherits from
#$attr{class} ||= $self->class($self->{fieldname}); return htmltag('td', %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) { for my $v ($self->{params}->param($p)) { 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 = < tags # We do a regex trick to turn "%s" into "+invalid+" (my $alertstart = $self->{messages}->js_invalid_start) =~ s/%s/'+invalid+'/g; (my $alertend = $self->{messages}->js_invalid_end) =~ s/%s/'+invalid+'/g; $jsfunc .= < 0 || alertstr != '') { if (! invalid) invalid = 'The following'; // catch for programmer error alert('$alertstart'+'\\n\\n' +alertstr+'\\n'+'$alertend'); // reset counters alertstr = ''; invalid = 0; return false; } return true; // all checked ok } EOJS # Must set our onsubmit to call validate() # Unfortunately, this introduces the requirement that script() # must be generated/called before start() in our template engines. # Fortunately, that usually happens anyways. Still sucks. $self->{onsubmit} ||= "return $jsname(this);"; } # set "; } 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 : puke "Called \$form->submits in scalar context somehow"; } 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 Nathan 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); $ok = 0 if ($self->{dfv_results}->has_invalid or $self->{dfv_results}->has_missing); } 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(@_); } 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"; } my %opt; if ($ref eq 'HASH') { # must copy to avoid destroying %opt = %{ $self->{template} }; $mod = 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 if supplied if ($mod) { # 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 my $tmpl = $mod->new(%opt); # dispatch to engine render return $tmpl->render($self); } # Builtin default rendering (follows) debug 1, "no template module specified, using builtin rendering"; return $self->render_builtin; } sub render_builtin { my $self = shift; my @html = (); # joined with newline # Opening CGI/title gunk my $hd = $self->header; if (defined $hd) { push @html, ($hd . $self->dtd), ''; push @html, (''.$self->title.'') if $self->title; # stylesheet path if specified if ($self->{stylesheet} && $self->{stylesheet} ne 1) { # user-specified path push @html, htmltag('link', { rel => 'stylesheet', type => 'text/css', href => $self->{stylesheet} }); } } # JavaScript validate/head functions my $js = $self->script; push @html, $js if $js; # Opening HTML if so requested my $font = $self->font; my $fcls = $font ? '' : ''; if (defined $hd) { push @html, '', $self->body; push @html, $font if $font; push @html, ('

'.$self->title.'

') if $self->title; } # Include warning if noscript push @html, $self->noscript if $js; # Begin form my $txt = $self->text; push @html, $txt if $txt; push @html, $self->start, '
', ($self->statetags . $self->keepextras); # Render hidden fields first my @unhidden; for my $field ($self->field) { push(@unhidden, $field), next if $field->type ne 'hidden'; push @html, $field->tag; # no label/etc for hidden fields } # Get table stuff and reused calls my $table = $self->table; push @html, $table if $table; # Render regular fields in table for my $field (@unhidden) { debug 2, "render: attacking normal field '$field'"; next if $field->static > 1 && ! $field->tag_value; # skip missing static vals if ($table) { my($trid, $laid, $inid, $erid, $cmid, $cl); if ($self->{name}) { # add id's to all elements $trid = tovar("$self->{name}_$field$self->{rowname}"); $laid = tovar("$self->{name}_$field$self->{labelname}"); $inid = tovar("$self->{name}_$field$self->{fieldname}"); $erid = tovar("$self->{name}_$field$self->{errorname}"); $cmid = tovar("$self->{name}_$field$self->{commentname}"); } push @html, $self->tr(id => $trid); $cl = $self->class($self->{labelname}); my $row = ' ' . $self->td(id => $laid, class => $cl) . $font; if ($field->invalid) { $row .= $self->invalid_tag($field->label); } elsif ($field->required && ! $field->static) { $row .= $self->required_tag($field->label); } else { $row .= $field->label; } $row .= $fcls . ''; push @html, $row; # tag plus optional errors and/or comments $row = ''; if ($field->invalid) { $row .= ' ' . $field->message; } if ($field->comment) { $row .= ' ' . $field->comment unless $field->static; } $row = $field->tag . $row; $cl = $self->class($self->{fieldname}); push @html, (' ' . $self->td(id => $inid, class => $cl) . $font . $row . $fcls . ''); push @html, ''; } else { # no table my $row = $font; if ($field->invalid) { $row .= $self->invalid_tag($field->label); } elsif ($field->required && ! $field->static) { $row .= $self->required_tag($field->label); } else { $row .= $field->label; } $row .= $fcls; push @html, $row; push @html, $field->tag; push @html, $field->message if $field->invalid; push @html, $field->comment if $field->comment; push @html, '
' if $self->linebreaks; } } # Throw buttons in a colspan my $buttons = $self->reset . $self->submit; if ($buttons) { my $row = ''; if ($table) { my($trid, $inid); if ($self->{name}) { # add id's $trid = tovar("$self->{name}_submit$self->{rowname}"); $inid = tovar("$self->{name}_submit$self->{fieldname}"); } my $c = $self->class($self->{submitname}); my %a = $c ? () : (align => 'center'); $row .= $self->tr(id => $trid) . "\n " . $self->td(id => $inid, class => $c, colspan => 2, %a) . $font; } $row .= $buttons; if ($table) { $row .= '' if $font; $row .= "\n" if $table; } push @html, $row; } # Properly nest closing tags push @html, '
' if $table; push @html, '',''; # $form->end push @html, '' if $font && defined $hd; push @html, '','' if defined $hd; # Always return scalar since print() is a list function return join("\n", @html) . "\n" } # 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}) { $mailer .= " -f $args{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 "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(@_); # 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__ =head1 DESCRIPTION If this is your first time using B, you should check out the website for tutorials and examples: www.formbuilder.org You should also consider joining the mailing list by sending an email to: fbusers-subscribe@formbuilder.org 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