File Coverage

lib/CGI/FormBuilder.pm
Criterion Covered Total %
statement 560 789 70.9
branch 264 444 59.4
condition 95 190 50.0
subroutine 56 68 82.3
pod 36 58 62.0
total 1011 1549 65.2


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   181019 use Carp;
  11         21  
  11         825  
12 11     11   97 use strict;
  11         30  
  11         270  
13 11     11   51 use warnings;
  11         23  
  11         700  
14 11     11   53 no warnings 'uninitialized';
  11         31  
  11         532  
15 11     11   59 use Scalar::Util qw(weaken);
  11         18  
  11         1105  
16              
17 11     11   6247 use CGI::FormBuilder::Util;
  11         38  
  11         1479  
18 11     11   7482 use CGI::FormBuilder::Field;
  11         42  
  11         548  
19 11     11   7178 use CGI::FormBuilder::Messages;
  11         36  
  11         168443  
20              
21             our $VERSION = '3.20';
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 1191810 local $^W = 0; # -w sucks
101 135         301 my $self = shift;
102              
103             # A single arg is a source; others are opt => val pairs
104 135         273 my %opt;
105 135 100       447 if (@_ == 1) {
106             %opt = UNIVERSAL::isa($_[0], 'HASH')
107 3 50       20 ? %{ $_[0] }
  3         21  
108             : ( source => shift() );
109             } else {
110 132         549 %opt = arghash(@_);
111             }
112              
113             # Pre-check for an external source
114 135 100       639 if (my $src = delete $opt{source}) {
115              
116             # check for engine type
117 23         57 my $mod;
118             my $sopt; # opts returned from parsing
119 23         75 my $ref = ref $src;
120 23 50       83 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     129 debug 1, "creating form from source ", $ref || $src;
133              
134 23 50       69 if ($ref eq 'HASH') {
    0          
    0          
    0          
135             # grab module
136 23   100     85 $mod = delete $src->{type} || 'File';
137              
138             # user can give 'Their::Complete::Module' or an 'IncludedTemplate'
139 23 50       146 $mod = join '::', __PACKAGE__, 'Source', $mod unless $mod =~ /::/;
140 23         106 debug 1, "loading $mod for 'source' option";
141              
142 23         2730 eval "require $mod";
143 23 50       138 puke "Bad source module $mod: $@" if $@;
144              
145 23         188 my $sob = $mod->new(%$src);
146 23         117 $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         116 while (my($k,$v) = each %$sopt) {
159 135 50       647 $opt{$k} = $v unless exists $opt{$k};
160             }
161             }
162              
163 135 100       361 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         460 debug 1, "constructing new FormBuilder object";
171             # damn deep copy this is SO damn annoying
172 134         615 while (my($k,$v) = each %DEFAULT) {
173 5896 100       10787 next if exists $opt{$k};
174 5618 100       10150 if (ref $v eq 'HASH') {
    50          
175 922         3279 $opt{$k} = { %$v };
176             } elsif (ref $v eq 'ARRAY') {
177 0         0 $opt{$k} = [ @$v ];
178             } else {
179 4696         14688 $opt{$k} = $v;
180             }
181             }
182 134         483 $self = bless \%opt, $self;
183             }
184              
185             # Create our CGI object if not present
186 135 100       540 unless (ref $self->{params}) {
187 131         11740 require CGI;
188 131         428539 $CGI::USE_PARAM_SEMICOLONS = 0; # fuck ; in urls
189 131         1026 $self->{params} = CGI->new($self->{params});
190             }
191              
192             # XXX not mod_perl safe
193 135   33     128094 $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       545 if (lc($self->{messages}) eq 'auto') {
199 2         5 my $lang = $self->{messages};
200             # figure out the messages from our params object
201 2 50       13 if (UNIVERSAL::isa($self->{params}, 'CGI')) {
    0          
    0          
202 2         13 $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     55 $lang ||= 'default';
213 2         12 $self->{messages} = CGI::FormBuilder::Messages->new(":$lang");
214             } else {
215             # ref or filename (::Messages will decode)
216 133         948 $self->{messages} = CGI::FormBuilder::Messages->new($self->{messages});
217             }
218              
219             # Initialize form fields (probably a good idea)
220 135 100       525 if ($self->{fields}) {
221 109         403 debug 1, "creating fields list";
222              
223             # check to see if 'fields' is a hash or array ref
224 109         280 my $ref = ref $self->{fields};
225 109 100 100     554 if ($ref && $ref eq 'HASH') {
226             # with a hash ref, we setup keys/values
227 4         12 debug 2, "got fields list from HASH";
228 4         7 while(my($k,$v) = each %{$self->{fields}}) {
  12         47  
229 8         17 $k = lc $k; # must lc to ignore case
230 8         21 $self->{values}{$k} = [ autodata $v ];
231             }
232             # reset main fields to field names
233 4         7 $self->{fields} = [ sort keys %{$self->{fields}} ];
  4         21  
234             } else {
235             # rewrite fields to ensure format
236 105         285 debug 2, "assuming fields list from ARRAY";
237 105         339 $self->{fields} = [ autodata $self->{fields} ];
238             }
239             }
240              
241 135 50       682 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       629 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       45 if ($self->{required} eq 'NONE') {
    100          
    50          
252 1         3 delete $self->{required}; # that's it
253             }
254             elsif ($self->{required} eq 'ALL') {
255 6         15 $self->{required} = [ @{$self->{fields}} ];
  6         24  
256             }
257             elsif ($self->{required}) {
258             # required => 'single_field' catch
259 1         5 $self->{required} = { $self->{required} => 1 };
260             }
261             } elsif ($self->{validate}) {
262             # construct a required list of all validated fields
263 28         50 $self->{required} = [ keys %{$self->{validate}} ];
  28         174  
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         332 my @ftmp = ();
270 135         209 for (@{$self->{fields}}) {
  135         475  
271 304 100       506 my %fprop = %{$self->{fieldopts}{$_} || {}}; # field properties
  304         1493  
272              
273 304 50       838 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         749 $fprop{name} = "$_";
279 304         1009 $_ = $self->new_field(%fprop);
280 304         823 weaken($_->{_form});
281             }
282 304         1017 debug 2, "push \@(@ftmp), $_";
283 304         905 weaken($self->{fieldrefs}{"$_"} = $_);
284 304         1004 push @ftmp, $_;
285             }
286              
287             # stringifiable objects (overwrite previous container)
288 135         433 $self->{fields} = \@ftmp;
289              
290             # setup values
291 135 100       661 $self->values($self->{values}) if $self->{values};
292              
293 135         447 debug 1, "field creation done, list = (@ftmp)";
294              
295 135         808 return $self;
296             }
297              
298             *param = \&field;
299             *params = \&field;
300             *fields = \&field;
301             sub field {
302 1096     1096 1 7495 local $^W = 0; # -w sucks
303 1096         1831 my $self = shift;
304 1096         4137 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     3196 return $self->new(fields => $_[0])
314             if ref $_[0] eq 'ARRAY' && @_ == 1;
315              
316 1095 100       2650 my $name = (@_ % 2 == 0) ? '' : shift();
317 1095         2612 my $args = arghash(@_);
318 1095   100     5639 $args->{name} ||= $name;
319              
320             # no name - return ala $cgi->param
321 1095 100       2653 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       1908 if (wantarray) {
326             # pre-scan for any "order" arguments, reorder, delete
327 952         1403 for my $redo (grep { $_->order } @{$self->{fields}}) {
  2732         11053  
  952         2540  
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         1494 debug 2, "return (@{$self->{fields}})";
  952         3340  
354 952         1920 return @{$self->{fields}};
  952         5075  
355             } else {
356             # this only returns a single scalar value for each field
357 1         2 return { map { $_ => scalar($_->value) } @{$self->{fields}} };
  8         26  
  1         4  
358             }
359             }
360              
361             # have name, so redispatch to field member
362 142         552 debug 2, "searching fields for '$args->{name}'";
363 142 50       724 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         174 delete $args->{name}; # segfault??
371 92         365 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       219 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         145 my $f = $self->new_field(%$args);
380 42         155 weaken($self->{fieldrefs}{"$f"} = $f);
381 42         99 weaken($f->{_form});
382 42         113 weaken($f->{fieldrefs}{"$f"});
383 42         139 push @{$self->{fields}}, $f;
  42         152  
384            
385 42         145 return $f->value;
386             }
387              
388             sub new_field {
389 346     346 0 569 my $self = shift;
390 346         824 my $args = arghash(@_);
391 346 50       872 puke "Need a name for \$form->new_field()" unless exists $args->{name};
392 346         1208 debug 1, "called \$form->new_field($args->{name})";
393              
394             # extract our per-field options from rearrange
395 346         1193 while (my($from,$to) = each %REARRANGE) {
396 4498 100       11687 next unless exists $self->{$from};
397 1749 100       3524 next if defined $args->{$to}; # manually set
398 1745         3835 my $tval = rearrange($self->{$from}, $args->{name});
399 1745         5052 debug 2, "rearrange: \$args->{$to} = $tval;";
400 1745         6198 $args->{$to} = $tval;
401             }
402              
403             $args->{type} = lc $self->{fieldtype}
404 346 100 66     974 if $self->{fieldtype} && ! exists $args->{type};
405 346 100       780 if ($self->{fieldattr}) { # legacy
406 11         20 while (my($k,$v) = each %{$self->{fieldattr}}) {
  22         78  
407 11 50       28 next if exists $args->{$k};
408 11         32 $args->{$k} = $v;
409             }
410             }
411            
412 346         1355 my $f = CGI::FormBuilder::Field->new($self, $args);
413 346         1516 debug 1, "created field $f";
414 346         768 return $f; # already set args above ^^^
415             }
416              
417             *fieldset = \&fieldsets;
418             sub fieldsets {
419 258     258 1 398 my $self = shift;
420 258 50       580 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         482 my(%legends, @sets);
448 258         992 for (optalign($self->{fieldsets})) {
449 270         717 my($o,$n) = optval($_);
450 270 50       754 next if exists $legends{$o};
451 270         529 push @sets, $o;
452 270         965 debug 2, "added fieldset $o (legend=$n) to \@sets";
453 270         780 $legends{$o} = $n;
454             }
455              
456             # find *all* our fieldsets, even hidden in fields w/o Human Tags
457 258         929 for ($self->field) {
458 748 100       3853 next unless my $o = $_->fieldset;
459 44 100       109 next if exists $legends{$o};
460 4         8 push @sets, $o;
461 4         12 debug 2, "added fieldset $o (legend=undef) to \@sets";
462 4         9 $legends{$o} = $o; # use fieldset as
463             }
464 258 100       1392 return wantarray ? @sets : \%legends;
465             }
466              
467             sub fieldlist {
468 59     59 0 110 my $self = shift;
469 59 50       223 my @fields = @_ ? @_ : $self->field;
470 59         132 my(%saw, @ret);
471 59         165 for my $set ($self->fieldsets) {
472             # reorder fields
473 63         151 for (@fields) {
474 213 100       486 next if $saw{$_};
475 194 100 100     674 if ($_->fieldset && $_->fieldset eq $set) {
476             # if this field is in this fieldset, regroup
477 11         18 push @ret, $_;
478 11         31 debug 2, "added field $_ to field order (fieldset=$set)";
479 11         24 $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         152 for (@fields) {
488 173         490 debug 2, "appended non-fieldset field $_ to form";
489 173 100       388 push @ret, $_ unless $saw{$_};
490             }
491              
492 59 50       320 return wantarray ? @ret : \@ret;
493             }
494              
495             sub header {
496 123     123 1 400 my $self = shift;
497 123 50       362 $self->{header} = shift if @_;
498 123 100       557 return unless $self->{header};
499 29         84 my %head;
500 29 100 66     237 if ($self->{cookies} && defined(my $sid = $self->sessionid)) {
501 3         39 require CGI::Cookie;
502             $head{'-cookie'} = CGI::Cookie->new(-name => $self->{sessionidname},
503 3         43 -value => $sid);
504             }
505             # Set the charset for i18n
506 29         1676 $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       181 return "Content-type: text/html\n\n" if $::TESTING;
511 1         12 require CGI;
512 1         27 return CGI::header(%head); # CGI.pm MOD_PERL fanciness
513             }
514              
515             sub charset {
516 32     32 1 295 my $self = shift;
517 32 100       89 $self->{charset} = shift if @_;
518 32   50     340 return $self->{charset} || $self->{messages}->charset || 'iso8859-1';
519             }
520              
521             sub lang {
522 3     3 1 6 my $self = shift;
523 3 50       8 $self->{lang} = shift if @_;
524 3   50     16 return $self->{lang} || $self->{messages}->lang || 'en_US';
525             }
526              
527             sub dtd {
528 15     15 0 30 my $self = shift;
529 15 50       45 $self->{dtd} = shift if @_;
530 15 100       81 return '' if $::TESTING;
531              
532             # replace special chars in dtd by exec'ing subs
533 1         3 my $dtd = $self->{dtd};
534 1         7 $dtd =~ s/\{(\w+)\}/$self->$1/ge;
  3         8  
535 1         5 return $dtd;
536             }
537              
538             sub title {
539 127     127 1 227 my $self = shift;
540 127 50       1695 $self->{title} = shift if @_;
541 127 100       730 return $self->{title} if exists $self->{title};
542 6         23 return toname(basename);
543             }
544              
545             *script_name = \&action;
546             sub action {
547 9     9 1 40 local $^W = 0; # -w sucks (still)
548 9         19 my $self = shift;
549 9 50       40 $self->{action} = shift if @_;
550 9 100       41 return $self->{action} if exists $self->{action};
551 8         24 return basename . $ENV{PATH_INFO};
552             }
553              
554             sub font {
555 339     339 1 648 my $self = shift;
556 339 50       811 $self->{font} = shift if @_;
557 339 100       1301 return '' unless $self->{font};
558 2 50       14 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 228 my $self = shift;
578 129         2291 my %attr = htmlattr('form', %$self);
579              
580 129   66     841 $attr{action} ||= $self->action;
581 129   33     332 $attr{method} ||= $self->method;
582 129         370 $attr{method} = lc($attr{method}); # xhtml
583 129 100       415 $self->disabled ? $attr{disabled} = 'disabled' : delete $attr{disabled};
584 129   66     1069 $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       382 unless $self->{_didscript};
589              
590             # A catch for lowercase actions
591             belch "Old-style 'onSubmit' action found - should be 'onsubmit'"
592 129 50       376 if $attr{onSubmit};
593              
594 129         388 return $self->version . htmltag('form', %attr);
595             }
596              
597             sub end {
598 70     70 0 248 return '';
599             }
600              
601             # Need to wrap this or else AUTOLOAD whines (OURATTR missing)
602             sub disabled {
603 690     690 0 1178 my $self = shift;
604 690 50       1530 $self->{disabled} = shift if @_;
605 690 100       2824 return $self->{disabled} ? 'disabled' : undef;
606             }
607            
608             sub body {
609 14     14 1 30 my $self = shift;
610 14 50       46 $self->{body} = shift if @_;
611 14 100 100     98 $self->{body}{bgcolor} ||= 'white' unless $self->{stylesheet};
612 14         49 return htmltag('body', $self->{body});
613             }
614              
615             sub class {
616 1490     1490 0 2533 my $self = shift;
617 1490 100       5207 return undef unless $self->{stylesheet};
618 307         1196 return join '', $self->{styleclass}, @_; # remainder is optional tag
619             }
620              
621             sub idname {
622 752     752 0 1283 my $self = shift;
623             $self->{id} = $self->{name}
624 752 100       2214 unless defined $self->{id};
625 752 100       2686 return undef unless $self->{id};
626 184         782 return join '', $self->{id}, @_; # remainder is optional tag
627             }
628              
629             sub table {
630 106     106 1 182 my $self = shift;
631              
632             # single hashref kills everything; a list is temporary
633 106 50       265 $self->{table} = shift if @_ == 1;
634 106 100       346 return unless $self->{table};
635              
636             # set defaults for numeric table => 1
637 104 100       315 $self->{table} = $DEFAULT{table} if $self->{table} == 1;
638              
639 104         218 my $attr = $self->{table};
640 104 100       270 if (@_) {
641             # if still have args, create a temp hash
642 100         302 my %temp = %$attr;
643 100         301 while (my $k = shift) {
644 156         542 $temp{$k} = shift;
645             }
646 100         238 $attr = \%temp;
647             }
648              
649 104 50       283 return unless $self->{table}; # 0 or unset via table(0)
650 104   100     434 $attr->{class} ||= $self->class;
651 104         322 return htmltag('table', $attr);
652             }
653              
654             sub tr {
655 218     218 0 378 my $self = shift;
656              
657             # single hashref kills everything; a list is temporary
658 218 50 33     643 $self->{tr} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
659              
660 218         435 my $attr = $self->{tr};
661 218 50       480 if (@_) {
662             # if still have args, create a temp hash
663 218         477 my %temp = %$attr;
664 218         564 while (my $k = shift) {
665 218         772 $temp{$k} = shift;
666             }
667 218         442 $attr = \%temp;
668             }
669              
670             # reduced formatting
671 218 100       579 if ($self->{stylesheet}) {
672             # extraneous - inherits from
673             #$attr->{class} ||= $self->class($self->{rowname});
674             } else {
675 168   100     717 $attr->{valign} ||= 'top';
676             }
677              
678 218         635 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 639 my $self = shift;
710              
711             # single hashref kills everything; a list is temporary
712 383 50 33     1084 $self->{td} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
713              
714 383         740 my $attr = $self->{td};
715 383 50       848 if (@_) {
716             # if still have args, create a temp hash
717 383         853 my %temp = %$attr;
718 383         939 while (my $k = shift) {
719 863         2632 $temp{$k} = shift;
720             }
721 383         774 $attr = \%temp;
722             }
723              
724             # extraneous - inherits from
725             #$attr->{class} ||= $self->class($self->{fieldname});
726              
727 383         1037 return htmltag('td', $attr);
728             }
729              
730             sub div {
731 90     90 0 196 my $self = shift;
732              
733             # single hashref kills everything; a list is temporary
734 90 50 33     335 $self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
735              
736 90         821 my $attr = $self->{div};
737 90 50       349 if (@_) {
738             # if still have args, create a temp hash
739 90         247 my %temp = %$attr;
740 90         318 while (my $k = shift) {
741 172         583 $temp{$k} = shift;
742             }
743 90         210 $attr = \%temp;
744             }
745              
746 90         285 return htmltag('div', $attr);
747             }
748              
749             sub submitted {
750 13     13 1 59 my $self = shift;
751 13   33     96 my $smnam = shift || $self->submittedname; # temp smnam
752 13 100       34 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
753              
754 13 100       34 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     221 my $sr = $self->{params}->param($self->submitname) || '0E0';
761 11         147 debug 2, "\$form->submitted() is true, returning $sr";
762 11         31 return $sr;
763             }
764 2         44 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 40941 my $self = shift;
786 159 100       421 $self->{sessionid} = shift if @_;
787 159 100       458 return $self->{sessionid} if $self->{sessionid};
788 153 50       403 return undef unless $self->{sessionidname};
789 153         243 my %cookies;
790 153 50       404 if ($self->{cookies}) {
791 153         7227 require CGI::Cookie;
792 153         30920 %cookies = CGI::Cookie->fetch;
793             }
794 153 50       2914 if (my $cook = $cookies{"$self->{sessionidname}"}) {
795 0         0 return $cook->value;
796             } else {
797 153   50     707 return $self->{params}->param($self->{sessionidname}) || undef;
798             }
799             }
800              
801             sub statetags {
802 129     129 0 273 my $self = shift;
803 129         309 my @html = ();
804              
805             # get _submitted
806 129         722 my $smnam = $self->submittedname;
807 129 100       434 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
808 129         590 my $smval = $self->{params}->param($smnam) + 1;
809 129         3312 push @html, htmltag('input', name => $smtag, value => $smval, type => 'hidden');
810              
811             # and how about _sessionid
812 129 100       460 if (defined(my $sid = $self->sessionid)) {
813             push @html, htmltag('input', name => $self->{sessionidname},
814 2         10 type => 'hidden', value => $sid);
815             }
816              
817             # and what page (hooks for ::Multi)
818 129 100       3534 if (defined $self->{page}) {
819             push @html, htmltag('input', name => $self->pagename,
820 2         20 type => 'hidden', value => $self->{page});
821             }
822              
823 129 50       869 return wantarray ? @html : join "\n", @html;
824             }
825              
826             *keepextra = \&keepextras;
827             sub keepextras {
828 129     129 1 490 local $^W = 0; # -w sucks
829 129         242 my $self = shift;
830 129         310 my @keep = ();
831 129         247 my @html = ();
832              
833             # which ones do they want?
834 129 50       331 $self->{keepextras} = shift if @_;
835 129 100       768 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     65 my $ref = ref $self->{keepextras} || '';
840 10 100       35 if ($ref eq 'ARRAY') {
    50          
841 4         9 @keep = @{$self->{keepextras}};
  4         18  
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         22 for my $p ($self->{params}->param()) {
848 50 100 100     316 next if $p =~ /^_/ || $self->{fieldrefs}{$p};
849 32         53 push @keep, $p;
850             }
851             }
852              
853             # In array context, we just return names we've resolved
854 10 50       32 return @keep if wantarray;
855              
856             # Make sure to get all values
857 10         24 for my $p (@keep) {
858 40 50       238 my @values = $self->{params}->can('multi_param') ? $self->{params}->multi_param($p) : $self->{params}->param($p);
859 40         1251 for my $v (@values) {
860 40         145 debug 1, "keepextras: saving hidden param $p = $v";
861 40         97 push @html, htmltag('input', name => $p, type => 'hidden', value => $v);
862             }
863             }
864 10         86 return join "\n", @html; # wantarray above
865             }
866              
867             sub javascript {
868 165     165 1 337 my $self = shift;
869 165 100       405 $self->{javascript} = shift if @_;
870              
871             # auto-determine javascript setting based on user agent
872 165 100       574 if (lc($self->{javascript}) eq 'auto') {
873 150 50 33     602 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         502 return 1;
880             }
881 15 50       82 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 216 my $self = shift;
893             return $self->{name}
894             ? (join '_', $self->{jsname}, tovar($self->{name}))
895 132 100       618 : $self->{jsname};
896             }
897              
898             sub script {
899 132     132 0 247 my $self = shift;
900              
901             # get validate() function name
902 132   33     426 my $jsname = $self->jsname || puke "Must have 'jsname' if 'javascript' is on";
903 132   50     709 my $jspre = $self->jsprefix || '';
904              
905             # "counter"
906 132         352 $self->{_didscript} = 1;
907 132 100       477 return '' unless $self->javascript;
908              
909             # code for misc non-validate functions
910 120         388 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     747 my $jsfunc = $self->jsfunc || '';
915 120   50     545 my $jshead = $self->jshead || '';
916              
917             # expand per-field validation functions, but
918             # only if we are not using Data::FormValidator
919 120 50       730 unless (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
920 120         416 for ($self->field) {
921 353         1221 $jsfunc .= $_->script;
922             }
923             }
924            
925             # skip out if we have nothing useful
926 120 100 100     1024 return '' unless $jsfunc || $jsmisc || $jshead;
      66        
927              
928             # prefix with opening code
929 38 100       121 if ($jsfunc) {
930 33         101 $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       231 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 221 my $self = shift;
983 120 100       439 return '' unless my @growable = grep { $_->growable } $self->field;
  353         907  
984              
985 2   50     9 my $jspre = $self->jsprefix || '';
986 2         5 my $jsmisc = '';
987              
988 2         8 my $grow = $self->growname;
989 2         11 $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       6 $jsmisc .= "${jspre}counter['$_'] = $count;\n" if $count > 0;
1030             # assume that values of growable > 1 provide limits
1031 2         6 my $limit = $_->growable;
1032 2 50 33     17 if ($limit && $limit ne 1) {
1033 0         0 $jsmisc .= "${jspre}limit['$_'] = $limit;\n";
1034             }
1035             }
1036 2         9 return $jsmisc;
1037             }
1038              
1039             sub script_otherbox {
1040 120     120 0 292 my $self = shift;
1041 120 100       366 return '' unless my @otherable = grep { $_->other } $self->field;
  353         998  
1042              
1043 5   50     18 my $jspre = $self->jsprefix || '';
1044 5         13 my $jsmisc = '';
1045            
1046 5         21 $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         13 return $jsmisc;
1061             }
1062              
1063             sub noscript {
1064 15     15 0 34 my $self = shift;
1065             # no state is kept and no args are allowed
1066 15 50       70 puke "No args allowed for \$form->noscript" if @_;
1067 15 50       44 return '' unless $self->javascript;
1068 15         108 return '';
1069             }
1070              
1071             sub submits {
1072 123     123 0 359 local $^W = 0; # -w sucks
1073 123         274 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         274 my @submit = ();
1079 123         330 my $sn = $self->{submitname};
1080 123         390 my $sc = $self->class($self->{buttonname});
1081 123 100       418 if (ref $self->{submit} eq 'ARRAY') {
1082             # multiple buttons + JavaScript - dynamically set the _submit value
1083 17 50       62 my @oncl = $self->javascript
1084             ? (onclick => "this.form.$sn.value = this.value;") : ();
1085 17         41 my $i=1;
1086 17         92 for my $subval (autodata $self->{submit}) {
1087 40 100       147 my $si = $i > 1 ? "_$i" : ''; # number with second one
1088 40         261 push @submit, { type => 'submit',
1089             id => "$self->{name}$sn$si",
1090             class => $sc,
1091             name => $sn,
1092             value => $subval, @oncl };
1093 40         91 $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       847 : $self->{submit};
1099 106         898 push @submit, { type => 'submit',
1100             id => "$self->{name}$sn",
1101             class => $sc,
1102             name => $sn,
1103             value => $subval };
1104             }
1105 123 100       595 return wantarray ? @submit : [ map { htmltag('input', $_) } @submit ];
  3         12  
1106             }
1107              
1108             sub submit {
1109 128     128 1 252 my $self = shift;
1110 128 50       340 $self->{submit} = shift if @_;
1111 128 100 66     1052 return '' if ! $self->{submit} || $self->static || $self->disabled;
      100        
1112              
1113             # no newline on buttons regardless of setting
1114 122         510 return join '', map { htmltag('input', $_) } $self->submits(@_);
  143         535  
1115             }
1116              
1117             sub reset {
1118 129     129 1 499 local $^W = 0; # -w sucks
1119 129         296 my $self = shift;
1120 129 50       358 $self->{reset} = shift if @_;
1121 129 50 66     945 return '' if ! $self->{reset} || $self->static || $self->disabled;
      66        
1122 5         17 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       31 : $self->{reset};
1127 5         28 my $rn = $self->resetname;
1128 5         28 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 126 my $self = shift;
1137 59 50       145 $self->{text} = shift if @_;
1138            
1139             # having any required fields changes the leading text
1140 59         116 my $req = 0;
1141 59         125 my $inv = 0;
1142 59         192 for ($self->fields) {
1143 173 100       689 $req++ if $_->required;
1144 173 100       632 $inv++ if $_->invalid; # failed validate()
1145             }
1146              
1147 59 100 100     307 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       154 $inv,
1151             $self->invalid_tag).'

' if $inv;
1152              
1153 54 100       563 if ($req) {
1154 13         110 my $form_required_text = $self->{messages}->form_required_text;
1155 13 100       84 $form_required_text = sprintf($form_required_text, $self->required_tag)
1156             if $form_required_text =~ /%/;
1157 13         76 return $self->{text} ."

$form_required_text

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