File Coverage

lib/CGI/FormBuilder.pm
Criterion Covered Total %
statement 556 785 70.8
branch 262 440 59.5
condition 95 190 50.0
subroutine 56 68 82.3
pod 36 58 62.0
total 1005 1541 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   180963 use Carp;
  11         30  
  11         1002  
12 11     11   64 use strict;
  11         21  
  11         434  
13 11     11   56 use warnings;
  11         25  
  11         400  
14 11     11   55 no warnings 'uninitialized';
  11         19  
  11         506  
15 11     11   144 use Scalar::Util qw(weaken);
  11         20  
  11         1334  
16              
17 11     11   8485 use CGI::FormBuilder::Util;
  11         30  
  11         1745  
18 11     11   10382 use CGI::FormBuilder::Field;
  11         36  
  11         512  
19 11     11   20299 use CGI::FormBuilder::Messages;
  11         29  
  11         174813  
20              
21             our $VERSION = '3.09';
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 5740 local $^W = 0; # -w sucks
101 135         306 my $self = shift;
102              
103             # A single arg is a source; others are opt => val pairs
104 135         228 my %opt;
105 135 100       438 if (@_ == 1) {
106 3         21 %opt = UNIVERSAL::isa($_[0], 'HASH')
107 3 50       20 ? %{ $_[0] }
108             : ( source => shift() );
109             } else {
110 132         710 %opt = arghash(@_);
111             }
112              
113             # Pre-check for an external source
114 135 100       684 if (my $src = delete $opt{source}) {
115              
116             # check for engine type
117 23         51 my $mod;
118             my $sopt; # opts returned from parsing
119 23         53 my $ref = ref $src;
120 23 50       68 unless ($ref) {
121             # string filename; redo format (ala $self->{template})
122 0 0 0     0 $src = {
123             type => 'File',
124             source => $src,
125             # pass catalyst class for \&validate refs
126             ($opt{c} && $opt{c}->action)
127             ? (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     119 debug 1, "creating form from source ", $ref || $src;
133              
134 23 50       67 if ($ref eq 'HASH') {
    0          
    0          
    0          
135             # grab module
136 23   100     96 $mod = delete $src->{type} || 'File';
137              
138             # user can give 'Their::Complete::Module' or an 'IncludedTemplate'
139 23 50       162 $mod = join '::', __PACKAGE__, 'Source', $mod unless $mod =~ /::/;
140 23         109 debug 1, "loading $mod for 'source' option";
141              
142 23         2409 eval "require $mod";
143 23 50       129 puke "Bad source module $mod: $@" if $@;
144              
145 23         217 my $sob = $mod->new(%$src);
146 23         114 $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         131 while (my($k,$v) = each %$sopt) {
159 135 50       627 $opt{$k} = $v unless exists $opt{$k};
160             }
161             }
162              
163 135 100       380 if (ref $self) {
164             # cloned/original object
165 1         5 debug 1, "rewriting existing FormBuilder object";
166 1         6 while (my($k,$v) = each %opt) {
167 1         7 $self->{$k} = $v;
168             }
169             } else {
170 134         486 debug 1, "constructing new FormBuilder object";
171             # damn deep copy this is SO damn annoying
172 134         749 while (my($k,$v) = each %DEFAULT) {
173 5896 100       18147 next if exists $opt{$k};
174 5618 100       13918 if (ref $v eq 'HASH') {
    50          
175 922         4404 $opt{$k} = { %$v };
176             } elsif (ref $v eq 'ARRAY') {
177 0         0 $opt{$k} = [ @$v ];
178             } else {
179 4696         18792 $opt{$k} = $v;
180             }
181             }
182 134         557 $self = bless \%opt, $self;
183             }
184              
185             # Create our CGI object if not present
186 135 100       711 unless (ref $self->{params}) {
187 131         36889 require CGI;
188 131         183381 $CGI::USE_PARAM_SEMICOLONS = 0; # fuck ; in urls
189 131         1088 $self->{params} = CGI->new($self->{params});
190             }
191              
192             # XXX not mod_perl safe
193 135   33     169506 $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       820 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       14 if (UNIVERSAL::isa($self->{params}, 'CGI')) {
    0          
    0          
202 2         49 $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 0   0     0 $lang = $ENV{HTTP_ACCEPT_LANGUAGE}
210             || $ENV{LC_MESSAGES} || $ENV{LC_ALL} || $ENV{LANG};
211             }
212 2   50     413 $lang ||= 'default';
213 2         15 $self->{messages} = CGI::FormBuilder::Messages->new(":$lang");
214             } else {
215             # ref or filename (::Messages will decode)
216 133         1181 $self->{messages} = CGI::FormBuilder::Messages->new($self->{messages});
217             }
218              
219             # Initialize form fields (probably a good idea)
220 135 100       617 if ($self->{fields}) {
221 109         456 debug 1, "creating fields list";
222              
223             # check to see if 'fields' is a hash or array ref
224 109         316 my $ref = ref $self->{fields};
225 109 100 100     700 if ($ref && $ref eq 'HASH') {
226             # with a hash ref, we setup keys/values
227 4         21 debug 2, "got fields list from HASH";
228 4         8 while(my($k,$v) = each %{$self->{fields}}) {
  12         61  
229 8         19 $k = lc $k; # must lc to ignore case
230 8         29 $self->{values}{$k} = [ autodata $v ];
231             }
232             # reset main fields to field names
233 4         8 $self->{fields} = [ sort keys %{$self->{fields}} ];
  4         29  
234             } else {
235             # rewrite fields to ensure format
236 105         329 debug 2, "assuming fields list from ARRAY";
237 105         513 $self->{fields} = [ autodata $self->{fields} ];
238             }
239             }
240              
241 135 50       818 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       877 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       50 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         9 $self->{required} = [ @{$self->{fields}} ];
  6         27  
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         52 $self->{required} = [ keys %{$self->{validate}} ];
  28         128  
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         354 my @ftmp = ();
270 135         228 for (@{$self->{fields}}) {
  135         1109  
271 304 100       490 my %fprop = %{$self->{fieldopts}{$_} || {}}; # field properties
  304         1964  
272              
273 304 50       859 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         725 $fprop{name} = "$_";
279 304         1030 $_ = $self->new_field(%fprop);
280 304         1174 weaken($_->{_form});
281             }
282 304         1055 debug 2, "push \@(@ftmp), $_";
283 304         1390 weaken($self->{fieldrefs}{"$_"} = $_);
284 304         1028 push @ftmp, $_;
285             }
286              
287             # stringifiable objects (overwrite previous container)
288 135         385 $self->{fields} = \@ftmp;
289              
290             # setup values
291 135 100       605 $self->values($self->{values}) if $self->{values};
292              
293 135         636 debug 1, "field creation done, list = (@ftmp)";
294              
295 135         753 return $self;
296             }
297              
298             *param = \&field;
299             *params = \&field;
300             *fields = \&field;
301             sub field {
302 1096     1096 1 8689 local $^W = 0; # -w sucks
303 1096         1602 my $self = shift;
304 1096         4408 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     3663 return $self->new(fields => $_[0])
314             if ref $_[0] eq 'ARRAY' && @_ == 1;
315              
316 1095 100       2549 my $name = (@_ % 2 == 0) ? '' : shift();
317 1095         3521 my $args = arghash(@_);
318 1095   100     5358 $args->{name} ||= $name;
319              
320             # no name - return ala $cgi->param
321 1095 100       2592 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       1662 if (wantarray) {
326             # pre-scan for any "order" arguments, reorder, delete
327 952         1123 for my $redo (grep { $_->order } @{$self->{fields}}) {
  2732         13296  
  952         2242  
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 0       0  
339             # start
340 0         0 unshift @{$self->{fields}}, $redo;
  0         0  
341             } 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         2085 debug 2, "return (@{$self->{fields}})";
  952         9442  
354 952         1668 return @{$self->{fields}};
  952         5722  
355             } else {
356             # this only returns a single scalar value for each field
357 1         3 return { map { $_ => scalar($_->value) } @{$self->{fields}} };
  8         28  
  1         3  
358             }
359             }
360              
361             # have name, so redispatch to field member
362 142         693 debug 2, "searching fields for '$args->{name}'";
363 142 50       837 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         210 delete $args->{name}; # segfault??
371 92         404 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       209 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         164 my $f = $self->new_field(%$args);
380 42         157 weaken($self->{fieldrefs}{"$f"} = $f);
381 42         152 weaken($f->{_form});
382 42         157 weaken($f->{fieldrefs}{"$f"});
383 42         94 push @{$self->{fields}}, $f;
  42         111  
384            
385 42         158 return $f->value;
386             }
387              
388             sub new_field {
389 346     346 0 651 my $self = shift;
390 346         989 my $args = arghash(@_);
391 346 50       1029 puke "Need a name for \$form->new_field()" unless exists $args->{name};
392 346         1785 debug 1, "called \$form->new_field($args->{name})";
393              
394             # extract our per-field options from rearrange
395 346         1456 while (my($from,$to) = each %REARRANGE) {
396 4498 100       14378 next unless exists $self->{$from};
397 1749 100       3730 next if defined $args->{$to}; # manually set
398 1745         5027 my $tval = rearrange($self->{$from}, $args->{name});
399 1745         6138 debug 2, "rearrange: \$args->{$to} = $tval;";
400 1745         8414 $args->{$to} = $tval;
401             }
402              
403 346 100 66     1074 $args->{type} = lc $self->{fieldtype}
404             if $self->{fieldtype} && ! exists $args->{type};
405 346 100       794 if ($self->{fieldattr}) { # legacy
406 11         18 while (my($k,$v) = each %{$self->{fieldattr}}) {
  22         90  
407 11 50       33 next if exists $args->{$k};
408 11         30 $args->{$k} = $v;
409             }
410             }
411            
412 346         1720 my $f = CGI::FormBuilder::Field->new($self, $args);
413 346         1811 debug 1, "created field $f";
414 346         891 return $f; # already set args above ^^^
415             }
416              
417             *fieldset = \&fieldsets;
418             sub fieldsets {
419 258     258 1 432 my $self = shift;
420 258 50       646 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         315 my(%legends, @sets);
448 258         1440 for (optalign($self->{fieldsets})) {
449 270         753 my($o,$n) = optval($_);
450 270 50       781 next if exists $legends{$o};
451 270         471 push @sets, $o;
452 270         1146 debug 2, "added fieldset $o (legend=$n) to \@sets";
453 270         927 $legends{$o} = $n;
454             }
455              
456             # find *all* our fieldsets, even hidden in fields w/o Human Tags
457 258         837 for ($self->field) {
458 748 100       3855 next unless my $o = $_->fieldset;
459 44 100       138 next if exists $legends{$o};
460 4         9 push @sets, $o;
461 4         21 debug 2, "added fieldset $o (legend=undef) to \@sets";
462 4         13 $legends{$o} = $o; # use fieldset as
463             }
464 258 100       1472 return wantarray ? @sets : \%legends;
465             }
466              
467             sub fieldlist {
468 59     59 0 115 my $self = shift;
469 59 50       256 my @fields = @_ ? @_ : $self->field;
470 59         124 my(%saw, @ret);
471 59         212 for my $set ($self->fieldsets) {
472             # reorder fields
473 63         131 for (@fields) {
474 213 100       594 next if $saw{$_};
475 194 100 100     929 if ($_->fieldset && $_->fieldset eq $set) {
476             # if this field is in this fieldset, regroup
477 11         18 push @ret, $_;
478 11         39 debug 2, "added field $_ to field order (fieldset=$set)";
479 11         34 $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         159 for (@fields) {
488 173         527 debug 2, "appended non-fieldset field $_ to form";
489 173 100       462 push @ret, $_ unless $saw{$_};
490             }
491              
492 59 50       357 return wantarray ? @ret : \@ret;
493             }
494              
495             sub header {
496 123     123 1 427 my $self = shift;
497 123 50       565 $self->{header} = shift if @_;
498 123 100       624 return unless $self->{header};
499 29         63 my %head;
500 29 100 66     206 if ($self->{cookies} && defined(my $sid = $self->sessionid)) {
501 3         47 require CGI::Cookie;
502 3         70 $head{'-cookie'} = CGI::Cookie->new(-name => $self->{sessionidname},
503             -value => $sid);
504             }
505             # Set the charset for i18n
506 29         1646 $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       217 return "Content-type: text/html\n\n" if $::TESTING;
511 1         9 require CGI;
512 1         37 return CGI::header(%head); # CGI.pm MOD_PERL fanciness
513             }
514              
515             sub charset {
516 32     32 1 362 my $self = shift;
517 32 100       94 $self->{charset} = shift if @_;
518 32   50     338 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     26 return $self->{lang} || $self->{messages}->lang || 'en_US';
525             }
526              
527             sub dtd {
528 15     15 0 31 my $self = shift;
529 15 50       49 $self->{dtd} = shift if @_;
530 15 100       89 return '' if $::TESTING;
531              
532             # replace special chars in dtd by exec'ing subs
533 1         5 my $dtd = $self->{dtd};
534 1         7 $dtd =~ s/\{(\w+)\}/$self->$1/ge;
  3         9  
535 1         5 return $dtd;
536             }
537              
538             sub title {
539 127     127 1 217 my $self = shift;
540 127 50       383 $self->{title} = shift if @_;
541 127 100       716 return $self->{title} if exists $self->{title};
542 6         30 return toname(basename);
543             }
544              
545             *script_name = \&action;
546             sub action {
547 9     9 1 37 local $^W = 0; # -w sucks (still)
548 9         36 my $self = shift;
549 9 50       37 $self->{action} = shift if @_;
550 9 100       90 return $self->{action} if exists $self->{action};
551 8         35 return basename . $ENV{PATH_INFO};
552             }
553              
554             sub font {
555 339     339 1 471 my $self = shift;
556 339 50       794 $self->{font} = shift if @_;
557 339 100       1672 return '' unless $self->{font};
558 2 50       13 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 291 my $self = shift;
578 129         2561 my %attr = htmlattr('form', %$self);
579              
580 129   66     957 $attr{action} ||= $self->action;
581 129   33     358 $attr{method} ||= $self->method;
582 129         379 $attr{method} = lc($attr{method}); # xhtml
583 129 100       432 $self->disabled ? $attr{disabled} = 'disabled' : delete $attr{disabled};
584 129   66     1013 $attr{class} ||= $self->class($self->formname);
585              
586             # Bleech, there's no better way to do this...?
587 129 50       580 belch "You should really call \$form->script BEFORE \$form->start"
588             unless $self->{_didscript};
589              
590             # A catch for lowercase actions
591 129 50       347 belch "Old-style 'onSubmit' action found - should be 'onsubmit'"
592             if $attr{onSubmit};
593              
594 129         495 return $self->version . htmltag('form', %attr);
595             }
596              
597             sub end {
598 70     70 0 213 return '';
599             }
600              
601             # Need to wrap this or else AUTOLOAD whines (OURATTR missing)
602             sub disabled {
603 690     690 0 1081 my $self = shift;
604 690 50       1757 $self->{disabled} = shift if @_;
605 690 100       3281 return $self->{disabled} ? 'disabled' : undef;
606             }
607            
608             sub body {
609 14     14 1 32 my $self = shift;
610 14 50       36 $self->{body} = shift if @_;
611 14 100 100     79 $self->{body}{bgcolor} ||= 'white' unless $self->{stylesheet};
612 14         51 return htmltag('body', $self->{body});
613             }
614              
615             sub class {
616 1490     1490 0 2482 my $self = shift;
617 1490 100       5716 return undef unless $self->{stylesheet};
618 307         1274 return join '', $self->{styleclass}, @_; # remainder is optional tag
619             }
620              
621             sub idname {
622 752     752 0 1117 my $self = shift;
623 752 100       2114 $self->{id} = $self->{name}
624             unless defined $self->{id};
625 752 100       3552 return undef unless $self->{id};
626 184         914 return join '', $self->{id}, @_; # remainder is optional tag
627             }
628              
629             sub table {
630 106     106 1 204 my $self = shift;
631              
632             # single hashref kills everything; a list is temporary
633 106 50       301 $self->{table} = shift if @_ == 1;
634 106 100       331 return unless $self->{table};
635              
636             # set defaults for numeric table => 1
637 104 100       321 $self->{table} = $DEFAULT{table} if $self->{table} == 1;
638              
639 104         235 my $attr = $self->{table};
640 104 100       301 if (@_) {
641             # if still have args, create a temp hash
642 100         272 my %temp = %$attr;
643 100         288 while (my $k = shift) {
644 156         511 $temp{$k} = shift;
645             }
646 100         220 $attr = \%temp;
647             }
648              
649 104 50       363 return unless $self->{table}; # 0 or unset via table(0)
650 104   100     461 $attr->{class} ||= $self->class;
651 104         475 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         374 my $attr = $self->{tr};
661 218 50       488 if (@_) {
662             # if still have args, create a temp hash
663 218         490 my %temp = %$attr;
664 218         688 while (my $k = shift) {
665 218         856 $temp{$k} = shift;
666             }
667 218         423 $attr = \%temp;
668             }
669              
670             # reduced formatting
671 218 100       583 if ($self->{stylesheet}) {
672             # extraneous - inherits from
673             #$attr->{class} ||= $self->class($self->{rowname});
674             } else {
675 168   100     785 $attr->{valign} ||= 'top';
676             }
677              
678 218         755 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 488 my $self = shift;
710              
711             # single hashref kills everything; a list is temporary
712 383 50 33     1030 $self->{td} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
713              
714 383         589 my $attr = $self->{td};
715 383 50       878 if (@_) {
716             # if still have args, create a temp hash
717 383         787 my %temp = %$attr;
718 383         1329 while (my $k = shift) {
719 863         3096 $temp{$k} = shift;
720             }
721 383         672 $attr = \%temp;
722             }
723              
724             # extraneous - inherits from
725             #$attr->{class} ||= $self->class($self->{fieldname});
726              
727 383         1198 return htmltag('td', $attr);
728             }
729              
730             sub div {
731 90     90 0 222 my $self = shift;
732              
733             # single hashref kills everything; a list is temporary
734 90 50 33     266 $self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');
735              
736 90         211 my $attr = $self->{div};
737 90 50       225 if (@_) {
738             # if still have args, create a temp hash
739 90         241 my %temp = %$attr;
740 90         262 while (my $k = shift) {
741 172         525 $temp{$k} = shift;
742             }
743 90         198 $attr = \%temp;
744             }
745              
746 90         309 return htmltag('div', $attr);
747             }
748              
749             sub submitted {
750 13     13 1 88 my $self = shift;
751 13   33     123 my $smnam = shift || $self->submittedname; # temp smnam
752 13 100       45 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
753              
754 13 100       58 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     286 my $sr = $self->{params}->param($self->submitname) || '0E0';
761 11         216 debug 2, "\$form->submitted() is true, returning $sr";
762 11         31 return $sr;
763             }
764 2         37 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 8829 my $self = shift;
786 159 100       454 $self->{sessionid} = shift if @_;
787 159 100       1025 return $self->{sessionid} if $self->{sessionid};
788 153 50       391 return undef unless $self->{sessionidname};
789 153         179 my %cookies;
790 153 50       513 if ($self->{cookies}) {
791 153         12592 require CGI::Cookie;
792 153         29530 %cookies = CGI::Cookie->fetch;
793             }
794 153 50       2645 if (my $cook = $cookies{"$self->{sessionidname}"}) {
795 0         0 return $cook->value;
796             } else {
797 153   50     690 return $self->{params}->param($self->{sessionidname}) || undef;
798             }
799             }
800              
801             sub statetags {
802 129     129 0 220 my $self = shift;
803 129         339 my @html = ();
804              
805             # get _submitted
806 129         675 my $smnam = $self->submittedname;
807 129 100       469 my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
808 129         735 my $smval = $self->{params}->param($smnam) + 1;
809 129         3153 push @html, htmltag('input', name => $smtag, value => $smval, type => 'hidden');
810              
811             # and how about _sessionid
812 129 100       530 if (defined(my $sid = $self->sessionid)) {
813 2         8 push @html, htmltag('input', name => $self->{sessionidname},
814             type => 'hidden', value => $sid);
815             }
816              
817             # and what page (hooks for ::Multi)
818 129 100       2991 if (defined $self->{page}) {
819 2         16 push @html, htmltag('input', name => $self->pagename,
820             type => 'hidden', value => $self->{page});
821             }
822              
823 129 50       1040 return wantarray ? @html : join "\n", @html;
824             }
825              
826             *keepextra = \&keepextras;
827             sub keepextras {
828 129     129 1 434 local $^W = 0; # -w sucks
829 129         217 my $self = shift;
830 129         236 my @keep = ();
831 129         218 my @html = ();
832              
833             # which ones do they want?
834 129 50       397 $self->{keepextras} = shift if @_;
835 129 100       782 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     53 my $ref = ref $self->{keepextras} || '';
840 10 100       36 if ($ref eq 'ARRAY') {
    50          
841 4         7 @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         26 for my $p ($self->{params}->param) {
848 50 100 100     466 next if $p =~ /^_/ || $self->{fieldrefs}{$p};
849 32         51 push @keep, $p;
850             }
851             }
852              
853             # In array context, we just return names we've resolved
854 10 50       34 return @keep if wantarray;
855              
856             # Make sure to get all values
857 10         22 for my $p (@keep) {
858 40         144 for my $v ($self->{params}->param($p)) {
859 40         853 debug 1, "keepextras: saving hidden param $p = $v";
860 40         110 push @html, htmltag('input', name => $p, type => 'hidden', value => $v);
861             }
862             }
863 10         82 return join "\n", @html; # wantarray above
864             }
865              
866             sub javascript {
867 165     165 1 298 my $self = shift;
868 165 100       441 $self->{javascript} = shift if @_;
869              
870             # auto-determine javascript setting based on user agent
871 165 100       611 if (lc($self->{javascript}) eq 'auto') {
872 150 50 33     631 if (exists $ENV{HTTP_USER_AGENT}
873             && $ENV{HTTP_USER_AGENT} =~ /lynx|mosaic/i)
874             {
875             # Turn off for old/non-graphical browsers
876 0         0 return 0;
877             }
878 150         510 return 1;
879             }
880 15 50       110 return $self->{javascript} if exists $self->{javascript};
881              
882             # Turn on for all other browsers by default.
883             # I suspect this process should be reversed, only
884             # showing JavaScript on those browsers we know accept
885             # it, but maintaining a full list will result in this
886             # module going out of date and having to be updated.
887 0         0 return 1;
888             }
889              
890             sub jsname {
891 132     132 0 225 my $self = shift;
892 132 100       903 return $self->{name}
893             ? (join '_', $self->{jsname}, tovar($self->{name}))
894             : $self->{jsname};
895             }
896              
897             sub script {
898 132     132 0 248 my $self = shift;
899              
900             # get validate() function name
901 132   33     468 my $jsname = $self->jsname || puke "Must have 'jsname' if 'javascript' is on";
902 132   50     772 my $jspre = $self->jsprefix || '';
903              
904             # "counter"
905 132         366 $self->{_didscript} = 1;
906 132 100       444 return '' unless $self->javascript;
907              
908             # code for misc non-validate functions
909 120         417 my $jsmisc = $self->script_growable # code to grow growable fields, if any
910             . $self->script_otherbox; # code to enable/disable the "other" box
911              
912             # custom user jsfunc option for w/i validate()
913 120   100     672 my $jsfunc = $self->jsfunc || '';
914 120   50     696 my $jshead = $self->jshead || '';
915              
916             # expand per-field validation functions, but
917             # only if we are not using Data::FormValidator
918 120 50       703 unless (UNIVERSAL::isa($self->{validate}, 'Data::FormValidator')) {
919 120         313 for ($self->field) {
920 353         1370 $jsfunc .= $_->script;
921             }
922             }
923            
924             # skip out if we have nothing useful
925 120 100 100     1814 return '' unless $jsfunc || $jsmisc || $jshead;
      66        
926              
927             # prefix with opening code
928 38 100       97 if ($jsfunc) {
929 33         181 $jsfunc = <
930             function $jsname (form) {
931             var alertstr = '';
932             var invalid = 0;
933             var invalid_fields = new Array();
934              
935             EOJ1
936             if (invalid > 0 || alertstr != '') {
937             EOJ2
938              
939             # Check to see if we have our own jserror callback on form failure
940             # if not, then use the builtin one. Aka jsalert
941 33 50       183 if (my $jse = $self->jserror) {
942 0         0 $jsfunc .= " return $jse(form, invalid, alertstr, invalid_fields);\n";
943             } else {
944             # Finally, close our JavaScript if it was opened, wrapping in ";
978             }
979              
980             sub script_growable {
981 120     120 0 217 my $self = shift;
982 120 100       526 return '' unless my @growable = grep { $_->growable } $self->field;
  353         1133  
983              
984 2   50     9 my $jspre = $self->jsprefix || '';
985 2         5 my $jsmisc = '';
986              
987 2         6 my $grow = $self->growname;
988 2         21 $jsmisc .= <
989             var ${jspre}counter = new Object; // for assigning unique ids; keyed by field name
990             var ${jspre}limit = new Object; // for limiting the size of growable fields
991             function ${jspre}grow (baseID) {
992             // inititalize the counter for this ID
993             if (isNaN(${jspre}counter[baseID])) ${jspre}counter[baseID] = 1;
994              
995             // don't go past the growth limit for this field
996             if (${jspre}counter[baseID] >= ${jspre}limit[baseID]) return;
997              
998             var base = document.getElementById(baseID + '_' + (${jspre}counter[baseID] - 1));
999              
1000             // we are inserting after the last field
1001             insertPoint = base.nextSibling;
1002              
1003             // line break
1004             base.parentNode.insertBefore(document.createElement('br'), insertPoint);
1005              
1006             var dup = base.cloneNode(true);
1007              
1008             dup.setAttribute('id', baseID + '_' + ${jspre}counter[baseID]);
1009             base.parentNode.insertBefore(dup, insertPoint);
1010              
1011             // add some padding space between the field and the "add field" button
1012             base.parentNode.insertBefore(document.createTextNode(' '), insertPoint);
1013              
1014             ${jspre}counter[baseID]++;
1015              
1016             // disable the "add field" button if we are at the limit
1017             if (${jspre}counter[baseID] >= ${jspre}limit[baseID]) {
1018             var addButton = document.getElementById('$grow' + '_' + baseID);
1019             addButton.setAttribute('disabled', 'disabled');
1020             }
1021             }
1022              
1023             EOJS
1024              
1025             # initialize growable counters
1026 2         5 for (@growable) {
1027 2         12 my $count = scalar(my @v = $_->values);
1028 2 50       8 $jsmisc .= "${jspre}counter['$_'] = $count;\n" if $count > 0;
1029             # assume that values of growable > 1 provide limits
1030 2         6 my $limit = $_->growable;
1031 2 50 33     16 if ($limit && $limit ne 1) {
1032 0         0 $jsmisc .= "${jspre}limit['$_'] = $limit;\n";
1033             }
1034             }
1035 2         10 return $jsmisc;
1036             }
1037              
1038             sub script_otherbox {
1039 120     120 0 232 my $self = shift;
1040 120 100       337 return '' unless my @otherable = grep { $_->other } $self->field;
  353         1004  
1041              
1042 5   50     24 my $jspre = $self->jsprefix || '';
1043 5         12 my $jsmisc = '';
1044            
1045 5         24 $jsmisc .= <
1046             // turn on/off any "other"fields
1047             function ${jspre}other_on (othername) {
1048             var box = document.getElementById(othername);
1049             box.removeAttribute('disabled');
1050             }
1051              
1052             function ${jspre}other_off (othername) {
1053             var box = document.getElementById(othername);
1054             box.setAttribute('disabled', 'disabled');
1055             }
1056              
1057             EOJS
1058              
1059 5         24 return $jsmisc;
1060             }
1061              
1062             sub noscript {
1063 15     15 0 32 my $self = shift;
1064             # no state is kept and no args are allowed
1065 15 50       65 puke "No args allowed for \$form->noscript" if @_;
1066 15 50       89 return '' unless $self->javascript;
1067 15         117 return '';
1068             }
1069              
1070             sub submits {
1071 123     123 0 324 local $^W = 0; # -w sucks
1072 123         203 my $self = shift;
1073              
1074             # handle the submit button(s)
1075             # logic is a little complicated - if set but to a false value,
1076             # then leave off. otherwise use as the value for the tags.
1077 123         270 my @submit = ();
1078 123         257 my $sn = $self->{submitname};
1079 123         484 my $sc = $self->class($self->{buttonname});
1080 123 100       425 if (ref $self->{submit} eq 'ARRAY') {
1081             # multiple buttons + JavaScript - dynamically set the _submit value
1082 17 50       69 my @oncl = $self->javascript
1083             ? (onclick => "this.form.$sn.value = this.value;") : ();
1084 17         39 my $i=1;
1085 17         79 for my $subval (autodata $self->{submit}) {
1086 40 100       123 my $si = $i > 1 ? "_$i" : ''; # number with second one
1087 40         244 push @submit, { type => 'submit',
1088             id => "$self->{name}$sn$si",
1089             class => $sc,
1090             name => $sn,
1091             value => $subval, @oncl };
1092 40         106 $i++;
1093             }
1094             } else {
1095             # show the text on the button
1096 106 100       1021 my $subval = $self->{submit} eq 1 ? $self->{messages}->form_submit_default
1097             : $self->{submit};
1098 106         925 push @submit, { type => 'submit',
1099             id => "$self->{name}$sn",
1100             class => $sc,
1101             name => $sn,
1102             value => $subval };
1103             }
1104 123 100       1009 return wantarray ? @submit : [ map { htmltag('input', $_) } @submit ];
  3         7  
1105             }
1106              
1107             sub submit {
1108 128     128 1 247 my $self = shift;
1109 128 50       365 $self->{submit} = shift if @_;
1110 128 100 66     938 return '' if ! $self->{submit} || $self->static || $self->disabled;
      100        
1111              
1112             # no newline on buttons regardless of setting
1113 122         526 return join '', map { htmltag('input', $_) } $self->submits(@_);
  143         633  
1114             }
1115              
1116             sub reset {
1117 129     129 1 413 local $^W = 0; # -w sucks
1118 129         255 my $self = shift;
1119 129 50       374 $self->{reset} = shift if @_;
1120 129 50 66     914 return '' if ! $self->{reset} || $self->static || $self->disabled;
      66        
1121 5         24 my $sc = $self->class($self->{buttonname});
1122              
1123             # similar to submit(), but a little simpler ;-)
1124 5 100       34 my $reset = $self->{reset} eq 1 ? $self->{messages}->form_reset_default
1125             : $self->{reset};
1126 5         36 my $rn = $self->resetname;
1127 5         32 return htmltag('input', type => 'reset',
1128             id => "$self->{name}$rn",
1129             class => $sc,
1130             name => $rn,
1131             value => $reset);
1132             }
1133              
1134             sub text {
1135 59     59 1 94 my $self = shift;
1136 59 50       194 $self->{text} = shift if @_;
1137            
1138             # having any required fields changes the leading text
1139 59         86 my $req = 0;
1140 59         99 my $inv = 0;
1141 59         160 for ($self->fields) {
1142 173 100       806 $req++ if $_->required;
1143 173 100       991 $inv++ if $_->invalid; # failed validate()
1144             }
1145              
1146 59 100 100     305 unless ($self->static || $self->disabled) {
1147             # only show either invalid or required text
1148 56 100       149 return $self->{text} .'

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

1149             $inv,
1150             $self->invalid_tag).'

' if $inv;
1151              
1152 54 100       217 return $self->{text} .'

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

1153             $self->required_tag).'

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