File Coverage

lib/CGI/FormBuilder.pm
Criterion Covered Total %
statement 557 786 70.8
branch 262 442 59.2
condition 94 190 49.4
subroutine 56 68 82.3
pod 36 58 62.0
total 1005 1544 65.0


line stmt bran cond sub pod time code
1              
2             ###########################################################################
3             # Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved.
4             # Please visit http://formbuilder.org for tutorials, support, and examples.
5             ###########################################################################
6              
7             # Note: Documentation has grown so massive it is now in FormBuilder.pod
8              
9             package CGI::FormBuilder;
10              
11 11     11   76975 use Carp;
  11         17  
  11         511  
12 11     11   42 use strict;
  11         11  
  11         171  
13 11     11   30 use warnings;
  11         12  
  11         218  
14 11     11   30 no warnings 'uninitialized';
  11         8  
  11         305  
15 11     11   34 use Scalar::Util qw(weaken);
  11         8  
  11         652  
16              
17 11     11   3720 use CGI::FormBuilder::Util;
  11         16  
  11         955  
18 11     11   4624 use CGI::FormBuilder::Field;
  11         17  
  11         328  
19 11     11   3944 use CGI::FormBuilder::Messages;
  11         15  
  11         84687  
20              
21             our $VERSION = '3.10';
22              
23             our $AUTOLOAD;
24              
25             # Default options for FormBuilder
26             our %DEFAULT = (
27             sticky => 1,
28             method => 'get',
29             submit => 1,
30             reset => 0,
31             header => 0,
32             body => { },
33             text => '',
34             table => { },
35             tr => { },
36             th => { },
37             td => { },
38             div => { },
39             jsname => 'validate',
40             jsprefix => 'fb_', # prefix for JS tags
41             sessionidname => '_sessionid',
42             submittedname => '_submitted',
43             pagename => '_page',
44             template => '', # default template
45             debug => 0, # can be 1 or 2
46             javascript => 'auto', # 0, 1, or 'auto'
47             cookies => 1,
48             cleanopts => 1,
49             render => 'render', # render sub name
50             smartness => 1, # can be 1 or 2
51             selectname => 1, # include -select-?
52             selectnum => 5,
53             stylesheet => 0, # use stylesheet stuff?
54             styleclass => 'fb', # style class to use
55             # For translating tag names (experimental)
56             tagnames => { },
57             # I don't see any reason why these are variables
58             formname => '_form',
59             submitname => '_submit',
60             resetname => '_reset',
61             bodyname => '_body',
62             tabname => '_tab',
63             rowname => '_row',
64             labelname => '_label',
65             fieldname => '_field', # equiv of
66             buttonname => '_button',
67             errorname => '_error',
68             othername => '_other',
69             growname => '_grow',
70             statename => '_state',
71             extraname => '_extra',
72             dtd => <<'EOD', # modified from CGI.pm
73            
74            
75             PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
76             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
77            
78             EOD
79             );
80              
81             # Which options to rearrange from new() into field()
82             our %REARRANGE = qw(
83             options options
84             optgroups optgroups
85             labels label
86             validate validate
87             required required
88             selectname selectname
89             selectnum selectnum
90             sortopts sortopts
91             nameopts nameopts
92             cleanopts cleanopts
93             sticky sticky
94             disabled disabled
95             columns columns
96             );
97              
98             *redo = \&new;
99             sub new {
100 135     135 1 3383 local $^W = 0; # -w sucks
101 135         159 my $self = shift;
102              
103             # A single arg is a source; others are opt => val pairs
104 135         138 my %opt;
105 135 100       289 if (@_ == 1) {
106             %opt = UNIVERSAL::isa($_[0], 'HASH')
107 3 50       8 ? %{ $_[0] }
  3         25  
108             : ( source => shift() );
109             } else {
110 132         347 %opt = arghash(@_);
111             }
112              
113             # Pre-check for an external source
114 135 100       396 if (my $src = delete $opt{source}) {
115              
116             # check for engine type
117 23         28 my $mod;
118             my $sopt; # opts returned from parsing
119 23         41 my $ref = ref $src;
120 23 50       52 unless ($ref) {
121             # string filename; redo format (ala $self->{template})
122             $src = {
123             type => 'File',
124             source => $src,
125             # pass catalyst class for \&validate refs
126             ($opt{c} && $opt{c}->action)
127 0 0 0     0 ? (caller => $opt{c}->action->class) : ()
128             };
129 0         0 $ref = 'HASH'; # tricky
130 0         0 debug 2, "rewrote 'source' option since found filename";
131             }
132 23   33     88 debug 1, "creating form from source ", $ref || $src;
133              
134 23 50       56 if ($ref eq 'HASH') {
    0          
    0          
    0          
135             # grab module
136 23   100     68 $mod = delete $src->{type} || 'File';
137              
138             # user can give 'Their::Complete::Module' or an 'IncludedTemplate'
139 23 50       116 $mod = join '::', __PACKAGE__, 'Source', $mod unless $mod =~ /::/;
140 23         82 debug 1, "loading $mod for 'source' option";
141              
142 23         1610 eval "require $mod";
143 23 50       87 puke "Bad source module $mod: $@" if $@;
144              
145 23         125 my $sob = $mod->new(%$src);
146 23         77 $sopt = $sob->parse;
147             } elsif ($ref eq 'CODE') {
148             # subroutine wrapper
149 0         0 $sopt = &{$src->{source}}($self);
  0         0  
150             } elsif (UNIVERSAL::can($src->{source}, 'parse')) {
151             # instantiated object
152 0         0 $sopt = $src->{source}->parse($self);
153             } elsif ($ref) {
154 0         0 puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ parse()";
155             }
156              
157             # per-instance variables win
158 23         96 while (my($k,$v) = each %$sopt) {
159 135 50       414 $opt{$k} = $v unless exists $opt{$k};
160             }
161             }
162              
163 135 100       198 if (ref $self) {
164             # cloned/original object
165 1         4 debug 1, "rewriting existing FormBuilder object";
166 1         4 while (my($k,$v) = each %opt) {
167 1         3 $self->{$k} = $v;
168             }
169             } else {
170 134         300 debug 1, "constructing new FormBuilder object";
171             # damn deep copy this is SO damn annoying
172 134         424 while (my($k,$v) = each %DEFAULT) {
173 5896 100       6587 next if exists $opt{$k};
174 5618 100       6538 if (ref $v eq 'HASH') {
    50          
175 922         2139 $opt{$k} = { %$v };
176             } elsif (ref $v eq 'ARRAY') {
177 0         0 $opt{$k} = [ @$v ];
178             } else {
179 4696         8884 $opt{$k} = $v;
180             }
181             }
182 134         244 $self = bless \%opt, $self;
183             }
184              
185             # Create our CGI object if not present
186 135 100       330 unless (ref $self->{params}) {
187 131         8223 require CGI;
188 131         208730 $CGI::USE_PARAM_SEMICOLONS = 0; # fuck ; in urls
189 131         620 $self->{params} = CGI->new($self->{params});
190             }
191              
192             # XXX not mod_perl safe
193 135   33     69044 $CGI::FormBuilder::Util::DEBUG = $ENV{FORMBUILDER_DEBUG} || $self->{debug};
194              
195             # And a messages delegate if not existent
196             # Handle 'auto' mode by trying to detect from request
197             # Can't do this in ::Messages because it has no CGI knowledge
198 135 100       352 if (lc($self->{messages}) eq 'auto') {
199 2         4 my $lang = $self->{messages};
200             # figure out the messages from our params object
201 2 50       9 if (UNIVERSAL::isa($self->{params}, 'CGI')) {
    0          
    0          
202 2         10 $lang = $self->{params}->http('Accept-Language');
203             } elsif (UNIVERSAL::isa($self->{params}, 'Apache')) {
204 0         0 $lang = $self->{params}->headers_in->get('Accept-Language');
205             } elsif (UNIVERSAL::isa($self->{params}, 'Catalyst::Request')) {
206 0         0 $lang = $self->{params}->headers->header('Accept-Language');
207             } else {
208             # last-ditch effort
209             $lang = $ENV{HTTP_ACCEPT_LANGUAGE}
210 0   0     0 || $ENV{LC_MESSAGES} || $ENV{LC_ALL} || $ENV{LANG};
211             }
212 2   50     60 $lang ||= 'default';
213 2         10 $self->{messages} = CGI::FormBuilder::Messages->new(":$lang");
214             } else {
215             # ref or filename (::Messages will decode)
216 133         599 $self->{messages} = CGI::FormBuilder::Messages->new($self->{messages});
217             }
218              
219             # Initialize form fields (probably a good idea)
220 135 100       328 if ($self->{fields}) {
221 109         220 debug 1, "creating fields list";
222              
223             # check to see if 'fields' is a hash or array ref
224 109         194 my $ref = ref $self->{fields};
225 109 100 100     407 if ($ref && $ref eq 'HASH') {
226             # with a hash ref, we setup keys/values
227 4         9 debug 2, "got fields list from HASH";
228 4         5 while(my($k,$v) = each %{$self->{fields}}) {
  12         30  
229 8         11 $k = lc $k; # must lc to ignore case
230 8         12 $self->{values}{$k} = [ autodata $v ];
231             }
232             # reset main fields to field names
233 4         5 $self->{fields} = [ sort keys %{$self->{fields}} ];
  4         13  
234             } else {
235             # rewrite fields to ensure format
236 105         198 debug 2, "assuming fields list from ARRAY";
237 105         272 $self->{fields} = [ autodata $self->{fields} ];
238             }
239             }
240              
241 135 50       443 if (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
242 0         0 debug 2, "got a Data::FormValidator for validate";
243             # we're being a bit naughty and peeking inside the DFV object
244 0         0 $self->{required} = $self->{validate}{profiles}{fb}{required};
245             } else {
246             # Catch the intersection of required and validate
247 135 100       413 if (ref $self->{required}) {
    100          
    100          
248             # ok, will handle itself automatically below
249             } elsif ($self->{required}) {
250             # catches for required => 'ALL'|'NONE'
251 8 100       31 if ($self->{required} eq 'NONE') {
    100          
    50          
252 1         2 delete $self->{required}; # that's it
253             }
254             elsif ($self->{required} eq 'ALL') {
255 6         7 $self->{required} = [ @{$self->{fields}} ];
  6         16  
256             }
257             elsif ($self->{required}) {
258             # required => 'single_field' catch
259 1         4 $self->{required} = { $self->{required} => 1 };
260             }
261             } elsif ($self->{validate}) {
262             # construct a required list of all validated fields
263 28         27 $self->{required} = [ keys %{$self->{validate}} ];
  28         91  
264             }
265             }
266              
267             # Now, new for the 3.x series, we cycle thru the fields list and
268             # replace it with a list of objects, which stringify to field names
269 135         205 my @ftmp = ();
270 135         111 for (@{$self->{fields}}) {
  135         283  
271 304 100       216 my %fprop = %{$self->{fieldopts}{$_} || {}}; # field properties
  304         1191  
272              
273 304 50       507 if (ref $_ =~ /^CGI::FormBuilder::Field/i) {
274             # is an existing Field object, so update its properties
275 0         0 $_->field(%fprop);
276             } else {
277             # init a new one
278 304         439 $fprop{name} = "$_";
279 304         624 $_ = $self->new_field(%fprop);
280 304         637 weaken($_->{_form});
281             }
282 304         664 debug 2, "push \@(@ftmp), $_";
283 304         603 weaken($self->{fieldrefs}{"$_"} = $_);
284 304         590 push @ftmp, $_;
285             }
286              
287             # stringifiable objects (overwrite previous container)
288 135         216 $self->{fields} = \@ftmp;
289              
290             # setup values
291 135 100       387 $self->values($self->{values}) if $self->{values};
292              
293 135         307 debug 1, "field creation done, list = (@ftmp)";
294              
295 135         425 return $self;
296             }
297              
298             *param = \&field;
299             *params = \&field;
300             *fields = \&field;
301             sub field {
302 1096     1096 1 4161 local $^W = 0; # -w sucks
303 1096         817 my $self = shift;
304 1096         2655 debug 2, "called \$form->field(@_)";
305              
306             # Handle any of:
307             #
308             # $form->field($name)
309             # $form->field(name => $name, arg => 'val')
310             # $form->field(\@newlist);
311             #
312              
313 1096 100 66     2035 return $self->new(fields => $_[0])
314             if ref $_[0] eq 'ARRAY' && @_ == 1;
315              
316 1095 100       1615 my $name = (@_ % 2 == 0) ? '' : shift();
317 1095         1675 my $args = arghash(@_);
318 1095   100     3091 $args->{name} ||= $name;
319              
320             # no name - return ala $cgi->param
321 1095 100       1551 unless ($args->{name}) {
322             # sub fields
323             # return an array of the names in list context, and a
324             # hashref of name/value pairs in a scalar context
325 953 100       999 if (wantarray) {
326             # pre-scan for any "order" arguments, reorder, delete
327 952         672 for my $redo (grep { $_->order } @{$self->{fields}}) {
  2732         7756  
  952         1384  
328 0 0       0 next if $redo->order eq 'auto'; # like javascript
329             # kill existing order
330 0         0 for (my $i=0; $i < @{$self->{fields}}; $i++) {
  0         0  
331 0 0       0 if ($self->{fields}[$i] eq $redo) {
332 0         0 debug 2, "reorder: removed $redo from \$fields->[$i]";
333 0         0 splice(@{$self->{fields}}, $i, 1);
  0         0  
334             }
335             }
336             # put it in its new place
337 0         0 debug 2, "reorder: moving $redo to $redo->{order}";
338 0 0       0 if ($redo->order <= 1) {
    0          
339             # start
340 0         0 unshift @{$self->{fields}}, $redo;
  0         0  
341 0         0 } elsif ($redo->order >= @{$self->{fields}}) {
342             # end
343 0         0 push @{$self->{fields}}, $redo;
  0         0  
344             } else {
345             # middle
346 0         0 splice(@{$self->{fields}}, $redo->order - 1, 0, $redo);
  0         0  
347             }
348             # kill subsequent reorders (unnecessary)
349 0         0 delete $redo->{order};
350             }
351              
352             # list of all field objects
353 952         803 debug 2, "return (@{$self->{fields}})";
  952         2096  
354 952         930 return @{$self->{fields}};
  952         2830  
355             } else {
356             # this only returns a single scalar value for each field
357 1         1 return { map { $_ => scalar($_->value) } @{$self->{fields}} };
  8         14  
  1         3  
358             }
359             }
360              
361             # have name, so redispatch to field member
362 142         334 debug 2, "searching fields for '$args->{name}'";
363 142 50       478 if ($args->{delete}) {
    100          
364             # blow the thing away
365 0         0 delete $self->{fieldrefs}{$args->{name}};
366 0         0 my @tf = grep { $_->name ne $args->{name} } @{$self->{fields}};
  0         0  
  0         0  
367 0         0 $self->{fields} = \@tf;
368 0         0 return;
369             } elsif (my $f = $self->{fieldrefs}{$args->{name}}) {
370 92         113 delete $args->{name}; # segfault??
371 92         263 return $f->field(%$args); # set args, get value back
372             }
373              
374             # non-existent field, and no args, so assume we're checking for it
375 50 100       172 return unless keys %$args > 1;
376              
377             # if we're still in here, we need to init a new field
378             # push it onto our mail fields array, just like initfields()
379 42         94 my $f = $self->new_field(%$args);
380 42         83 weaken($self->{fieldrefs}{"$f"} = $f);
381 42         79 weaken($f->{_form});
382 42         86 weaken($f->{fieldrefs}{"$f"});
383 42         49 push @{$self->{fields}}, $f;
  42         91  
384            
385 42         121 return $f->value;
386             }
387              
388             sub new_field {
389 346     346 0 306 my $self = shift;
390 346         572 my $args = arghash(@_);
391 346 50       597 puke "Need a name for \$form->new_field()" unless exists $args->{name};
392 346         804 debug 1, "called \$form->new_field($args->{name})";
393              
394             # extract our per-field options from rearrange
395 346         788 while (my($from,$to) = each %REARRANGE) {
396 4498 100       7994 next unless exists $self->{$from};
397 1749 100       2100 next if defined $args->{$to}; # manually set
398 1745         2532 my $tval = rearrange($self->{$from}, $args->{name});
399 1745         3156 debug 2, "rearrange: \$args->{$to} = $tval;";
400 1745         4053 $args->{$to} = $tval;
401             }
402              
403             $args->{type} = lc $self->{fieldtype}
404 346 100 66     677 if $self->{fieldtype} && ! exists $args->{type};
405 346 100       465 if ($self->{fieldattr}) { # legacy
406 11         12 while (my($k,$v) = each %{$self->{fieldattr}}) {
  22         59  
407 11 50       22 next if exists $args->{$k};
408 11         19 $args->{$k} = $v;
409             }
410             }
411            
412 346         848 my $f = CGI::FormBuilder::Field->new($self, $args);
413 346         1077 debug 1, "created field $f";
414 346         415 return $f; # already set args above ^^^
415             }
416              
417             *fieldset = \&fieldsets;
418             sub fieldsets {
419 258     258 1 219 my $self = shift;
420 258 50       411 if (@_) {
421 0 0       0 if (ref($_[0]) eq 'ARRAY') {
    0          
422 0         0 $self->{fieldsets} = shift;
423             } elsif (@_ % 2) {
424             # search for fieldset and update it, or add it
425             # can't use optalign because must change in-place
426 0         0 while (@_) {
427 0         0 my($k,$v) = (shift,shift);
428 0   0     0 for (@{$self->{fieldsets}||=[]}) {
  0         0  
429 0 0       0 if ($k eq $_->[0]) {
430 0         0 $_->[1] = $v;
431 0         0 undef $k; # catch below
432             }
433             }
434             # not found, so append
435 0 0       0 if ($k) {
436 0         0 push @{$self->{fieldsets}}, [$k,$v];
  0         0  
437             }
438             }
439             } else {
440 0         0 puke "Invalid usage of \$form->fieldsets(name => 'Label')"
441             }
442             }
443              
444             # We look for all the fieldset definitions, checking the main
445             # form for a "proper" legend ala our other settings. We then
446             # divide up all the fields and group them in fieldsets.
447 258         200 my(%legends, @sets);
448 258         663 for (optalign($self->{fieldsets})) {
449 270         477 my($o,$n) = optval($_);
450 270 50       475 next if exists $legends{$o};
451 270         243 push @sets, $o;
452 270         610 debug 2, "added fieldset $o (legend=$n) to \@sets";
453 270         473 $legends{$o} = $n;
454             }
455              
456             # find *all* our fieldsets, even hidden in fields w/o Human Tags
457 258         459 for ($self->field) {
458 748 100       2034 next unless my $o = $_->fieldset;
459 44 100       74 next if exists $legends{$o};
460 4         6 push @sets, $o;
461 4         8 debug 2, "added fieldset $o (legend=undef) to \@sets";
462 4         5 $legends{$o} = $o; # use fieldset as
463             }
464 258 100       790 return wantarray ? @sets : \%legends;
465             }
466              
467             sub fieldlist {
468 59     59 0 61 my $self = shift;
469 59 50       152 my @fields = @_ ? @_ : $self->field;
470 59         63 my(%saw, @ret);
471 59         121 for my $set ($self->fieldsets) {
472             # reorder fields
473 63         98 for (@fields) {
474 213 100       301 next if $saw{$_};
475 194 100 100     498 if ($_->fieldset && $_->fieldset eq $set) {
476             # if this field is in this fieldset, regroup
477 11         11 push @ret, $_;
478 11         20 debug 2, "added field $_ to field order (fieldset=$set)";
479 11         16 $saw{$_} = 1;
480             }
481             }
482             }
483              
484             # keep non-fieldset fields in order relative
485             # to one another, appending them to the end
486             # of the form
487 59         89 for (@fields) {
488 173         302 debug 2, "appended non-fieldset field $_ to form";
489 173 100       241 push @ret, $_ unless $saw{$_};
490             }
491              
492 59 50       215 return wantarray ? @ret : \@ret;
493             }
494              
495             sub header {
496 123     123 1 392 my $self = shift;
497 123 50       196 $self->{header} = shift if @_;
498 123 100       381 return unless $self->{header};
499 29         32 my %head;
500 29 100 66     107 if ($self->{cookies} && defined(my $sid = $self->sessionid)) {
501 3         19 require CGI::Cookie;
502             $head{'-cookie'} = CGI::Cookie->new(-name => $self->{sessionidname},
503 3         23 -value => $sid);
504             }
505             # Set the charset for i18n
506 29         928 $head{'-charset'} = $self->charset;
507              
508             # Forcibly require - no extra time in normal case, and if
509             # using Apache::Request this needs to be loaded anyways.
510 29 100       126 return "Content-type: text/html\n\n" if $::TESTING;
511 1         8 require CGI;
512 1         9 return CGI::header(%head); # CGI.pm MOD_PERL fanciness
513             }
514              
515             sub charset {
516 32     32 1 266 my $self = shift;
517 32 100       65 $self->{charset} = shift if @_;
518 32   50     219 return $self->{charset} || $self->{messages}->charset || 'iso8859-1';
519             }
520              
521             sub lang {
522 3     3 1 4 my $self = shift;
523 3 50       5 $self->{lang} = shift if @_;
524 3   50     19 return $self->{lang} || $self->{messages}->lang || 'en_US';
525             }
526              
527             sub dtd {
528 15     15 0 19 my $self = shift;
529 15 50       38 $self->{dtd} = shift if @_;
530 15 100       63 return '' if $::TESTING;
531              
532             # replace special chars in dtd by exec'ing subs
533 1         1 my $dtd = $self->{dtd};
534 1         6 $dtd =~ s/\{(\w+)\}/$self->$1/ge;
  3         7  
535 1         3 return $dtd;
536             }
537              
538             sub title {
539 127     127 1 119 my $self = shift;
540 127 50       218 $self->{title} = shift if @_;
541 127 100       463 return $self->{title} if exists $self->{title};
542 6         17 return toname(basename);
543             }
544              
545             *script_name = \&action;
546             sub action {
547 9     9 1 24 local $^W = 0; # -w sucks (still)
548 9         11 my $self = shift;
549 9 50       20 $self->{action} = shift if @_;
550 9 100       27 return $self->{action} if exists $self->{action};
551 8         15 return basename . $ENV{PATH_INFO};
552             }
553              
554             sub font {
555 339     339 1 283 my $self = shift;
556 339 50       438 $self->{font} = shift if @_;
557 339 100       863 return '' unless $self->{font};
558 2 50       10 return '' if $self->{stylesheet}; # kill fonts for style
559              
560             # Catch for allowable hashref or string
561 0         0 my $ret;
562 0   0     0 my $ref = ref $self->{font} || '';
563 0 0       0 if (! $ref) {
    0          
564             # string "arial,helvetica"
565 0         0 $ret = { face => $self->{font} };
566             } elsif ($ref eq 'ARRAY') {
567             # hack for array [arial,helvetica] from conf
568 0         0 $ret = { face => join ',', @{$self->{font}} };
  0         0  
569             } else {
570 0         0 $ret = $self->{font};
571             }
572 0 0       0 return wantarray ? %$ret : htmltag('font', %$ret);
573             }
574              
575             *tag = \&start;
576             sub start {
577 129     129 0 123 my $self = shift;
578 129         1266 my %attr = htmlattr('form', %$self);
579              
580 129   66     483 $attr{action} ||= $self->action;
581 129   33     214 $attr{method} ||= $self->method;
582 129         217 $attr{method} = lc($attr{method}); # xhtml
583 129 100       267 $self->disabled ? $attr{disabled} = 'disabled' : delete $attr{disabled};
584 129   66     686 $attr{class} ||= $self->class($self->formname);
585              
586             # Bleech, there's no better way to do this...?
587             belch "You should really call \$form->script BEFORE \$form->start"
588 129 50       240 unless $self->{_didscript};
589              
590             # A catch for lowercase actions
591             belch "Old-style 'onSubmit' action found - should be 'onsubmit'"
592 129 50       225 if $attr{onSubmit};
593              
594 129         254 return $self->version . htmltag('form', %attr);
595             }
596              
597             sub end {
598 70     70 0 104 return '';
599             }
600              
601             # Need to wrap this or else AUTOLOAD whines (OURATTR missing)
602             sub disabled {
603 690     690 0 550 my $self = shift;
604 690 50       1015 $self->{disabled} = shift if @_;
605 690 100       1949 return $self->{disabled} ? 'disabled' : undef;
606             }
607            
608             sub body {
609 14     14 1 21 my $self = shift;
610 14 50       33 $self->{body} = shift if @_;
611 14 100 100     65 $self->{body}{bgcolor} ||= 'white' unless $self->{stylesheet};
612 14         37 return htmltag('body', $self->{body});
613             }
614              
615             sub class {
616 1490     1490 0 1185 my $self = shift;
617 1490 100       3491 return undef unless $self->{stylesheet};
618 307         764 return join '', $self->{styleclass}, @_; # remainder is optional tag
619             }
620              
621             sub idname {
622 752     752 0 629 my $self = shift;
623             $self->{id} = $self->{name}
624 752 100       1230 unless defined $self->{id};
625 752 100       1719 return undef unless $self->{id};
626 184         451 return join '', $self->{id}, @_; # remainder is optional tag
627             }
628              
629             sub table {
630 106     106 1 99 my $self = shift;
631              
632             # single hashref kills everything; a list is temporary
633 106 50       179 $self->{table} = shift if @_ == 1;
634 106 100       214 return unless $self->{table};
635              
636             # set defaults for numeric table => 1
637 104 100       179 $self->{table} = $DEFAULT{table} if $self->{table} == 1;
638              
639 104         95 my $attr = $self->{table};
640 104 100       165 if (@_) {
641             # if still have args, create a temp hash
642 100         198 my %temp = %$attr;
643 100         172 while (my $k = shift) {
644 156         352 $temp{$k} = shift;
645             }
646 100         121 $attr = \%temp;
647             }
648              
649 104 50       159 return unless $self->{table}; # 0 or unset via table(0)
650 104   100     230 $attr->{class} ||= $self->class;
651 104         213 return htmltag('table', $attr);
652             }
653              
654             sub tr {
655 218     218 0 184 my $self = shift;
656              
657             # single hashref kills everything; a list is temporary
658 218 50 33     424 $self->{tr} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
659              
660 218         212 my $attr = $self->{tr};
661 218 50       338 if (@_) {
662             # if still have args, create a temp hash
663 218         332 my %temp = %$attr;
664 218         349 while (my $k = shift) {
665 218         476 $temp{$k} = shift;
666             }
667 218         251 $attr = \%temp;
668             }
669              
670             # reduced formatting
671 218 100       332 if ($self->{stylesheet}) {
672             # extraneous - inherits from
673             #$attr->{class} ||= $self->class($self->{rowname});
674             } else {
675 168   100     503 $attr->{valign} ||= 'top';
676             }
677              
678 218         434 return htmltag('tr', $attr);
679             }
680              
681             sub th {
682 0     0 0 0 my $self = shift;
683              
684             # single hashref kills everything; a list is temporary
685 0 0 0     0 $self->{th} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
686              
687 0         0 my $attr = $self->{th};
688 0 0       0 if (@_) {
689             # if still have args, create a temp hash
690 0         0 my %temp = %$attr;
691 0         0 while (my $k = shift) {
692 0         0 $temp{$k} = shift;
693             }
694 0         0 $attr = \%temp;
695             }
696              
697             # reduced formatting
698 0 0       0 if ($self->{stylesheet}) {
699             # extraneous - inherits from
700             #$attr->{class} ||= $self->class($self->{labelname});
701             } else {
702 0   0     0 $attr->{align} ||= $self->{lalign} || 'left';
      0        
703             }
704              
705 0         0 return htmltag('th', $attr);
706             }
707              
708             sub td {
709 383     383 0 296 my $self = shift;
710              
711             # single hashref kills everything; a list is temporary
712 383 50 33     689 $self->{td} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
713              
714 383         373 my $attr = $self->{td};
715 383 50       607 if (@_) {
716             # if still have args, create a temp hash
717 383         576 my %temp = %$attr;
718 383         582 while (my $k = shift) {
719 863         1659 $temp{$k} = shift;
720             }
721 383         419 $attr = \%temp;
722             }
723              
724             # extraneous - inherits from
725             #$attr->{class} ||= $self->class($self->{fieldname});
726              
727 383         668 return htmltag('td', $attr);
728             }
729              
730             sub div {
731 90     90 0 100 my $self = shift;
732              
733             # single hashref kills everything; a list is temporary
734 90 50 33     193 $self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
735              
736 90         105 my $attr = $self->{div};
737 90 50       156 if (@_) {
738             # if still have args, create a temp hash
739 90         160 my %temp = %$attr;
740 90         162 while (my $k = shift) {
741 172         377 $temp{$k} = shift;
742             }
743 90         116 $attr = \%temp;
744             }
745              
746 90         203 return htmltag('div', $attr);
747             }
748              
749             sub submitted {
750 13     13 1 36 my $self = shift;
751 13   33     65 my $smnam = shift || $self->submittedname; # temp smnam
752 13 100       27 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
753              
754 13 100       33 if ($self->{params}->param($smtag)) {
755             # If we've been submitted, then we return the value of
756             # the submit tag (which allows multiple submission buttons).
757             # Must use an "|| 0E0" or else hitting "Enter" won't cause
758             # $form->submitted to be true (as the button is only sent
759             # across CGI when clicked).
760 11   50     181 my $sr = $self->{params}->param($self->submitname) || '0E0';
761 11         133 debug 2, "\$form->submitted() is true, returning $sr";
762 11         18 return $sr;
763             }
764 2         27 return 0;
765             }
766              
767             # This creates a modified self_url, just including fields (no sessionid, etc)
768             sub query_string {
769 0     0 1 0 my $self = shift;
770 0         0 my @qstr = ();
771 0         0 for my $f ($self->fields, $self->keepextras) {
772             # get all values, but ONLY from CGI
773 0         0 push @qstr, join('=', escapeurl($f), escapeurl($_)) for $self->cgi_param($f);
774             }
775 0         0 return join '&', @qstr;
776             }
777              
778             sub self_url {
779 0     0 1 0 my $self = shift;
780 0         0 return join '?', $self->action, $self->query_string;
781             }
782              
783             # must forcibly return scalar undef for CGI::Session easiness
784             sub sessionid {
785 159     159 1 2716 my $self = shift;
786 159 100       267 $self->{sessionid} = shift if @_;
787 159 100       283 return $self->{sessionid} if $self->{sessionid};
788 153 50       270 return undef unless $self->{sessionidname};
789 153         111 my %cookies;
790 153 50       252 if ($self->{cookies}) {
791 153         5039 require CGI::Cookie;
792 153         14036 %cookies = CGI::Cookie->fetch;
793             }
794 153 50       1549 if (my $cook = $cookies{"$self->{sessionidname}"}) {
795 0         0 return $cook->value;
796             } else {
797 153   50     375 return $self->{params}->param($self->{sessionidname}) || undef;
798             }
799             }
800              
801             sub statetags {
802 129     129 0 124 my $self = shift;
803 129         159 my @html = ();
804              
805             # get _submitted
806 129         406 my $smnam = $self->submittedname;
807 129 100       264 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
808 129         360 my $smval = $self->{params}->param($smnam) + 1;
809 129         1931 push @html, htmltag('input', name => $smtag, value => $smval, type => 'hidden');
810              
811             # and how about _sessionid
812 129 100       281 if (defined(my $sid = $self->sessionid)) {
813             push @html, htmltag('input', name => $self->{sessionidname},
814 2         6 type => 'hidden', value => $sid);
815             }
816              
817             # and what page (hooks for ::Multi)
818 129 100       2111 if (defined $self->{page}) {
819             push @html, htmltag('input', name => $self->pagename,
820 2         12 type => 'hidden', value => $self->{page});
821             }
822              
823 129 50       607 return wantarray ? @html : join "\n", @html;
824             }
825              
826             *keepextra = \&keepextras;
827             sub keepextras {
828 129     129 1 284 local $^W = 0; # -w sucks
829 129         136 my $self = shift;
830 129         170 my @keep = ();
831 129         142 my @html = ();
832              
833             # which ones do they want?
834 129 50       210 $self->{keepextras} = shift if @_;
835 129 100       529 return '' unless $self->{keepextras};
836              
837             # If we set keepextras, then this means that any extra fields that
838             # we've set that are *not* in our fields() will be added to the form
839 10   100     36 my $ref = ref $self->{keepextras} || '';
840 10 100       24 if ($ref eq 'ARRAY') {
    50          
841 4         7 @keep = @{$self->{keepextras}};
  4         11  
842             } elsif ($ref) {
843 0         0 puke "Unsupported data structure type '$ref' passed to 'keepextras' option";
844             } else {
845             # Set to "1", so must go thru all params, skipping
846             # leading underscore fields and form fields
847 6         13 for my $p ($self->{params}->param()) {
848 50 100 66     213 next if $p =~ /^_/ || $self->{fieldrefs}{$p};
849 32         29 push @keep, $p;
850             }
851             }
852              
853             # In array context, we just return names we've resolved
854 10 50       26 return @keep if wantarray;
855              
856             # Make sure to get all values
857 10         15 for my $p (@keep) {
858 40 50       156 my @values = $self->{params}->can('multi_param') ? $self->{params}->multi_param($p) : $self->{params}->param($p);
859 40         728 for my $v (@values) {
860 40         111 debug 1, "keepextras: saving hidden param $p = $v";
861 40         71 push @html, htmltag('input', name => $p, type => 'hidden', value => $v);
862             }
863             }
864 10         56 return join "\n", @html; # wantarray above
865             }
866              
867             sub javascript {
868 165     165 1 140 my $self = shift;
869 165 100       247 $self->{javascript} = shift if @_;
870              
871             # auto-determine javascript setting based on user agent
872 165 100       366 if (lc($self->{javascript}) eq 'auto') {
873 150 50 33     359 if (exists $ENV{HTTP_USER_AGENT}
874             && $ENV{HTTP_USER_AGENT} =~ /lynx|mosaic/i)
875             {
876             # Turn off for old/non-graphical browsers
877 0         0 return 0;
878             }
879 150         321 return 1;
880             }
881 15 50       61 return $self->{javascript} if exists $self->{javascript};
882              
883             # Turn on for all other browsers by default.
884             # I suspect this process should be reversed, only
885             # showing JavaScript on those browsers we know accept
886             # it, but maintaining a full list will result in this
887             # module going out of date and having to be updated.
888 0         0 return 1;
889             }
890              
891             sub jsname {
892 132     132 0 120 my $self = shift;
893             return $self->{name}
894             ? (join '_', $self->{jsname}, tovar($self->{name}))
895 132 100       411 : $self->{jsname};
896             }
897              
898             sub script {
899 132     132 0 142 my $self = shift;
900              
901             # get validate() function name
902 132   33     231 my $jsname = $self->jsname || puke "Must have 'jsname' if 'javascript' is on";
903 132   50     476 my $jspre = $self->jsprefix || '';
904              
905             # "counter"
906 132         212 $self->{_didscript} = 1;
907 132 100       233 return '' unless $self->javascript;
908              
909             # code for misc non-validate functions
910 120         224 my $jsmisc = $self->script_growable # code to grow growable fields, if any
911             . $self->script_otherbox; # code to enable/disable the "other" box
912              
913             # custom user jsfunc option for w/i validate()
914 120   100     421 my $jsfunc = $self->jsfunc || '';
915 120   50     352 my $jshead = $self->jshead || '';
916              
917             # expand per-field validation functions, but
918             # only if we are not using Data::FormValidator
919 120 50       431 unless (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
920 120         204 for ($self->field) {
921 353         812 $jsfunc .= $_->script;
922             }
923             }
924            
925             # skip out if we have nothing useful
926 120 100 100     689 return '' unless $jsfunc || $jsmisc || $jshead;
      66        
927              
928             # prefix with opening code
929 38 100       74 if ($jsfunc) {
930 33         106 $jsfunc = <
931             function $jsname (form) {
932             var alertstr = '';
933             var invalid = 0;
934             var invalid_fields = new Array();
935              
936             EOJ1
937             if (invalid > 0 || alertstr != '') {
938             EOJ2
939              
940             # Check to see if we have our own jserror callback on form failure
941             # if not, then use the builtin one. Aka jsalert
942 33 50       123 if (my $jse = $self->jserror) {
943 0         0 $jsfunc .= " return $jse(form, invalid, alertstr, invalid_fields);\n";
944             } else {
945             # Finally, close our JavaScript if it was opened, wrapping in ";
979             }
980              
981             sub script_growable {
982 120     120 0 117 my $self = shift;
983 120 100       206 return '' unless my @growable = grep { $_->growable } $self->field;
  353         576  
984              
985 2   50     6 my $jspre = $self->jsprefix || '';
986 2         3 my $jsmisc = '';
987              
988 2         8 my $grow = $self->growname;
989 2         19 $jsmisc .= <
990             var ${jspre}counter = new Object; // for assigning unique ids; keyed by field name
991             var ${jspre}limit = new Object; // for limiting the size of growable fields
992             function ${jspre}grow (baseID) {
993             // inititalize the counter for this ID
994             if (isNaN(${jspre}counter[baseID])) ${jspre}counter[baseID] = 1;
995              
996             // don't go past the growth limit for this field
997             if (${jspre}counter[baseID] >= ${jspre}limit[baseID]) return;
998              
999             var base = document.getElementById(baseID + '_' + (${jspre}counter[baseID] - 1));
1000              
1001             // we are inserting after the last field
1002             insertPoint = base.nextSibling;
1003              
1004             // line break
1005             base.parentNode.insertBefore(document.createElement('br'), insertPoint);
1006              
1007             var dup = base.cloneNode(true);
1008              
1009             dup.setAttribute('id', baseID + '_' + ${jspre}counter[baseID]);
1010             base.parentNode.insertBefore(dup, insertPoint);
1011              
1012             // add some padding space between the field and the "add field" button
1013             base.parentNode.insertBefore(document.createTextNode(' '), insertPoint);
1014              
1015             ${jspre}counter[baseID]++;
1016              
1017             // disable the "add field" button if we are at the limit
1018             if (${jspre}counter[baseID] >= ${jspre}limit[baseID]) {
1019             var addButton = document.getElementById('$grow' + '_' + baseID);
1020             addButton.setAttribute('disabled', 'disabled');
1021             }
1022             }
1023              
1024             EOJS
1025              
1026             # initialize growable counters
1027 2         5 for (@growable) {
1028 2         9 my $count = scalar(my @v = $_->values);
1029 2 50       5 $jsmisc .= "${jspre}counter['$_'] = $count;\n" if $count > 0;
1030             # assume that values of growable > 1 provide limits
1031 2         4 my $limit = $_->growable;
1032 2 50 33     10 if ($limit && $limit ne 1) {
1033 0         0 $jsmisc .= "${jspre}limit['$_'] = $limit;\n";
1034             }
1035             }
1036 2         7 return $jsmisc;
1037             }
1038              
1039             sub script_otherbox {
1040 120     120 0 120 my $self = shift;
1041 120 100       169 return '' unless my @otherable = grep { $_->other } $self->field;
  353         601  
1042              
1043 5   50     15 my $jspre = $self->jsprefix || '';
1044 5         8 my $jsmisc = '';
1045            
1046 5         11 $jsmisc .= <
1047             // turn on/off any "other"fields
1048             function ${jspre}other_on (othername) {
1049             var box = document.getElementById(othername);
1050             box.removeAttribute('disabled');
1051             }
1052              
1053             function ${jspre}other_off (othername) {
1054             var box = document.getElementById(othername);
1055             box.setAttribute('disabled', 'disabled');
1056             }
1057              
1058             EOJS
1059              
1060 5         9 return $jsmisc;
1061             }
1062              
1063             sub noscript {
1064 15     15 0 17 my $self = shift;
1065             # no state is kept and no args are allowed
1066 15 50       34 puke "No args allowed for \$form->noscript" if @_;
1067 15 50       26 return '' unless $self->javascript;
1068 15         73 return '';
1069             }
1070              
1071             sub submits {
1072 123     123 0 218 local $^W = 0; # -w sucks
1073 123         111 my $self = shift;
1074              
1075             # handle the submit button(s)
1076             # logic is a little complicated - if set but to a false value,
1077             # then leave off. otherwise use as the value for the tags.
1078 123         141 my @submit = ();
1079 123         150 my $sn = $self->{submitname};
1080 123         225 my $sc = $self->class($self->{buttonname});
1081 123 100       217 if (ref $self->{submit} eq 'ARRAY') {
1082             # multiple buttons + JavaScript - dynamically set the _submit value
1083 17 50       38 my @oncl = $self->javascript
1084             ? (onclick => "this.form.$sn.value = this.value;") : ();
1085 17         24 my $i=1;
1086 17         43 for my $subval (autodata $self->{submit}) {
1087 40 100       76 my $si = $i > 1 ? "_$i" : ''; # number with second one
1088 40         175 push @submit, { type => 'submit',
1089             id => "$self->{name}$sn$si",
1090             class => $sc,
1091             name => $sn,
1092             value => $subval, @oncl };
1093 40         58 $i++;
1094             }
1095             } else {
1096             # show the text on the button
1097             my $subval = $self->{submit} eq 1 ? $self->{messages}->form_submit_default
1098 106 100       518 : $self->{submit};
1099 106         496 push @submit, { type => 'submit',
1100             id => "$self->{name}$sn",
1101             class => $sc,
1102             name => $sn,
1103             value => $subval };
1104             }
1105 123 100       358 return wantarray ? @submit : [ map { htmltag('input', $_) } @submit ];
  3         6  
1106             }
1107              
1108             sub submit {
1109 128     128 1 127 my $self = shift;
1110 128 50       241 $self->{submit} = shift if @_;
1111 128 100 66     604 return '' if ! $self->{submit} || $self->static || $self->disabled;
      100        
1112              
1113             # no newline on buttons regardless of setting
1114 122         306 return join '', map { htmltag('input', $_) } $self->submits(@_);
  143         294  
1115             }
1116              
1117             sub reset {
1118 129     129 1 277 local $^W = 0; # -w sucks
1119 129         134 my $self = shift;
1120 129 50       207 $self->{reset} = shift if @_;
1121 129 50 66     484 return '' if ! $self->{reset} || $self->static || $self->disabled;
      66        
1122 5         11 my $sc = $self->class($self->{buttonname});
1123              
1124             # similar to submit(), but a little simpler ;-)
1125             my $reset = $self->{reset} eq 1 ? $self->{messages}->form_reset_default
1126 5 100       21 : $self->{reset};
1127 5         17 my $rn = $self->resetname;
1128 5         19 return htmltag('input', type => 'reset',
1129             id => "$self->{name}$rn",
1130             class => $sc,
1131             name => $rn,
1132             value => $reset);
1133             }
1134              
1135             sub text {
1136 59     59 1 65 my $self = shift;
1137 59 50       100 $self->{text} = shift if @_;
1138            
1139             # having any required fields changes the leading text
1140 59         55 my $req = 0;
1141 59         58 my $inv = 0;
1142 59         97 for ($self->fields) {
1143 173 100       498 $req++ if $_->required;
1144 173 100       490 $inv++ if $_->invalid; # failed validate()
1145             }
1146              
1147 59 100 100     186 unless ($self->static || $self->disabled) {
1148             # only show either invalid or required text
1149             return $self->{text} .'

'. sprintf($self->{messages}->form_invalid_text,

1150 56 100       111 $inv,
1151             $self->invalid_tag).'

' if $inv;
1152              
1153             return $self->{text} .'

'. sprintf($self->{messages}->form_required_text,

1154 54 100       155 $self->required_tag).'

' if $req;
1155             }
1156 44         112 return $self->{text};
1157             }
1158              
1159             sub invalid_tag {
1160 19     19 0 21 my $self = shift;
1161 19   100     37 my $label = shift || '';
1162             my @tags = $self->{stylesheet}
1163 19 100       69 ? (qq(), '')
1164             : ('', '');
1165 19 100       87 return wantarray ? @tags : join $label, @tags;
1166             }
1167              
1168             sub required_tag {
1169 48     48 0 45 my $self = shift;
1170 48   100     121 my $label = shift || '';
1171             my @tags = $self->{stylesheet}
1172 48 100       125 ? (qq(), '')
1173             : ('', '');
1174 48 100       318 return wantarray ? @tags : join $label, @tags;
1175             }
1176              
1177             sub cgi_param {
1178 9     9 1 13 my $self = shift;
1179 9         25 $self->{params}->param(@_);
1180             }
1181              
1182             sub tmpl_param {
1183 74     74 1 89 my $self = shift;
1184 74 100       143 if (my $key = shift) {
1185             return @_ ? $self->{tmplvar}{$key} = shift
1186 4 50       23 : $self->{tmplvar}{$key};
1187             } else {
1188             # return hash or key/value pairs
1189 70   100     269 my $hr = $self->{tmplvar} || {};
1190 70 50       277 return wantarray ? %$hr : $hr;
1191             }
1192             }
1193              
1194             sub version {
1195             # Hidden trailer. If you perceive this as annoying, let me know and I
1196             # may remove it. It's supposed to help.
1197 129 50   129 0 518 return '' if $::TESTING;
1198 0 0       0 if (ref $_[0]) {
1199 0         0 return "\n\n";
1200             } else {
1201 0         0 return "CGI::FormBuilder v$VERSION by Nate Wiger. All Rights Reserved.\n";
1202             }
1203             }
1204              
1205             sub values {
1206 49     49 1 56 my $self = shift;
1207              
1208 49 50       98 if (@_) {
1209 49         95 $self->{values} = arghash(@_);
1210 49         83 my %val = ();
1211 49         55 my @val = ();
1212              
1213             # We currently make two passes, first getting the values
1214             # and storing them into a temp hash, and then going thru
1215             # the fields and picking up the values and attributes.
1216 49         62 local $" = ',';
1217 49         147 debug 1, "\$form->{values} = ($self->{values})";
1218              
1219             # Using isa() allows objects to transparently fit in here
1220 49 50       203 if (UNIVERSAL::isa($self->{values}, 'CODE')) {
    100          
    50          
1221             # it's a sub; lookup each value in turn
1222 0         0 for my $key (&{$self->{values}}) {
  0         0  
1223             # always assume an arrayref of values...
1224 0         0 $val{$key} = [ &{$self->{values}}($key) ];
  0         0  
1225 0         0 debug 2, "setting values from \\&code(): $key = (@{$val{$key}})";
  0         0  
1226             }
1227             } elsif (UNIVERSAL::isa($self->{values}, 'HASH')) {
1228             # must lc all the keys since we're case-insensitive, then
1229             # we turn our values hashref into an arrayref on the fly
1230 47         103 my @v = autodata $self->{values};
1231 47         103 while (@v) {
1232 91         130 my $key = lc shift @v;
1233 91         150 $val{$key} = [ autodata shift @v ];
1234 91         143 debug 2, "setting values from HASH: $key = (@{$val{$key}})";
  91         218  
1235             }
1236             } elsif (UNIVERSAL::isa($self->{values}, 'ARRAY')) {
1237             # also accept an arrayref which is walked sequentially below
1238 2         5 debug 2, "setting values from ARRAY: (walked below)";
1239 2         5 @val = autodata $self->{values};
1240             } else {
1241 0         0 puke "Unsupported operand to 'values' option - must be \\%hash, \\&sub, or \$object";
1242             }
1243              
1244             # redistribute values across all existing fields
1245 49         102 for ($self->fields) {
1246 118   100     211 my $v = $val{lc($_)} || shift @val; # use array if no value
1247 118 100       334 $_->field(value => $v) if defined $v;
1248             }
1249             }
1250              
1251             }
1252              
1253             sub name {
1254 60     60 1 65 my $self = shift;
1255 60 50       216 @_ ? $self->{name} = shift : $self->{name};
1256             }
1257              
1258             sub nameopts {
1259 0     0 1 0 my $self = shift;
1260 0 0       0 if (@_) {
1261 0         0 $self->{nameopts} = shift;
1262 0         0 for ($self->fields) {
1263 0         0 $_->field(nameopts => $self->{nameopts});
1264             }
1265             }
1266 0         0 return $self->{nameopts};
1267             }
1268              
1269             sub sortopts {
1270 0     0 1 0 my $self = shift;
1271 0 0       0 if (@_) {
1272 0         0 $self->{sortopts} = shift;
1273 0         0 for ($self->fields) {
1274 0         0 $_->field(sortopts => $self->{sortopts});
1275             }
1276             }
1277 0         0 return $self->{sortopts};
1278             }
1279              
1280             sub selectnum {
1281 0     0 1 0 my $self = shift;
1282 0 0       0 if (@_) {
1283 0         0 $self->{selectnum} = shift;
1284 0         0 for ($self->fields) {
1285 0         0 $_->field(selectnum => $self->{selectnum});
1286             }
1287             }
1288 0         0 return $self->{selectnum};
1289             }
1290              
1291             sub options {
1292 0     0 1 0 my $self = shift;
1293 0 0       0 if (@_) {
1294 0         0 $self->{options} = arghash(@_);
1295 0         0 my %val = ();
1296              
1297             # same case-insensitization as $form->values
1298 0         0 my @v = autodata $self->{options};
1299 0         0 while (@v) {
1300 0         0 my $key = lc shift @v;
1301 0         0 $val{$key} = [ autodata shift @v ];
1302             }
1303              
1304 0         0 for ($self->fields) {
1305 0         0 my $v = $val{lc($_)};
1306 0 0       0 $_->field(options => $v) if defined $v;
1307             }
1308             }
1309 0         0 return $self->{options};
1310             }
1311              
1312             sub labels {
1313 0     0 1 0 my $self = shift;
1314 0 0       0 if (@_) {
1315 0         0 $self->{labels} = arghash(@_);
1316 0         0 my %val = ();
1317              
1318             # same case-insensitization as $form->values
1319 0         0 my @v = autodata $self->{labels};
1320 0         0 while (@v) {
1321 0         0 my $key = lc shift @v;
1322 0         0 $val{$key} = [ autodata shift @v ];
1323             }
1324              
1325 0         0 for ($self->fields) {
1326 0         0 my $v = $val{lc($_)};
1327 0 0       0 $_->field(label => $v) if defined $v;
1328             }
1329             }
1330 0         0 return $self->{labels};
1331             }
1332              
1333             # Note that validate does not work like a true accessor
1334             sub validate {
1335 19     19 1 94 my $self = shift;
1336            
1337 19 50       32 if (@_) {
1338 0 0       0 if (ref $_[0]) {
    0          
    0          
1339             # this'll either be a hashref or a DFV object
1340 0         0 $self->{validate} = shift;
1341             } elsif (@_ % 2 == 0) {
1342             # someone passed a hash-as-list
1343 0         0 $self->{validate} = { @_ };
1344             } elsif (@_ > 1) {
1345             # just one argument we'll interpret as a DFV profile name;
1346             # an odd number > 1 is probably a typo...
1347 0         0 puke "Odd number of elements passed to validate";
1348             }
1349             }
1350              
1351 19         15 my $ok = 1;
1352              
1353 19 50       38 if (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
1354 0   0     0 my $profile_name = shift || 'fb';
1355 0         0 debug 1, "validating fields via the '$profile_name' profile";
1356             # hang on to the DFV results, for things like DBIx::Class::WebForm
1357 0         0 $self->{dfv_results} = $self->{validate}->check($self, $profile_name);
1358              
1359             # mark the invalid fields
1360             my @invalid_fields = (
1361             $self->{dfv_results}->invalid,
1362             $self->{dfv_results}->missing,
1363 0         0 );
1364 0         0 for my $field_name (@invalid_fields) {
1365 0         0 $self->field(
1366             name => $field_name,
1367             invalid => 1,
1368             );
1369             }
1370             # validation failed
1371 0 0       0 $ok = 0 if @invalid_fields > 0;
1372             } else {
1373 19         29 debug 1, "validating all fields via \$form->validate";
1374 19         25 for ($self->fields) {
1375 41 100       87 $ok = 0 unless $_->validate;
1376             }
1377             }
1378 19         50 debug 1, "validation done, ok = $ok (should be 1)";
1379 19         35 return $ok;
1380             }
1381              
1382             sub confirm {
1383             # This is nothing more than a special wrapper around render()
1384 0     0 1 0 my $self = shift;
1385 0 0       0 my $date = $::TESTING ? 'LOCALTIME' : localtime();
1386 0   0     0 $self->{text} ||= sprintf $self->{messages}->form_confirm_text, $date;
1387 0         0 $self->{static} = 1;
1388 0         0 return $self->render(@_);
1389             }
1390              
1391             # Prepare a template
1392             sub prepare {
1393 70     70 1 78 my $self = shift;
1394 70         213 debug 1, "Calling \$form->prepare(@_)";
1395              
1396             # Build a big hashref of data that can be used by the template
1397             # engine. Templates then have the ability to expand this however
1398             # they see fit.
1399 70         172 my %tmplvar = $self->tmpl_param;
1400              
1401             # This is based on the original Template Toolkit render()
1402 70         148 for my $field ($self->field) {
1403              
1404             # Extract value since used often
1405 201         431 my @value = $field->tag_value;
1406              
1407             # Create a struct for each field
1408 201         724 $tmplvar{field}{"$field"} = {
1409             %$field, # gets invalid/missing/required
1410             field => $field->tag,
1411             value => $value[0],
1412             values => \@value,
1413             options => [$field->options],
1414             label => $field->label,
1415             type => $field->type,
1416             comment => $field->comment,
1417             nameopts => $field->nameopts,
1418             cleanopts => $field->cleanopts,
1419             };
1420             # Force-stringify "$field" to get name() under buggy Perls
1421 201         629 $tmplvar{field}{"$field"}{error} = $field->error;
1422             }
1423              
1424             # Must generate JS first because it affects the others.
1425             # This is a bit action-at-a-distance, but I just can't
1426             # figure out a way around it.
1427 70         174 debug 2, "\$tmplvar{jshead} = \$self->script";
1428 70         184 $tmplvar{jshead} = $self->script;
1429 70         154 debug 2, "\$tmplvar{title} = \$self->title";
1430 70         165 $tmplvar{title} = $self->title;
1431 70         135 debug 2, "\$tmplvar{start} = \$self->start . \$self->statetags . \$self->keepextras";
1432 70         155 $tmplvar{start} = $self->start . $self->statetags . $self->keepextras;
1433 70         224 debug 2, "\$tmplvar{submit} = \$self->submit";
1434 70         153 $tmplvar{submit} = $self->submit;
1435 70         235 debug 2, "\$tmplvar{reset} = \$self->reset";
1436 70         139 $tmplvar{reset} = $self->reset;
1437 70         154 debug 2, "\$tmplvar{end} = \$self->end";
1438 70         149 $tmplvar{end} = $self->end;
1439 70         138 debug 2, "\$tmplvar{invalid} = \$self->invalid";
1440 70         246 $tmplvar{invalid} = $self->invalid;
1441 70         152 debug 2, "\$tmplvar{required} = \$self->required";
1442 70         210 $tmplvar{required} = $self->required;
1443              
1444 70         161 my $fieldsets = $self->fieldsets;
1445 70         194 for my $key (keys %$fieldsets) {
1446             $tmplvar{fieldset}{$key} = {
1447             name => $key,
1448 74         395 label => $fieldsets->{$key},
1449             }
1450             }
1451 70         140 $tmplvar{fieldsets} = [ map $tmplvar{fieldset}{$_}, $self->fieldsets ];
1452              
1453 70         160 debug 2, "\$tmplvar{fields} = [ map \$tmplvar{field}{\$_}, \$self->field ]";
1454 70         109 $tmplvar{fields} = [ map $tmplvar{field}{$_}, $self->field ];
1455              
1456 70 50       532 return wantarray ? %tmplvar : \%tmplvar;
1457             }
1458              
1459             sub render {
1460 70     70 1 935 local $^W = 0; # -w sucks
1461 70         156 my $self = shift;
1462 70         254 debug 1, "starting \$form->render(@_)";
1463              
1464             # any arguments are used to make permanent changes to the $form
1465 70 100       151 if (@_) {
1466 1 50       4 puke "Odd number of arguments passed into \$form->render()"
1467             unless @_ % 2 == 0;
1468 1         3 while (@_) {
1469 3         3 my $k = shift;
1470 3         11 $self->$k(shift);
1471             }
1472             }
1473              
1474             # check for engine type
1475 70         69 my $mod;
1476 70         116 my $ref = ref $self->{template};
1477 70 50 66     231 if (! $ref && $self->{template}) {
1478             # "legacy" string filename for HTML::Template; redo format
1479             # modifying $self object is ok because it's compatible
1480             $self->{template} = {
1481             type => 'HTML',
1482             filename => $self->{template},
1483 0         0 };
1484 0         0 $ref = 'HASH'; # tricky
1485 0         0 debug 2, "rewrote 'template' option since found filename";
1486             }
1487             # Get ourselves ready
1488 70         145 $self->{prepare} = $self->prepare;
1489             # weaken($self->{prepare});
1490            
1491 70         85 my $opt;
1492 70 100       341 if ($ref eq 'HASH') {
    50          
    50          
    50          
1493             # must copy to avoid destroying
1494 12         13 $opt = { %{ $self->{template} } };
  12         40  
1495 12   100     47 $mod = ucfirst(delete $opt->{type} || 'HTML');
1496             } elsif ($ref eq 'CODE') {
1497             # subroutine wrapper
1498 0         0 return &{$self->{template}}($self);
  0         0  
1499             } elsif (UNIVERSAL::can($self->{template}, 'render')) {
1500             # instantiated object
1501 0         0 return $self->{template}->render($self);
1502             } elsif ($ref) {
1503 0         0 puke "Unsupported operand to 'template' option - must be \\%hash, \\&sub, or \$object w/ render()";
1504             }
1505              
1506             # load user-specified rendering module, or builtin rendering
1507 70   100     215 $mod ||= 'Builtin';
1508              
1509             # user can give 'Their::Complete::Module' or an 'IncludedAdapter'
1510 70 50       266 $mod = join '::', __PACKAGE__, 'Template', $mod unless $mod =~ /::/;
1511 70         196 debug 1, "loading $mod for 'template' option";
1512              
1513             # load module
1514 70         3852 eval "require $mod";
1515 70 100       268 puke "Bad template engine $mod: $@" if $@;
1516              
1517             # create new object
1518             #CGI::FormBuilder::Template::Builtin
1519            
1520 63         263 my $tmpl = $mod->new($opt);
1521             # Experiemental: Alter tag names as we're rendering, to support
1522             # Ajaxian markup schemes that use their own tags (Backbase, Dojo, etc)
1523 63         96 local %CGI::FormBuilder::Util::TAGNAMES;
1524 63         87 while (my($k,$v) = each %{$self->{tagnames}}) {
  72         569  
1525 9         10 $CGI::FormBuilder::Util::TAGNAMES{$k} = $v;
1526             }
1527              
1528              
1529             # Call the engine's prepare too, if it exists
1530             # Give it the form object so it can do what it wants
1531             # This will have all of the prepared data in {prepare} anyways
1532 63 100 66     393 if ($tmpl && UNIVERSAL::can($tmpl, 'prepare')) {
1533 59         135 $tmpl->prepare($self);
1534             }
1535            
1536              
1537              
1538             # dispatch to engine, prepend header
1539 63         304 debug 1, "returning $tmpl->render($self->{prepare})";
1540              
1541 63         152 my $ret = $self->header . $tmpl->render($self->{prepare});
1542            
1543             #we have a circular reference but we need to kill it after setting up return
1544 63         928 weaken($self->{prepare});
1545 63         305 return $ret;
1546             }
1547              
1548             # These routines should be moved to ::Mail or something since they're rarely used
1549             sub mail () {
1550             # This is a very generic mail handler
1551 0     0 1 0 my $self = shift;
1552 0         0 my $args = arghash(@_);
1553              
1554             # Where does the mailer live? Must be sendmail-compatible
1555 0         0 my $mailer = undef;
1556 0 0 0     0 unless ($mailer = $args->{mailer} && -x $mailer) {
1557 0         0 for my $sendmail (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/bin/sendmail)) {
1558 0 0       0 if (-x $sendmail) {
1559 0         0 $mailer = "$sendmail -t";
1560 0         0 last;
1561             }
1562             }
1563             }
1564 0 0       0 unless ($mailer) {
1565 0         0 belch "Cannot find a sendmail-compatible mailer; use mailer => '/path/to/mailer'";
1566 0         0 return;
1567             }
1568 0 0       0 unless ($args->{to}) {
1569 0         0 belch "Missing required 'to' argument; cannot continue without recipient";
1570 0         0 return;
1571             }
1572 0 0       0 if ($args->{from}) {
1573 0         0 (my $from = $args->{from}) =~ s/"/\\"/g;
1574 0         0 $mailer .= qq( -f "$from");
1575             }
1576              
1577 0         0 debug 1, "opening new mail to $args->{to}";
1578              
1579             # untaint
1580 0         0 my $oldpath = $ENV{PATH};
1581 0         0 $ENV{PATH} = '/usr/bin:/usr/sbin';
1582              
1583 0 0       0 open(MAIL, "|$mailer >/dev/null 2>&1") || next;
1584 0         0 print MAIL "From: $args->{from}\n";
1585 0         0 print MAIL "To: $args->{to}\n";
1586 0 0       0 print MAIL "Cc: $args->{cc}\n" if $args->{cc};
1587 0 0       0 print MAIL "Content-Type: text/plain; charset=\""
1588             . $self->charset . "\"\n" if $self->charset;
1589 0         0 print MAIL "Subject: $args->{subject}\n\n";
1590 0         0 print MAIL "$args->{text}\n";
1591              
1592             # retaint
1593 0         0 $ENV{PATH} = $oldpath;
1594              
1595 0         0 return close(MAIL);
1596             }
1597              
1598             sub mailconfirm () {
1599              
1600             # This prints out a very generic message. This should probably
1601             # be much better, but I suspect very few if any people will use
1602             # this method. If you do, let me know and maybe I'll work on it.
1603              
1604 0     0 1 0 my $self = shift;
1605 0 0       0 my $to = shift unless (@_ > 1);
1606 0         0 my $args = arghash(@_);
1607              
1608             # must have a "to"
1609 0 0 0     0 return unless $args->{to} ||= $to;
1610              
1611             # defaults
1612 0   0     0 $args->{from} ||= 'auto-reply';
1613 0   0     0 $args->{subject} ||= sprintf $self->{messages}->mail_confirm_subject, $self->title;
1614 0   0     0 $args->{text} ||= sprintf $self->{messages}->mail_confirm_text, scalar localtime();
1615              
1616 0         0 debug 1, "mailconfirm() called, subject = '$args->{subject}'";
1617              
1618 0         0 $self->mail($args);
1619             }
1620              
1621             sub mailresults () {
1622             # This is a wrapper around mail() that sends the form results
1623 0     0 1 0 my $self = shift;
1624 0         0 my $args = arghash(@_);
1625              
1626 0 0       0 if (exists $args->{plugin}) {
1627 0         0 my $lib = "CGI::FormBuilder::Mail::$args->{plugin}";
1628 0         0 eval "use $lib";
1629 0 0       0 puke "Cannot use mailresults() plugin '$lib': $@" if $@;
1630 0         0 eval {
1631 0         0 my $plugin = $lib->new( form => $self, %$args );
1632 0         0 $plugin->mailresults();
1633             };
1634 0 0       0 puke "Could not mailresults() with plugin '$lib': $@" if $@;
1635 0         0 return;
1636             }
1637              
1638             # Get the field separator to use
1639 0   0     0 my $delim = $args->{delimiter} || ': ';
1640 0   0     0 my $join = $args->{joiner} || $";
1641 0   0     0 my $sep = $args->{separator} || "\n";
1642              
1643             # subject default
1644 0   0     0 $args->{subject} ||= sprintf $self->{messages}->mail_results_subject, $self->title;
1645 0         0 debug 1, "mailresults() called, subject = '$args->{subject}'";
1646              
1647 0 0       0 if ($args->{skip}) {
1648 0 0       0 if ($args->{skip} =~ m#^m?(\S)(.*)\1$#) {
1649 0         0 ($args->{skip} = $2) =~ s/\\\//\//g;
1650 0         0 $args->{skip} =~ s/\//\\\//g;
1651             }
1652             }
1653              
1654 0         0 my @form = ();
1655 0         0 for my $field ($self->fields) {
1656 0 0 0     0 if ($args->{skip} && $field =~ /$args->{skip}/) {
1657 0         0 next;
1658             }
1659 0         0 my $v = join $join, $field->value;
1660 0 0       0 $field = $field->label if $args->{labels};
1661 0         0 push @form, "$field$delim$v";
1662             }
1663 0         0 my $text = join $sep, @form;
1664              
1665 0         0 $self->mail(%$args, text => $text);
1666             }
1667              
1668 131     131   22927 sub DESTROY { 1 }
1669              
1670             # This is used to access all options after new(), by name
1671             sub AUTOLOAD {
1672             # This allows direct addressing by name
1673 3229     3229   8776 local $^W = 0;
1674 3229         2441 my $self = shift;
1675 3229         9038 my($name) = $AUTOLOAD =~ /.*::(.+)/;
1676              
1677             # If fieldsubs => 1 set, then allow grabbing fields directly
1678 3229 0 33     5488 if ($self->{fieldsubs} && $self->{fieldrefs}{$name}) {
1679 0         0 return $self->field(name => $name, @_);
1680             }
1681              
1682 3229         7621 debug 3, "-> dispatch to \$form->{$name} = @_";
1683 3229 100       5085 if (@_ % 2 == 1) {
1684 5         8 $self->{$name} = shift;
1685              
1686 5 100       10 if ($REARRANGE{$name}) {
1687             # needs to be splatted into every field
1688 2         5 for ($self->fields) {
1689 6         10 my $tval = rearrange($self->{$name}, "$_");
1690 6         20 $_->$name($tval);
1691             }
1692             }
1693             }
1694              
1695             # Try to catch $form->$fieldname usage
1696 3229 50 66     11003 if ((! exists($self->{$name}) || @_) && ! $CGI::FormBuilder::Util::OURATTR{$name}) {
      66        
1697 0 0       0 if ($self->{fieldsubs}) {
1698 0         0 return $self->field(name => $name, @_);
1699             } else {
1700 0         0 belch "Possible field access via \$form->$name() - see 'fieldsubs' option"
1701             }
1702             }
1703              
1704 3229         8748 return $self->{$name};
1705             }
1706              
1707             1;
1708             __END__