CGI-FormBuilder
view release on metacpan or search on metacpan
lib/CGI/FormBuilder.pm view on Meta::CPAN
###########################################################################
# Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved.
# Please visit http://formbuilder.org for tutorials, support, and examples.
###########################################################################
# Note: Documentation has grown so massive it is now in FormBuilder.pod
package CGI::FormBuilder;
use Carp;
use strict;
use warnings;
no warnings 'uninitialized';
use Scalar::Util qw(weaken);
use CGI::FormBuilder::Util;
use CGI::FormBuilder::Field;
use CGI::FormBuilder::Messages;
our $VERSION = '3.20';
our $AUTOLOAD;
# Default options for FormBuilder
our %DEFAULT = (
sticky => 1,
method => 'get',
submit => 1,
reset => 0,
header => 0,
body => { },
text => '',
table => { },
tr => { },
th => { },
td => { },
div => { },
jsname => 'validate',
jsprefix => 'fb_', # prefix for JS tags
sessionidname => '_sessionid',
submittedname => '_submitted',
pagename => '_page',
template => '', # default template
debug => 0, # can be 1 or 2
javascript => 'auto', # 0, 1, or 'auto'
cookies => 1,
cleanopts => 1,
render => 'render', # render sub name
smartness => 1, # can be 1 or 2
selectname => 1, # include -select-?
selectnum => 5,
stylesheet => 0, # use stylesheet stuff?
styleclass => 'fb', # style class to use
# For translating tag names (experimental)
tagnames => { },
# I don't see any reason why these are variables
formname => '_form',
submitname => '_submit',
resetname => '_reset',
bodyname => '_body',
tabname => '_tab',
rowname => '_row',
labelname => '_label',
fieldname => '_field', # equiv of <tmpl_var field-tag>
buttonname => '_button',
errorname => '_error',
othername => '_other',
growname => '_grow',
statename => '_state',
extraname => '_extra',
dtd => <<'EOD', # modified from CGI.pm
<?xml version="1.0" encoding="{charset}"?>
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
lib/CGI/FormBuilder.pm view on Meta::CPAN
if ($self->{fields}) {
debug 1, "creating fields list";
# check to see if 'fields' is a hash or array ref
my $ref = ref $self->{fields};
if ($ref && $ref eq 'HASH') {
# with a hash ref, we setup keys/values
debug 2, "got fields list from HASH";
while(my($k,$v) = each %{$self->{fields}}) {
$k = lc $k; # must lc to ignore case
$self->{values}{$k} = [ autodata $v ];
}
# reset main fields to field names
$self->{fields} = [ sort keys %{$self->{fields}} ];
} else {
# rewrite fields to ensure format
debug 2, "assuming fields list from ARRAY";
$self->{fields} = [ autodata $self->{fields} ];
}
}
if (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
debug 2, "got a Data::FormValidator for validate";
# we're being a bit naughty and peeking inside the DFV object
$self->{required} = $self->{validate}{profiles}{fb}{required};
} else {
# Catch the intersection of required and validate
if (ref $self->{required}) {
# ok, will handle itself automatically below
} elsif ($self->{required}) {
# catches for required => 'ALL'|'NONE'
if ($self->{required} eq 'NONE') {
delete $self->{required}; # that's it
}
elsif ($self->{required} eq 'ALL') {
$self->{required} = [ @{$self->{fields}} ];
}
elsif ($self->{required}) {
# required => 'single_field' catch
$self->{required} = { $self->{required} => 1 };
}
} elsif ($self->{validate}) {
# construct a required list of all validated fields
$self->{required} = [ keys %{$self->{validate}} ];
}
}
# Now, new for the 3.x series, we cycle thru the fields list and
# replace it with a list of objects, which stringify to field names
my @ftmp = ();
for (@{$self->{fields}}) {
my %fprop = %{$self->{fieldopts}{$_} || {}}; # field properties
if (ref $_ =~ /^CGI::FormBuilder::Field/i) {
# is an existing Field object, so update its properties
$_->field(%fprop);
} else {
# init a new one
$fprop{name} = "$_";
$_ = $self->new_field(%fprop);
weaken($_->{_form});
}
debug 2, "push \@(@ftmp), $_";
weaken($self->{fieldrefs}{"$_"} = $_);
push @ftmp, $_;
}
# stringifiable objects (overwrite previous container)
$self->{fields} = \@ftmp;
# setup values
$self->values($self->{values}) if $self->{values};
debug 1, "field creation done, list = (@ftmp)";
return $self;
}
*param = \&field;
*params = \&field;
*fields = \&field;
sub field {
local $^W = 0; # -w sucks
my $self = shift;
debug 2, "called \$form->field(@_)";
# Handle any of:
#
# $form->field($name)
# $form->field(name => $name, arg => 'val')
# $form->field(\@newlist);
#
return $self->new(fields => $_[0])
if ref $_[0] eq 'ARRAY' && @_ == 1;
my $name = (@_ % 2 == 0) ? '' : shift();
my $args = arghash(@_);
$args->{name} ||= $name;
# no name - return ala $cgi->param
unless ($args->{name}) {
# sub fields
# return an array of the names in list context, and a
# hashref of name/value pairs in a scalar context
if (wantarray) {
# pre-scan for any "order" arguments, reorder, delete
for my $redo (grep { $_->order } @{$self->{fields}}) {
next if $redo->order eq 'auto'; # like javascript
# kill existing order
for (my $i=0; $i < @{$self->{fields}}; $i++) {
if ($self->{fields}[$i] eq $redo) {
debug 2, "reorder: removed $redo from \$fields->[$i]";
splice(@{$self->{fields}}, $i, 1);
}
}
# put it in its new place
debug 2, "reorder: moving $redo to $redo->{order}";
if ($redo->order <= 1) {
# start
unshift @{$self->{fields}}, $redo;
} elsif ($redo->order >= @{$self->{fields}}) {
# end
push @{$self->{fields}}, $redo;
} else {
# middle
splice(@{$self->{fields}}, $redo->order - 1, 0, $redo);
}
# kill subsequent reorders (unnecessary)
delete $redo->{order};
}
# list of all field objects
debug 2, "return (@{$self->{fields}})";
return @{$self->{fields}};
} else {
# this only returns a single scalar value for each field
return { map { $_ => scalar($_->value) } @{$self->{fields}} };
}
}
# have name, so redispatch to field member
debug 2, "searching fields for '$args->{name}'";
if ($args->{delete}) {
# blow the thing away
delete $self->{fieldrefs}{$args->{name}};
my @tf = grep { $_->name ne $args->{name} } @{$self->{fields}};
$self->{fields} = \@tf;
return;
} elsif (my $f = $self->{fieldrefs}{$args->{name}}) {
delete $args->{name}; # segfault??
return $f->field(%$args); # set args, get value back
}
# non-existent field, and no args, so assume we're checking for it
return unless keys %$args > 1;
# if we're still in here, we need to init a new field
# push it onto our mail fields array, just like initfields()
my $f = $self->new_field(%$args);
weaken($self->{fieldrefs}{"$f"} = $f);
weaken($f->{_form});
weaken($f->{fieldrefs}{"$f"});
push @{$self->{fields}}, $f;
return $f->value;
}
sub new_field {
my $self = shift;
my $args = arghash(@_);
puke "Need a name for \$form->new_field()" unless exists $args->{name};
debug 1, "called \$form->new_field($args->{name})";
# extract our per-field options from rearrange
while (my($from,$to) = each %REARRANGE) {
next unless exists $self->{$from};
next if defined $args->{$to}; # manually set
my $tval = rearrange($self->{$from}, $args->{name});
debug 2, "rearrange: \$args->{$to} = $tval;";
$args->{$to} = $tval;
}
$args->{type} = lc $self->{fieldtype}
if $self->{fieldtype} && ! exists $args->{type};
if ($self->{fieldattr}) { # legacy
while (my($k,$v) = each %{$self->{fieldattr}}) {
next if exists $args->{$k};
$args->{$k} = $v;
}
}
my $f = CGI::FormBuilder::Field->new($self, $args);
debug 1, "created field $f";
return $f; # already set args above ^^^
}
*fieldset = \&fieldsets;
sub fieldsets {
my $self = shift;
if (@_) {
if (ref($_[0]) eq 'ARRAY') {
$self->{fieldsets} = shift;
} elsif (@_ % 2) {
# search for fieldset and update it, or add it
# can't use optalign because must change in-place
while (@_) {
my($k,$v) = (shift,shift);
for (@{$self->{fieldsets}||=[]}) {
if ($k eq $_->[0]) {
$_->[1] = $v;
undef $k; # catch below
}
}
# not found, so append
if ($k) {
push @{$self->{fieldsets}}, [$k,$v];
}
}
} else {
puke "Invalid usage of \$form->fieldsets(name => 'Label')"
}
}
lib/CGI/FormBuilder.pm view on Meta::CPAN
debug 2, "\$tmplvar{title} = \$self->title";
$tmplvar{title} = $self->title;
debug 2, "\$tmplvar{start} = \$self->start . \$self->statetags . \$self->keepextras";
$tmplvar{start} = $self->start . $self->statetags . $self->keepextras;
debug 2, "\$tmplvar{submit} = \$self->submit";
$tmplvar{submit} = $self->submit;
debug 2, "\$tmplvar{reset} = \$self->reset";
$tmplvar{reset} = $self->reset;
debug 2, "\$tmplvar{end} = \$self->end";
$tmplvar{end} = $self->end;
debug 2, "\$tmplvar{invalid} = \$self->invalid";
$tmplvar{invalid} = $self->invalid;
debug 2, "\$tmplvar{required} = \$self->required";
$tmplvar{required} = $self->required;
my $fieldsets = $self->fieldsets;
for my $key (keys %$fieldsets) {
$tmplvar{fieldset}{$key} = {
name => $key,
label => $fieldsets->{$key},
}
}
$tmplvar{fieldsets} = [ map $tmplvar{fieldset}{$_}, $self->fieldsets ];
debug 2, "\$tmplvar{fields} = [ map \$tmplvar{field}{\$_}, \$self->field ]";
$tmplvar{fields} = [ map $tmplvar{field}{$_}, $self->field ];
return wantarray ? %tmplvar : \%tmplvar;
}
sub render {
local $^W = 0; # -w sucks
my $self = shift;
debug 1, "starting \$form->render(@_)";
# any arguments are used to make permanent changes to the $form
if (@_) {
puke "Odd number of arguments passed into \$form->render()"
unless @_ % 2 == 0;
while (@_) {
my $k = shift;
$self->$k(shift);
}
}
# check for engine type
my $mod;
my $ref = ref $self->{template};
if (! $ref && $self->{template}) {
# "legacy" string filename for HTML::Template; redo format
# modifying $self object is ok because it's compatible
$self->{template} = {
type => 'HTML',
filename => $self->{template},
};
$ref = 'HASH'; # tricky
debug 2, "rewrote 'template' option since found filename";
}
# Get ourselves ready
$self->{prepare} = $self->prepare;
# weaken($self->{prepare});
my $opt;
if ($ref eq 'HASH') {
# must copy to avoid destroying
$opt = { %{ $self->{template} } };
$mod = ucfirst(delete $opt->{type} || 'HTML');
} elsif ($ref eq 'CODE') {
# subroutine wrapper
return &{$self->{template}}($self);
} elsif (UNIVERSAL::can($self->{template}, 'render')) {
# instantiated object
return $self->{template}->render($self);
} elsif ($ref) {
puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ render()";
}
# load user-specified rendering module, or builtin rendering
$mod ||= 'Builtin';
# user can give 'Their::Complete::Module' or an 'IncludedAdapter'
$mod = join '::', __PACKAGE__, 'Template', $mod unless $mod =~ /::/;
debug 1, "loading $mod for 'template' option";
# load module
eval "require $mod";
puke "Bad template engine $mod: $@" if $@;
# create new object
#CGI::FormBuilder::Template::Builtin
my $tmpl = $mod->new($opt);
# Experiemental: Alter tag names as we're rendering, to support
# Ajaxian markup schemes that use their own tags (Backbase, Dojo, etc)
local %CGI::FormBuilder::Util::TAGNAMES;
while (my($k,$v) = each %{$self->{tagnames}}) {
$CGI::FormBuilder::Util::TAGNAMES{$k} = $v;
}
# Call the engine's prepare too, if it exists
# Give it the form object so it can do what it wants
# This will have all of the prepared data in {prepare} anyways
if ($tmpl && UNIVERSAL::can($tmpl, 'prepare')) {
$tmpl->prepare($self);
}
# dispatch to engine, prepend header
debug 1, "returning $tmpl->render($self->{prepare})";
my $ret = $self->header . $tmpl->render($self->{prepare});
#we have a circular reference but we need to kill it after setting up return
weaken($self->{prepare});
return $ret;
}
# These routines should be moved to ::Mail or something since they're rarely used
sub mail () {
# This is a very generic mail handler
my $self = shift;
my $args = arghash(@_);
# Where does the mailer live? Must be sendmail-compatible
my $mailer = undef;
unless ($mailer = $args->{mailer} && -x $mailer) {
for my $sendmail (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/bin/sendmail)) {
if (-x $sendmail) {
$mailer = "$sendmail -t";
last;
}
}
}
unless ($mailer) {
belch "Cannot find a sendmail-compatible mailer; use mailer => '/path/to/mailer'";
return;
}
unless ($args->{to}) {
belch "Missing required 'to' argument; cannot continue without recipient";
return;
}
if ($args->{from}) {
(my $from = $args->{from}) =~ s/"/\\"/g;
$mailer .= qq( -f "$from");
}
debug 1, "opening new mail to $args->{to}";
# untaint
my $oldpath = $ENV{PATH};
$ENV{PATH} = '/usr/bin:/usr/sbin';
open(MAIL, "|$mailer >/dev/null 2>&1") || next;
print MAIL "From: $args->{from}\n";
print MAIL "To: $args->{to}\n";
print MAIL "Cc: $args->{cc}\n" if $args->{cc};
print MAIL "Content-Type: text/plain; charset=\""
. $self->charset . "\"\n" if $self->charset;
print MAIL "Subject: $args->{subject}\n\n";
print MAIL "$args->{text}\n";
# retaint
$ENV{PATH} = $oldpath;
return close(MAIL);
}
sub mailconfirm () {
# This prints out a very generic message. This should probably
# be much better, but I suspect very few if any people will use
# this method. If you do, let me know and maybe I'll work on it.
my $self = shift;
( run in 2.019 seconds using v1.01-cache-2.11-cpan-98e64b0badf )