no warnings 'uninitialized';
our $VERSION = '3.20';
our $AUTOLOAD;
our %DEFAULT = (
sticky => 1,
method => 'get',
submit => 1,
reset => 0,
header => 0,
body => { },
text => '',
table => { },
tr => { },
th => { },
td => { },
div => { },
jsname => 'validate',
jsprefix => 'fb_',
sessionidname => '_sessionid',
submittedname => '_submitted',
pagename => '_page',
template => '',
debug => 0,
javascript => 'auto',
cookies => 1,
cleanopts => 1,
render => 'render',
smartness => 1,
selectname => 1,
selectnum => 5,
stylesheet => 0,
styleclass => 'fb',
tagnames => { },
formname => '_form',
submitname => '_submit',
resetname => '_reset',
bodyname => '_body',
tabname => '_tab',
rowname => '_row',
labelname => '_label',
fieldname => '_field',
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"
EOD
);
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;
my $self = shift;
my %opt;
if (@_ == 1) {
%opt = UNIVERSAL::isa($_[0], 'HASH')
? %{ $_[0] }
: ( source => shift() );
} else {
%opt = arghash(@_);
}
if (my $src = delete $opt{source}) {
my $mod;
my $sopt;
my $ref = ref $src;
unless ($ref) {
$src = {
type => 'File',
source => $src,
($opt{c} && $opt{c}->action)
? (caller => $opt{c}->action->class) : ()
};
$ref = 'HASH';
debug 2, "rewrote 'source' option since found filename";
}
debug 1, "creating form from source ", $ref || $src;
if ($ref eq 'HASH') {
$mod = delete $src->{type} || 'File';
$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') {
$sopt = &{$src->{source}}($self);
} elsif (UNIVERSAL::can($src->{source}, 'parse')) {
$sopt = $src->{source}->parse($self);
} elsif ($ref) {
puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ parse()";
}
while (my($k,$v) = each %$sopt) {
$opt{$k} = $v unless exists $opt{$k};
}
}
if (ref $self) {
debug 1, "rewriting existing FormBuilder object";
while (my($k,$v) = each %opt) {
$self->{$k} = $v;
}
} else {
debug 1, "constructing new FormBuilder object";
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;
}
unless (ref $self->{params}) {
$CGI::USE_PARAM_SEMICOLONS = 0;
$self->{params} = CGI->new($self->{params});
}
$CGI::FormBuilder::Util::DEBUG = $ENV{FORMBUILDER_DEBUG} || $self->{debug};
if (lc($self->{messages}) eq 'auto') {
my $lang = $self->{messages};
if (UNIVERSAL::isa($self->{params}, 'CGI')) {
$lang = $self->{params}->http('Accept-Language');
} elsif (UNIVERSAL::isa($self->{params}, 'Apache')) {
$lang = $self->{params}->headers_in->get('Accept-Language');
} elsif (UNIVERSAL::isa($self->{params}, 'Catalyst::Request')) {
$lang = $self->{params}->headers->header('Accept-Language');
} else {
$lang = $ENV{HTTP_ACCEPT_LANGUAGE}
|| $ENV{LC_MESSAGES} || $ENV{LC_ALL} || $ENV{LANG};
}
$lang ||= 'default';
$self->{messages} = CGI::FormBuilder::Messages->new(":$lang");
} else {
$self->{messages} = CGI::FormBuilder::Messages->new($self->{messages});
}
if ($self->{fields}) {
debug 1, "creating fields list";
my $ref = ref $self->{fields};
if ($ref && $ref eq 'HASH') {
debug 2, "got fields list from HASH";
while(my($k,$v) = each %{$self->{fields}}) {
$k = lc $k;
$self->{values}{$k} = [ autodata $v ];
}
$self->{fields} = [ sort keys %{$self->{fields}} ];
} else {
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";
$self->{required} = $self->{validate}{profiles}{fb}{required};
} else {
if (ref $self->{required}) {
} elsif ($self->{required}) {
if ($self->{required} eq 'NONE') {
delete $self->{required};
}
elsif ($self->{required} eq 'ALL') {
$self->{required} = [ @{$self->{fields}} ];
}
elsif ($self->{required}) {
$self->{required} = { $self->{required} => 1 };
}
} elsif ($self->{validate}) {
$self->{required} = [ keys %{$self->{validate}} ];
}
}
my @ftmp = ();
for (@{$self->{fields}}) {
my %fprop = %{$self->{fieldopts}{$_} || {}};
if (ref $_ =~ /^CGI::FormBuilder::Field/i) {
$_->field(%fprop);
} else {
$fprop{name} = "$_";
$_ = $self->new_field(%fprop);
weaken($_->{_form});
}
debug 2, "push \@(@ftmp), $_";
weaken($self->{fieldrefs}{"$_"} = $_);
push @ftmp, $_;
}
$self->{fields} = \@ftmp;
$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;
my $self = shift;
debug 2, "called \$form->field(@_)";
return $self->new(fields => $_[0])
if ref $_[0] eq 'ARRAY' && @_ == 1;
my $name = (@_ % 2 == 0) ? '' : shift();
my $args = arghash(@_);
$args->{name} ||= $name;
unless ($args->{name}) {
if (wantarray) {
for my $redo (grep { $_->order } @{$self->{fields}}) {
next if $redo->order eq 'auto';
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);
}
}
debug 2, "reorder: moving $redo to $redo->{order}";
if ($redo->order <= 1) {
unshift @{$self->{fields}}, $redo;
} elsif ($redo->order >= @{$self->{fields}}) {
push @{$self->{fields}}, $redo;
} else {
splice(@{$self->{fields}}, $redo->order - 1, 0, $redo);
}
delete $redo->{order};
}
debug 2, "return (@{$self->{fields}})";
return @{$self->{fields}};
} else {
return { map { $_ => scalar($_->value) } @{$self->{fields}} };
}
}
debug 2, "searching fields for '$args->{name}'";
if ($args->{delete}) {
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};
return $f->field(%$args);
}
return unless keys %$args > 1;
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})";
while (my($from,$to) = each %REARRANGE) {
next unless exists $self->{$from};
next if defined $args->{$to};
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}) {
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;
}
*fieldset = \&fieldsets;
sub fieldsets {
my $self = shift;
if (@_) {
if (ref($_[0]) eq 'ARRAY') {
$self->{fieldsets} = shift;
} elsif (@_ % 2) {
while (@_) {
my($k,$v) = (shift,shift);
for (@{$self->{fieldsets}||=[]}) {
if ($k eq $_->[0]) {
$_->[1] = $v;
undef $k;
}
}
if ($k) {
push @{$self->{fieldsets}}, [$k,$v];
}
}
} else {
puke "Invalid usage of \$form->fieldsets(name => 'Label')"
}
}
my(%legends, @sets);
for (optalign($self->{fieldsets})) {
my($o,$n) = optval($_);
next if exists $legends{$o};
push @sets, $o;
debug 2, "added fieldset $o (legend=$n) to \@sets";
$legends{$o} = $n;
}
for ($self->field) {
next unless my $o = $_->fieldset;
next if exists $legends{$o};
push @sets, $o;
debug 2, "added fieldset $o (legend=undef) to \@sets";
$legends{$o} = $o;
}
return wantarray ? @sets : \%legends;
}
sub fieldlist {
my $self = shift;
my @fields = @_ ? @_ : $self->field;
my(%saw, @ret);
for my $set ($self->fieldsets) {
for (@fields) {
next if $saw{$_};
if ($_->fieldset && $_->fieldset eq $set) {
push @ret, $_;
debug 2, "added field $_ to field order (fieldset=$set)";
$saw{$_} = 1;
}
}
}
for (@fields) {
debug 2, "appended non-fieldset field $_ to form";
push @ret, $_ unless $saw{$_};
}
return wantarray ? @ret : \@ret;
}
sub header {
my $self = shift;
$self->{header} = shift if @_;
return unless $self->{header};
my %head;
if ($self->{cookies} && defined(my $sid = $self->sessionid)) {
$head{'-cookie'} = CGI::Cookie->new(-name => $self->{sessionidname},
-value => $sid);
}
$head{'-charset'} = $self->charset;
return "Content-type: text/html\n\n" if $::TESTING;
return CGI::header(%head);
}
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 '<html>' if $::TESTING;
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;
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};
my $ret;
my $ref = ref $self->{font} || '';
if (! $ref) {
$ret = { face => $self->{font} };
} elsif ($ref eq 'ARRAY') {
$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});
$self->disabled ? $attr{disabled} = 'disabled' : delete $attr{disabled};
$attr{class} ||= $self->class($self->formname);
belch "You should really call \$form->script BEFORE \$form->start"
unless $self->{_didscript};
belch "Old-style 'onSubmit' action found - should be 'onsubmit'"
if $attr{onSubmit};
return $self->version . htmltag('form', %attr);
}
sub end {
return '</form>';
}
sub disabled {
my $self = shift;
$self->{disabled} = shift if @_;
return $self->{disabled} ? 'disabled' : undef;
}
sub body {
my $self = shift;
$self->{body} = shift if @_;
$self->{body}{bgcolor} ||= 'white' unless $self->{stylesheet};
return htmltag('body', $self->{body});
}
sub class {
my $self = shift;
return undef unless $self->{stylesheet};
return join '', $self->{styleclass}, @_;
}
sub idname {
my $self = shift;
$self->{id} = $self->{name}
unless defined $self->{id};
return undef unless $self->{id};
return join '', $self->{id}, @_;
}
sub table {
my $self = shift;
$self->{table} = shift if @_ == 1;
return unless $self->{table};
$self->{table} = $DEFAULT{table} if $self->{table} == 1;
my $attr = $self->{table};
if (@_) {
my %temp = %$attr;
while (my $k = shift) {
$temp{$k} = shift;
}
$attr = \%temp;
}
return unless $self->{table};
$attr->{class} ||= $self->class;
return htmltag('table', $attr);
}
sub tr {
my $self = shift;
$self->{tr} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
my $attr = $self->{tr};
if (@_) {
my %temp = %$attr;
while (my $k = shift) {
$temp{$k} = shift;
}
$attr = \%temp;
}
if ($self->{stylesheet}) {
} else {
$attr->{valign} ||= 'top';
}
return htmltag('tr', $attr);
}
sub th {
my $self = shift;
$self->{th} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
my $attr = $self->{th};
if (@_) {
my %temp = %$attr;
while (my $k = shift) {
$temp{$k} = shift;
}
$attr = \%temp;
}
if ($self->{stylesheet}) {
} else {
$attr->{align} ||= $self->{lalign} || 'left';
}
return htmltag('th', $attr);
}
sub td {
my $self = shift;
$self->{td} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
my $attr = $self->{td};
if (@_) {
my %temp = %$attr;
while (my $k = shift) {
$temp{$k} = shift;
}
$attr = \%temp;
}
return htmltag('td', $attr);
}
sub div {
my $self = shift;
$self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
my $attr = $self->{div};
if (@_) {
my %temp = %$attr;
while (my $k = shift) {
$temp{$k} = shift;
}
$attr = \%temp;
}
return htmltag('div', $attr);
}
sub submitted {
my $self = shift;
my $smnam = shift || $self->submittedname;
my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
if ($self->{params}->param($smtag)) {
my $sr = $self->{params}->param($self->submitname) || '0E0';
debug 2, "\$form->submitted() is true, returning $sr";
return $sr;
}
return 0;
}
sub query_string {
my $self = shift;
my @qstr = ();
for my $f ($self->fields, $self->keepextras) {
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;
}
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}) {
%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 = ();
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');
if (defined(my $sid = $self->sessionid)) {
push @html, htmltag('input', name => $self->{sessionidname},
type => 'hidden', value => $sid);
}
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;
my $self = shift;
my @keep = ();
my @html = ();
$self->{keepextras} = shift if @_;
return '' unless $self->{keepextras};
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 {
for my $p ($self->{params}->param()) {
next if $p =~ /^_/ || $self->{fieldrefs}{$p};
push @keep, $p;
}
}
return @keep if wantarray;
for my $p (@keep) {
my @values = $self->{params}->can('multi_param') ? $self->{params}->multi_param($p) : $self->{params}->param($p);
for my $v (@values) {
debug 1, "keepextras: saving hidden param $p = $v";
push @html, htmltag('input', name => $p, type => 'hidden', value => $v);
}
}
return join "\n", @html;
}
sub javascript {
my $self = shift;
$self->{javascript} = shift if @_;
if (lc($self->{javascript}) eq 'auto') {
if (exists $ENV{HTTP_USER_AGENT}
&& $ENV{HTTP_USER_AGENT} =~ /lynx|mosaic/i)
{
return 0;
}
return 1;
}
return $self->{javascript} if exists $self->{javascript};
return 1;
}
sub jsname {
my $self = shift;
return $self->{name}
? (join '_', $self->{jsname}, tovar($self->{name}))
: $self->{jsname};
}
sub script {
my $self = shift;
my $jsname = $self->jsname || puke "Must have 'jsname' if 'javascript' is on";
my $jspre = $self->jsprefix || '';
$self->{_didscript} = 1;
return '' unless $self->javascript;
my $jsmisc = $self->script_growable
. $self->script_otherbox;
my $jsfunc = $self->jsfunc || '';
my $jshead = $self->jshead || '';
unless (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
for ($self->field) {
$jsfunc .= $_->script;
}
}
return '' unless $jsfunc || $jsmisc || $jshead;
if ($jsfunc) {
$jsfunc = <<EOJ1 . $jsfunc . <<EOJ2;
function $jsname (form) {
var alertstr = '';
var invalid = 0;
var invalid_fields = new Array();
EOJ1
if (invalid > 0 || alertstr != '') {
EOJ2
if (my $jse = $self->jserror) {
$jsfunc .= " return $jse(form, invalid, alertstr, invalid_fields);\n";
} else {
(my $alertstart = $self->{messages}->js_invalid_start) =~ s/%s/'+invalid+'/g;
(my $alertend = $self->{messages}->js_invalid_end) =~ s/%s/'+invalid+'/g;
$jsfunc .= <<EOJS;
if (! invalid) invalid = 'The following'; // catch for programmer error
alert('$alertstart'+'\\n\\n'
+alertstr+'\\n'+'$alertend');
return false;
EOJS
}
if (my $jss = $self->jsvalid) {
$jsfunc .= " }\n return $jss(form);\n}\n";
} else {
$jsfunc .= " }\n return true; // all checked ok\n}\n";
}
$self->{onsubmit} ||= "return $jsname(this);";
}
return '<script type="text/javascript">'
. "<!-- hide from old browsers\n"
. $jshead . $jsmisc . $jsfunc
. "//-->\n</script>";
}
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 .= <<EOJS;
var ${jspre}counter = new Object; // for assigning unique ids; keyed by field name
var ${jspre}limit = new Object; // for limiting the size of growable fields
function ${jspre}grow (baseID) {
// inititalize the counter for this ID
if (isNaN(${jspre}counter[baseID])) ${jspre}counter[baseID] = 1;
// don't go past the growth limit for this field
if (${jspre}counter[baseID] >= ${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
for (@growable) {
my $count = scalar(my @v = $_->values);
$jsmisc .= "${jspre}counter['$_'] = $count;\n" if $count > 0;
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 .= <<EOJS;
// turn on/off any "other"fields
function ${jspre}other_on (othername) {
var box = document.getElementById(othername);
box.removeAttribute('disabled');
}
function ${jspre}other_off (othername) {
var box = document.getElementById(othername);
box.setAttribute('disabled', 'disabled');
}
EOJS
return $jsmisc;
}
sub noscript {
my $self = shift;
puke "No args allowed for \$form->noscript" if @_;
return '' unless $self->javascript;
return '<noscript>' . $self->invalid_tag($self->{messages}->js_noscript) . '</noscript>';
}
sub submits {
local $^W = 0;
my $self = shift;
my @submit = ();
my $sn = $self->{submitname};
my $sc = $self->class($self->{buttonname});
if (ref $self->{submit} eq 'ARRAY') {
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" : '';
push @submit, { type => 'submit',
id => "$self->{name}$sn$si",
class => $sc,
name => $sn,
value => $subval, @oncl };
$i++;
}
} else {
my $subval = $self->{submit} eq 1 ? $self->{messages}->form_submit_default
: $self->{submit};
push @submit, { type => 'submit',
id => "$self->{name}$sn",
class => $sc,
name => $sn,
value => $subval };
}
return wantarray ? @submit : [ map { htmltag('input', $_) } @submit ];
}
sub submit {
my $self = shift;
$self->{submit} = shift if @_;
return '' if ! $self->{submit} || $self->static || $self->disabled;
return join '', map { htmltag('input', $_) } $self->submits(@_);
}
sub reset {
local $^W = 0;
my $self = shift;
$self->{reset} = shift if @_;
return '' if ! $self->{reset} || $self->static || $self->disabled;
my $sc = $self->class($self->{buttonname});
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 @_;
my $req = 0;
my $inv = 0;
for ($self->fields) {
$req++ if $_->required;
$inv++ if $_->invalid;
}
unless ($self->static || $self->disabled) {
return $self->{text} .'<p>'. sprintf($self->{messages}->form_invalid_text,
$inv,
$self->invalid_tag).'</p>' if $inv;
if ($req) {
my $form_required_text = $self->{messages}->form_required_text;
$form_required_text = sprintf($form_required_text, $self->required_tag)
if $form_required_text =~ /%/;
return $self->{text} ."<p>$form_required_text</p>";
}
}
return $self->{text};
}
sub invalid_tag {
my $self = shift;
my $label = shift || '';
my @tags = $self->{stylesheet}
? (qq(<span class="$self->{styleclass}_invalid">), '</span>')
: ('<font color="#cc0000"><b>', '</b></font>');
return wantarray ? @tags : join $label, @tags;
}
sub required_tag {
my $self = shift;
my $label = shift || '';
my @tags = $self->{stylesheet}
? (qq(<span class="$self->{styleclass}_required">), '</span>')
: ('<b>', '</b>');
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 {
my $hr = $self->{tmplvar} || {};
return wantarray ? %$hr : $hr;
}
}
sub version {
return '' if $::TESTING;
if (ref $_[0]) {
return "\n<!-- Generated by CGI::FormBuilder v$VERSION available from www.formbuilder.org -->\n";
} else {
return "CGI::FormBuilder v$VERSION by Nate Wiger. All Rights Reserved.\n";
}
}
sub values {
my $self = shift;
if (@_) {
$self->{values} = arghash(@_);
my %val = ();
my @val = ();
local $" = ',';
debug 1, "\$form->{values} = ($self->{values})";
if (UNIVERSAL::isa($self->{values}, 'CODE')) {
for my $key (&{$self->{values}}) {
$val{$key} = [ &{$self->{values}}($key) ];
debug 2, "setting values from \\&code(): $key = (@{$val{$key}})";
}
} elsif (UNIVERSAL::isa($self->{values}, 'HASH')) {
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')) {
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";
}
for ($self->fields) {
my $v = $val{lc($_)} || shift @val;
$_->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 = ();
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 = ();
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};
}
sub validate {
my $self = shift;
if (@_) {
if (ref $_[0]) {
$self->{validate} = shift;
} elsif (@_ % 2 == 0) {
$self->{validate} = { @_ };
} elsif (@_ > 1) {
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";
$self->{dfv_results} = $self->{validate}->check($self, $profile_name);
my @invalid_fields = (
$self->{dfv_results}->invalid,
$self->{dfv_results}->missing,
);
for my $field_name (@invalid_fields) {
$self->field(
name => $field_name,
invalid => 1,
);
}
$ok = 0 if @invalid_fields > 0;
} else {
debug 1, "validating all fields via \$form->validate";
for ($self->fields) {
$ok = 0 unless $_->validate;
}
}
debug 1, "validation done, ok = $ok (should be 1)";
return $ok;
}
sub confirm {
my $self = shift;
my $date = $::TESTING ? 'LOCALTIME' : localtime();
$self->{text} ||= sprintf $self->{messages}->form_confirm_text, $date;
$self->{static} = 1;
return $self->render(@_);
}
sub prepare {
my $self = shift;
debug 1, "Calling \$form->prepare(@_)";
my %tmplvar = $self->tmpl_param;
for my $field ($self->field) {
my @value = $field->tag_value;
$tmplvar{field}{"$field"} = {
%$field,
field => $field->tag,
value => $value[0],
values => \@value,
options => [$field->options],
label => $field->label,
type => $field->type,
comment => $field->comment,
nameopts => $field->nameopts,
cleanopts => $field->cleanopts,
};
$tmplvar{field}{"$field"}{error} = $field->error;
}
debug 2, "\$tmplvar{jshead} = \$self->script";
$tmplvar{jshead} = $self->script;
debug 2, "\$tmplvar{title} = \$self->title";
$tmplvar{title} = $self->title;
debug 2, "\$tmplvar{start} = \$self->start . \$self->statetags . \$self->keepextras";
$tmplvar{start} = $self->start . $self->statetags . $self->keepextras;
debug 2, "\$tmplvar{submit} = \$self->submit";
$tmplvar{submit} = $self->submit;
debug 2, "\$tmplvar{reset} = \$self->reset";
$tmplvar{reset} = $self->reset;
debug 2, "\$tmplvar{end} = \$self->end";
$tmplvar{end} = $self->end;
debug 2, "\$tmplvar{invalid} = \$self->invalid";
$tmplvar{invalid} = $self->invalid;
debug 2, "\$tmplvar{required} = \$self->required";
$tmplvar{required} = $self->required;
my $fieldsets = $self->fieldsets;
for my $key (keys %$fieldsets) {
$tmplvar{fieldset}{$key} = {
name => $key,
label => $fieldsets->{$key},
}
}
$tmplvar{fieldsets} = [ map $tmplvar{fieldset}{$_}, $self->fieldsets ];
debug 2, "\$tmplvar{fields} = [ map \$tmplvar{field}{\$_}, \$self->field ]";
$tmplvar{fields} = [ map $tmplvar{field}{$_}, $self->field ];
return wantarray ? %tmplvar : \%tmplvar;
}
sub render {
local $^W = 0;
my $self = shift;
debug 1, "starting \$form->render(@_)";
if (@_) {
puke "Odd number of arguments passed into \$form->render()"
unless @_ % 2 == 0;
while (@_) {
my $k = shift;
$self->$k(shift);
}
}
my $mod;
my $ref = ref $self->{template};
if (! $ref && $self->{template}) {
$self->{template} = {
type => 'HTML',
filename => $self->{template},
};
$ref = 'HASH';
debug 2, "rewrote 'template' option since found filename";
}
$self->{prepare} = $self->prepare;
my $opt;
if ($ref eq 'HASH') {
$opt = { %{ $self->{template} } };
$mod = ucfirst(delete $opt->{type} || 'HTML');
} elsif ($ref eq 'CODE') {
return &{$self->{template}}($self);
} elsif (UNIVERSAL::can($self->{template}, 'render')) {
return $self->{template}->render($self);
} elsif ($ref) {
puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ render()";
}
$mod ||= 'Builtin';
$mod = join '::', __PACKAGE__, 'Template', $mod unless $mod =~ /::/;
debug 1, "loading $mod for 'template' option";
eval "require $mod";
puke "Bad template engine $mod: $@" if $@;
my $tmpl = $mod->new($opt);
local %CGI::FormBuilder::Util::TAGNAMES;
while (my($k,$v) = each %{$self->{tagnames}}) {
$CGI::FormBuilder::Util::TAGNAMES{$k} = $v;
}
if ($tmpl && UNIVERSAL::can($tmpl, 'prepare')) {
$tmpl->prepare($self);
}
debug 1, "returning $tmpl->render($self->{prepare})";
my $ret = $self->header . $tmpl->render($self->{prepare});
weaken($self->{prepare});
return $ret;
}
sub mail () {
my $self = shift;
my $args = arghash(@_);
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}";
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";
$ENV{PATH} = $oldpath;
return close(MAIL);
}
sub mailconfirm () {
my $self = shift;
my $to = shift unless (@_ > 1);
my $args = arghash(@_);
return unless $args->{to} ||= $to;
$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 () {
my $self = shift;
my $args = arghash(@_);
if (exists $args->{plugin}) {
my $lib = "CGI::FormBuilder::Mail::$args->{plugin}";
eval "use $lib";
puke "Cannot use mailresults() plugin '$lib': $@" if $@;
eval {
my $plugin = $lib->new( form => $self, %$args );
$plugin->mailresults();
};
puke "Could not mailresults() with plugin '$lib': $@" if $@;
return;
}
my $delim = $args->{delimiter} || ': ';
my $join = $args->{joiner} || $";
my $sep = $args->{separator} || "\n";
$args->{subject} ||= sprintf $self->{messages}->mail_results_subject, $self->title;
debug 1, "mailresults() called, subject = '$args->{subject}'";
if ($args->{skip}) {
if ($args->{skip} =~ m
($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 }
sub AUTOLOAD {
local $^W = 0;
my $self = shift;
my($name) = $AUTOLOAD =~ /.*::(.+)/;
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}) {
for ($self->fields) {
my $tval = rearrange($self->{$name}, "$_");
$_->$name($tval);
}
}
}
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;