' . $self->title . '

package CGI::FormBuilder; # Copyright (c) 2000-2005 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( 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; } =cut use Carp; use strict; use vars qw($VERSION $AUTOLOAD %DEFOPTS %REARRANGE); use CGI::FormBuilder::Util; use CGI::FormBuilder::Field; use CGI::FormBuilder::Messages; $VERSION = '3.01'; # Default options for FormBuilder %DEFOPTS = ( sticky => 1, method => 'GET', submit => 'Submit', reset => 'Reset', submitname => '_submit', resetname => '_reset', body => { bgcolor => 'white' }, text => '', table => { border => 0 }, tr => { valign => 'middle' }, td => { align => 'left' }, jsname => 'validate', sessionidname => '_sessionid', submittedname => '_submitted', template => '', # default template debug => 0, # can be 1 or 2 javascript => 'auto', # 0, 1, or 'auto' render => 'render', # render sub name smartness => 1, # can be 1 or 2 selectnum => 5, stylesheet => 0, # use stylesheet stuff? styleclass => 'fb_', # prefix for style doctype => < EOD ); # Which options to rearrange from new() into field() %REARRANGE = qw( options options labels label validate validate required required selectnum selectnum sortopts sortopts nameopts nameopts sticky sticky ); *redo = \&new; sub new { local $^W = 0; # -w sucks my $self = shift; my %opt = cleanargs(@_); # old options $opt{td}{align} = delete $opt{lalign} if $opt{lalign}; 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 %DEFOPTS) { 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}); } # And a messages delegate if not existent unless ($self->{messages} && ref $self->{messages} ne 'HASH') { $self->{messages} = CGI::FormBuilder::Messages->new($self->{messages}); } # XXX not mod_perl safe (problem) $CGI::FormBuilder::Util::DEBUG = $self->{debug}; # 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} ]; } } # Catch the intersection of required and validate if ($self->{required} && $self->{validate}) { # ok, will handle itself automatically below } elsif ($self->{required}) { # ok, validate will default to values } 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 = (); # holds field properties $fprop{name} = $_; if (ref $_ eq 'CGI::FormBuilder::Field') { # is an existing Field object, so update its properties $_->field(%fprop); } else { # init a new one $_ = $self->newfield(%fprop); } debug 2, "push \@(@ftmp), $_"; 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; } *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 = cleanargs(@_); $args{name} ||= $name; # 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) { # 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}'"; for (@{$self->{fields}}) { debug 2, "checking $_"; # serial search not that much slower unless dozens of # fields, plus then we know it's already been blessed if ($_ eq $args{name}) { debug 2, "found $_ eq $args{name}"; delete $args{name}; # segfault?? return $_->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->newfield(%args); push @{$self->{fields}}, $f; return $f->value; } sub newfield { my $self = shift; my %args = cleanargs(@_); puke "Need a name for \$form->newfield()" unless exists $args{name}; debug 1, "called \$form->newfield($args{name})"; # extract our per-field options from rearrange while (my($from,$to) = each %REARRANGE) { next unless exists $self->{$from}; next if $args{$to}; # manually set my $tval; my $ref = ref $self->{$from}; if ($ref && $ref eq 'HASH') { $tval = $self->{$from}{$args{name}}; } elsif ($ref && $ref eq 'ARRAY') { $tval = ismember($args{name}, @{$self->{$from}}) ? 1 : 0; } elsif ($self->{$from} eq 'NONE') { $tval = 0; } elsif ($self->{$from} eq 'ALL') { $tval = 1; } else { $tval = $self->{$from}; } 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 basename { my $prog = $ENV{SCRIPT_NAME} || $0; # Thanks to Randy Kobes for this patch fixing $0 on Win32 my($basename) = ($^O =~ /Win32/i) ? ($prog =~ m!.*\\(.*)\??!) : ($prog =~ m!.*/(.*)\??!); return $basename; } sub header { my $self = shift; $self->{header} = shift if @_; return $self->{header} ? "Content-Type: text/html; charset=ISO-8859-1\n\n" : ''; } sub title { my $self = shift; $self->{title} = shift if @_; return $self->{title} if exists $self->{title}; return toname($self->basename); } sub action { my $self = shift; $self->{action} = shift if @_; return $self->{action} if exists $self->{action}; return $ENV{SCRIPT_NAME} || $self->basename; } 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; if ($self->{font} && ! ref $self->{font}) { $ret = { face => $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{class} ||= $self->{styleclass} . 'form' if $self->{stylesheet}; return $self->version . htmltag('form', %attr); } sub end { return ''; } # These return attr in wantarray (unusual) since it helps in render() sub body { my $self = shift; $self->{body} = shift if @_; return wantarray ? htmlattr('body', $self->{body}) : htmltag('body', $self->{body}); } sub table { my $self = shift; $self->{table} = shift if @_; return '' unless $self->{table}; # 0 or unset $self->{table} = {} if $self->{table} == 1; $self->{table}{class} ||= $self->{styleclass} . 'table' if $self->{stylesheet}; return wantarray ? htmlattr('table', $self->{table}) : htmltag('table', $self->{table}); } sub tr { my $self = shift; $self->{tr} = shift if @_; $self->{tr}{class} ||= $self->{styleclass} . 'tr' if $self->{stylesheet}; return wantarray ? htmlattr('tr', $self->{tr}) : htmltag('tr', $self->{tr}); } sub td { my $self = shift; $self->{td} = shift if @_; $self->{td}{class} ||= $self->{styleclass} . 'td' if $self->{stylesheet}; return wantarray ? htmlattr('td', $self->{td}) : htmltag('td', $self->{td}); } 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; } sub sessionid { my $self = shift; return unless $self->sessionidname; return $self->{params}->param($self->sessionidname) || ''; } sub statetags { my $self = shift; my @state = (); # get _submitted my $smnam = $self->submittedname; my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam; my $smv = $self->{params}->param($smnam) + 1; push @state, { name => $smtag, value => $smv, type => 'hidden' }; # and how about _sessionid push @state, { name => $self->sessionidname, value => $self->sessionid, type => 'hidden' }; return join '', map { htmltag('input', $_) } @state; } *keepextra = \&keepextras; sub keepextras { my $self = shift; my @keep = (); # which ones do they want? $self->{keepextras} = shift, return 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 @just_these = (); if (my $ref = ref $self->{keepextras}) { if ($ref eq 'ARRAY') { @just_these = @{$self->{keepextras}}; } else { puke "Unsupported data structure type '$ref' passed to 'keepextras' option"; } } # Go thru all params, skipping leading underscore fields and form fields for my $p ($self->{params}->param) { next if @just_these && ! ismember($p, @just_these); next if $p =~ /^_/ || $self->field($p); for my $v ($self->{params}->param($p)) { # make sure to get all values debug 1, "keepextras: saving hidden param $p = $v"; push @keep, { name => $p, type => 'hidden', value => $v }; } } return join '', map { htmltag('input', $_) } @keep; } sub javascript { my $self = shift; $self->{javascript} = shift if @_; # auto-determine javascript setting based on user agent if ($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; } } 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 script { local $^W = 0; my $self = shift; # no state is kept and no args are allowed puke "No args allowed for \$form->script" if @_; return '' unless $self->javascript; # get validate() function name my $jsname = $self->{name} ? "$self->{jsname}_$self->{name}" : $self->{jsname}; my $jsfunc = ''; # custom user jsfunc option for w/i validate() $jsfunc .= $self->jsfunc; # expand per-field validation functions for ($self->field) { $jsfunc .= $_->script; } # skip out if we have nothing useful return '' unless $jsfunc || $self->jshead; # prefix with opening code $jsfunc = $self->jshead . < 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 # setup our form onSubmit # needs to be ||= so user can overrride w/ own tag # XXX action at a distance, I really don't like this... $self->{onSubmit} ||= "return $jsname(this);"; # set "; } sub noscript { my $self = shift; # no state is kept and no args are allowed puke "No args allowed for \$form->noscript" if @_; return '' unless $self->javascript; return ''; } sub submit { my $self = shift; $self->{submit} = shift if @_; return '' if $self->static || ! $self->{submit}; # 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; 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;") : (); for my $s (autodata $self->{submit}) { push @submit, { name => $sn, type => 'submit', value => $s, @oncl }; } } else { # show the text on the button push @submit, { name => $sn, type => 'submit', value => $self->{submit} }; } return join '', map { htmltag('input', $_) } @submit; } sub reset { my $self = shift; $self->{reset} = shift if @_; return '' if $self->static || ! $self->{reset}; # similar to submit(), but a little simpler ;-) my $reset = { type => 'reset', name => $self->resetname, value => $self->{reset} }; return htmltag('input', $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) { # only show either invalid or required text return $self->{text} . sprintf($self->{messages}->form_invalid_text, $self->{messages}->form_invalid_opentag, $self->{messages}->form_invalid_closetag) if $inv; return $self->{text} . sprintf($self->{messages}->form_required_text, $self->{messages}->form_required_opentag, $self->{messages}->form_required_closetag) if $req; } return $self->{text}; } sub cgi_param { my $self = shift; $self->{params}->param(@_); } sub tmpl_param { puke "To interface with tmpl_param(), you must now create your own object"; } 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} = cleanargs(@_); 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})"; my $ref = ref $self->{values}; if ($ref && $ref eq '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 ($ref && $ref 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 = 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 ($ref && $ref eq '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 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} = cleanargs(@_); 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} = cleanargs(@_); 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 (@_) { $self->{validate} = ref $_[0] ? shift : { @_ }; } my $ok = 1; 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; my $sub = $self->{render}; 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}, $sub)) { # instantiated object return $self->{template}->$sub($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 'IncludedTemplate' $mod = join '::', __PACKAGE__, 'Template', $mod unless $mod =~ /::/; debug 1, "loading $mod for 'template' option"; eval "require $mod"; puke "Bad template engine $mod: $@" if $@; # dispatch to user sub debug 2, "return &{$mod\::$sub}($self)"; no strict 'refs'; return &{"$mod\::$sub"}($self, %opt); } else { # Builtin default rendering (follows) my $html = ''; debug 1, "no template module specified, using builtin rendering"; # Just for test suite purposes $self->{doctype} = '' if $::TESTING; # Opening CGI/title gunk if ($self->header) { $html .= $self->header; $html .= $self->doctype . ''; $html .= '' . $self->title . '' if $self->title; # stylesheet path if specified if ($self->stylesheet && $self->stylesheet =~ /\D/) { $html .= htmltag('link', { rel => 'stylesheet', href => $self->stylesheet }); } } # JavaScript validate/head functions if (my $sc = $self->script) { $html .= "\n" if $html; $html .= $sc . $self->noscript; } # Opening HTML if so requested my $font = $self->font; if ($self->header) { $html .= "\n"; $html .= $self->body; $html .= $font; $html .= '

' . $self->title . '

' if $self->title; } # Begin form $html .= $self->text; $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'; $html .= $field->tag; # no label/etc for hidden fields } # Get table stuff and reused calls my $table = $self->table; my $tr = $self->tr; my $td = $self->td; $html .= $table . "\n"; # want newline regardless my %ta = $self->td; $ta{align} = 'left'; # force input tags left my $lh = htmltag('td', %ta); # Render regular fields in table for my $field (@unhidden) { debug 2, "render: attacking normal field '$field'"; if ($table) { $html .= $tr . $td . $font; $html .= $self->{messages}->form_required_opentag if $field->required; $html .= $field->label; $html .= $self->{messages}->form_required_closetag if $field->required; $html .= '' if $font; $html .= '' . $lh . $font; $html .= $field->tag; $html .= ' ' . $field->comment if $field->comment; # "if" to control ' ' $html .= '' if $font; $html .= ''; $html .= $lh . $field->message . '' if $field->invalid; $html .= "\n"; } else { $html .= $field->label . ' ' . $field->tag . ' '; $html .= '
' if $self->linebreaks; } } # Throw buttons in a colspan my $buttons = $self->reset . $self->submit; if ($buttons) { if ($table) { $ta{colspan} = 2; $ta{align} = 'center'; $html .= $self->tr . htmltag('td', %ta) . $font; } $html .= $buttons; if ($table) { $html .= '' if $font; $html .= "\n" if $table; } } # Properly nest closing tags $html .= '' if $table; $html .= ''; # should be $form->end $html .= '' if $font && $self->header; $html .= "" if $self->header; $html .= "\n"; return $html; } } # These routines should be moved to ::Mail or something since they're never used sub mail () { # This is a very generic mail handler my $self = shift; my %args = cleanargs(@_); # 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 to use; mail aborting"; return; } unless ($args{to}) { belch "Missing required 'to' argument; cannot continue without recipient"; return; } 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 = cleanargs(@_); # 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 = cleanargs(@_); # 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 my $self = shift; my($name) = $AUTOLOAD =~ /.*::(.+)/; debug 3, "-> dispatch to \$form->{$name} = @_"; $self->{$name} = shift if @_; # Try to catch outdated $form->$fieldname usage if ((! exists($self->{$name}) || @_) && ! $CGI::FormBuilder::Util::OURATTR{$name}) { belch "Possible outdated field access via \$form->$name()" } 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 For a fast description of all available options, search for the string "quick" in this document. =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 they don't save you much time when trying to generate and process forms. The goal of C (B<"FormBuilder">) is to provide an easy way for you to generate and process entire CGI form-based applications. Its main features are: =over - Lots of builtin "intelligence", giving about a 4:1 ratio of the code it generates versus what you have to write. - Automatic field typing based on the number of options, as well as auto-naming and auto-layout. - Full-blown regex validation for form fields, including some builtin patterns and even JavaScript code generation. - Native HTML generation that is XHTML compliant and pretty nice looking, honestly. - Builtin support for C, C, and C

' . $self->title . '

User Information