File Coverage

blib/lib/CGI/Test/Form.pm
Criterion Covered Total %
statement 209 295 70.8
branch 31 56 55.3
condition 16 37 43.2
subroutine 53 81 65.4
pod 2 55 3.6
total 311 524 59.3


line stmt bran cond sub pod time code
1             package CGI::Test::Form;
2 14     14   43 use strict;
  14         11  
  14         331  
3 14     14   42 use warnings;
  14         14  
  14         308  
4             ####################################################################
5             # $Id: Form.pm 411 2011-09-26 11:19:30Z nohuhu@nohuhu.org $
6             # $Name: cgi-test_0-104_t1 $
7             ####################################################################
8             # Copyright (c) 2001, Raphael Manfredi
9             #
10             # You may redistribute only under the terms of the Artistic License,
11             # as specified in the README file that comes with the distribution.
12             #
13              
14             #
15             # Class interfacing with the content of a
tag, which comes from
16             # a CGI::Test::Page object. The tree nodes we are playing with here are
17             # direct pointers into the node of the page object.
18             #
19              
20 14     14   35 use Carp;
  14         17  
  14         622  
21              
22             #
23             # We may not create an instance of all those classes, but the cost of
24             # lazily requiring them would probably outweigh the cost of loading
25             # them once and for all, on reasonably sized forms.
26             #
27 14     14   4773 use CGI::Test::Form::Widget::Button::Submit;
  14         16  
  14         295  
28 14     14   4761 use CGI::Test::Form::Widget::Button::Reset;
  14         24  
  14         259  
29 14     14   4576 use CGI::Test::Form::Widget::Button::Image;
  14         22  
  14         268  
30 14     14   4535 use CGI::Test::Form::Widget::Button::Plain;
  14         18  
  14         264  
31 14     14   4742 use CGI::Test::Form::Widget::Input::Text_Field;
  14         24  
  14         284  
32 14     14   4679 use CGI::Test::Form::Widget::Input::Text_Area;
  14         25  
  14         271  
33 14     14   4569 use CGI::Test::Form::Widget::Input::Password;
  14         22  
  14         281  
34 14     14   4579 use CGI::Test::Form::Widget::Input::File;
  14         24  
  14         272  
35 14     14   4666 use CGI::Test::Form::Widget::Menu::List;
  14         22  
  14         311  
36 14     14   5447 use CGI::Test::Form::Widget::Menu::Popup;
  14         23  
  14         270  
37 14     14   4748 use CGI::Test::Form::Widget::Box::Radio;
  14         22  
  14         270  
38 14     14   4598 use CGI::Test::Form::Widget::Box::Check;
  14         20  
  14         250  
39 14     14   4874 use CGI::Test::Form::Widget::Hidden;
  14         26  
  14         28225  
40              
41             ######################################################################
42             #
43             # ->new
44             #
45             # Creation routine
46             #
47             ######################################################################
48             sub new
49             {
50 16     16 0 35 my $this = bless {}, shift;
51 16         19 my ($node, $page) = @_;
52              
53 16         77 $this->{tree} = $node; # is the root node of the tree
54 16         25 $this->{page} = $page;
55              
56 16   50     40 $this->{enctype} = $node->attr("enctype")
57             || "application/x-www-form-urlencoded";
58 16   50     180 $this->{method} = uc $node->attr("method") || "POST";
59              
60 16         124 foreach my $attr (qw(action name accept accept-charset))
61             {
62 64         50 my $oattr = $attr;
63 64         99 $oattr =~ s/-/_/g;
64 64         100 my $value = $node->attr($attr);
65 64 100       367 $this->{$oattr} = $value if defined $value;
66             }
67              
68             #
69             # Although ACTION is now required in newer HTML DTDs, it was optional
70             # in HTML 2.0 and defaults to the base URI of the document.
71             #
72              
73 16 50       43 $this->{action} = $page->uri->as_string unless exists $this->{action};
74              
75 16         52 return $this;
76             }
77              
78             ######################################################################
79             # DEPRECATED
80             ######################################################################
81             sub make
82             { #
83 0     0 0 0 my $class = shift;
84 0         0 return $class->new(@_);
85             }
86              
87             #
88             # Attribute access
89             #
90              
91             ######################################################################
92             sub tree
93             {
94 16     16 0 15 my $this = shift;
95 16         66 return $this->{tree};
96             }
97              
98             ######################################################################
99             sub page
100             {
101 38     38 0 37 my $this = shift;
102 38         138 return $this->{page};
103             }
104              
105             ######################################################################
106             sub enctype
107             {
108 25     25 0 33 my $this = shift;
109 25         90 return $this->{enctype};
110             }
111              
112             ######################################################################
113             sub action
114             {
115 38     38 0 292 my $this = shift;
116 38         264 return $this->{action};
117             }
118              
119             ######################################################################
120             sub method
121             {
122 29     29 0 13265 my $this = shift;
123 29         111 return $this->{method};
124             }
125              
126             ######################################################################
127             sub name
128             {
129 0     0 0 0 my $this = shift;
130 0         0 return $this->{name};
131             }
132              
133             ######################################################################
134             sub accept
135             {
136 0     0 0 0 my $this = shift;
137 0         0 return $this->{accept};
138             }
139              
140             ######################################################################
141             sub accept_charset
142             {
143 0     0 0 0 my $this = shift;
144 0         0 return $this->{accept_charset};
145             }
146              
147             #
148             # Lazy attribute access
149             #
150              
151             ######################################################################
152             sub buttons
153             {
154 17     17 0 252 my $this = shift;
155 17   66     69 return $this->{buttons} || $this->_xtract("buttons");
156             }
157              
158             ######################################################################
159             sub inputs
160             {
161 19     19 0 23 my $this = shift;
162 19   33     52 return $this->{inputs} || $this->_xtract("inputs");
163             }
164              
165             ######################################################################
166             sub menus
167             {
168 15     15 0 245 my $this = shift;
169 15   33     48 return $this->{menus} || $this->_xtract("menus");
170             }
171              
172             ######################################################################
173             sub radios
174             {
175 8     8 0 15 my $this = shift;
176 8   66     68 return $this->{radios} || $this->_xtract("radios");
177             }
178              
179             ######################################################################
180             sub checkboxes
181             {
182 9     9 0 238 my $this = shift;
183 9   33     45 return $this->{checkboxes} || $this->_xtract("checkboxes");
184             }
185              
186             ######################################################################
187             sub hidden
188             {
189 0     0 0 0 my $this = shift;
190 0   0     0 return $this->{hidden} || $this->_xtract("hidden");
191             }
192              
193             ######################################################################
194             sub widgets
195             {
196 26     26 0 29 my $this = shift;
197 26   33     136 return $this->{widgets} || $this->_xtract("widgets");
198             }
199              
200             #
201             # Second-order lazy attributes
202             #
203              
204             ######################################################################
205             sub submits
206             {
207 20     20 0 16 my $this = shift;
208 20   66     81 return $this->{submits} || ($this->{submits} = $this->_submits);
209             }
210              
211             ######################################################################
212             sub radio_groups
213             {
214 1     1 0 284 my $this = shift;
215             return $this->radios()
216 1   33     3 && $this->{radio_groups};
217             }
218             ######################################################################
219             sub checkbox_groups
220             {
221 1     1 0 1 my $this = shift;
222             return $this->checkboxes()
223 1   33     2 && $this->{checkbox_groups};
224             }
225              
226             #
227             # Expanded lists -- syntactic sugar
228             #
229              
230             ######################################################################
231             sub button_list
232             {
233 0     0 0 0 my $this = shift;
234 0         0 return @{$this->buttons()};
  0         0  
235             }
236             ######################################################################
237             sub input_list
238             {
239 0     0 0 0 my $this = shift;
240 0         0 return @{$this->inputs()};
  0         0  
241             }
242             ######################################################################
243             sub menu_list
244             {
245 0     0 0 0 my $this = shift;
246 0         0 return @{$this->menus()};
  0         0  
247             }
248             ######################################################################
249             sub radio_list
250             {
251 0     0 0 0 my $this = shift;
252 0         0 return @{$this->radios()};
  0         0  
253             }
254             ######################################################################
255             sub checkbox_list
256             {
257 0     0 0 0 my $this = shift;
258 0         0 return @{$this->checkboxes()};
  0         0  
259             }
260             ######################################################################
261             sub hidden_list
262             {
263 0     0 0 0 my $this = shift;
264 0         0 return @{$this->hidden()};
  0         0  
265             }
266             ######################################################################
267             sub widget_list
268             {
269 0     0 0 0 my $this = shift;
270 0         0 return @{$this->widgets()};
  0         0  
271             }
272             ######################################################################
273             sub submit_list
274             {
275 1     1 0 1 my $this = shift;
276 1         1 @{$this->submits()};
  1         2  
277             }
278              
279             #
280             # By parameter-name n-n widget access (one widget returned for each asked)
281             #
282              
283             ######################################################################
284             sub button_by_name
285             {
286 0     0 0 0 my $this = shift;
287 0         0 $this->_by_name($this->buttons, @_);
288             }
289             ######################################################################
290             sub input_by_name
291             {
292 18     18 0 56 my $this = shift;
293 18         32 $this->_by_name($this->inputs, @_);
294             }
295             ######################################################################
296             sub menu_by_name
297             {
298 14     14 0 270 my $this = shift;
299 14         31 $this->_by_name($this->menus, @_);
300             }
301             ######################################################################
302             sub radio_by_name
303             {
304 6     6 0 22544 my $this = shift;
305 6         1094 $this->_by_name($this->radios, @_);
306             }
307             ######################################################################
308             sub checkbox_by_name
309             {
310 7     7 0 29 my $this = shift;
311 7         26 $this->_by_name($this->checkboxes, @_);
312             }
313             ######################################################################
314             sub hidden_by_name
315             {
316 0     0 0 0 my $this = shift;
317 0         0 $this->_by_name($this->hidden, @_);
318             }
319             ######################################################################
320             sub widget_by_name
321             {
322 6     6 0 1290 my $this = shift;
323 6         16 $this->_by_name($this->widgets, @_);
324             }
325             ######################################################################
326             sub submit_by_name
327             {
328 13     13 0 28 my $this = shift;
329 13         24 return $this->_by_name($this->submits, @_);
330             }
331              
332             #
333             # By parameter-name 1-n widget access (many widgets may be returned, one asked)
334             #
335              
336             ######################################################################
337             sub buttons_named
338             {
339 0     0 0 0 my $this = shift;
340 0         0 return $this->_all_named($this->buttons, @_);
341             }
342             ######################################################################
343             sub inputs_named
344             {
345 0     0 0 0 my $this = shift;
346 0         0 return $this->_all_named($this->inputs, @_);
347             }
348             ######################################################################
349             sub menus_named
350             {
351 0     0 0 0 my $this = shift;
352 0         0 return $this->_all_named($this->menus, @_);
353             }
354             ######################################################################
355             sub radios_named
356             {
357 1     1 0 251 my $this = shift;
358 1         3 return $this->_all_named($this->radios, @_);
359             }
360             ######################################################################
361             sub checkboxes_named
362             {
363 0     0 0 0 my $this = shift;
364 0         0 return $this->_all_named($this->checkboxes, @_);
365             }
366             ######################################################################
367             sub hidden_named
368             {
369 0     0 0 0 my $this = shift;
370 0         0 return $this->_all_named($this->hidden, @_);
371             }
372             ######################################################################
373             sub widgets_named
374             {
375 0     0 0 0 my $this = shift;
376 0         0 return $this->_all_named($this->widgets, @_);
377             }
378             ######################################################################
379             sub submits_named
380             {
381 6     6 0 18 my $this = shift;
382 6         16 return $this->_all_named($this->submits, @_);
383             }
384              
385             #
386             # Convenience routines around ->_matching().
387             #
388              
389             ######################################################################
390             sub buttons_matching
391             {
392 16     16 0 19 my $this = shift;
393 16         37 return $this->_matching($this->buttons, @_);
394             }
395             ######################################################################
396             sub inputs_matching
397             {
398 0     0 0 0 my $this = shift;
399 0         0 return $this->_matching($this->inputs, @_);
400             }
401             ######################################################################
402             sub menus_matching
403             {
404 0     0 0 0 my $this = shift;
405 0         0 return $this->_matching($this->menus, @_);
406             }
407             ######################################################################
408             sub radios_matching
409             {
410 0     0 0 0 my $this = shift;
411 0         0 return $this->_matching($this->radios, @_);
412             }
413             ######################################################################
414             sub checkboxes_matching
415             {
416 0     0 0 0 my $this = shift;
417 0         0 return $this->_matching($this->checkboxes, @_);
418             }
419             ######################################################################
420             sub hidden_matching
421             {
422 0     0 0 0 my $this = shift;
423 0         0 return $this->_matching($this->hidden, @_);
424             }
425             ######################################################################
426             sub widgets_matching
427             {
428 20     20 0 18 my $this = shift;
429 20         42 return $this->_matching($this->widgets, @_);
430             }
431             ######################################################################
432             sub submits_matching
433             {
434 0     0 0 0 my $this = shift;
435 0         0 return $this->_matching($this->submits, @_);
436             }
437              
438             ######################################################################
439             #
440             # ->reset
441             #
442             # Reset form state, restoring all the widget controls to the value they
443             # had upon entry.
444             #
445             ######################################################################
446             sub reset
447             {
448 0     0 1 0 my $this = shift;
449              
450 0         0 foreach my $w ($this->widget_list)
451             {
452 0         0 $w->reset_state;
453             }
454 0         0 return;
455             }
456              
457             ######################################################################
458             #
459             # ->submit
460             #
461             # Submit this form.
462             # Returns resulting CGI::Test::Page.
463             #
464             ######################################################################
465             sub submit
466             {
467 19     19 1 14 my $this = shift;
468              
469 19         58 my $method = $this->method;
470 19         55 my $input = $this->_output; # Input to the request we're about to make
471 19         56 my $action = $this->_action_url;
472 19         46 my $page = $this->page;
473 19         101 my $server = $page->server;
474 19         19 my $result;
475              
476 19 100       49 if ($method eq "GET")
    50          
477             {
478 17 50       56 confess "GET requests only allowed URL encoding, not %s",
479             $input->mime_type
480             unless $input->mime_type eq "application/x-www-form-urlencoded";
481              
482 17         66 $action->query($input->data);
483 17         674 $result = $server->GET($action->as_string, $page->user);
484             }
485             elsif ($method eq "POST")
486             {
487 2         12 $result = $server->POST($action->as_string, $input, $page->user);
488             }
489             else
490             {
491 0         0 confess "unsupported method $method for FORM action";
492             }
493              
494 11         608 return $result;
495             }
496              
497             ######################################################################
498             #
499             # ->_xtract
500             #
501             # Widget extraction routine: traverse the tree and create an instance
502             # of CGI::Test::Form::Widget per encountered widget. The dynamic type depends
503             # on the widget type, e.g. a button creates a CGI::Test::Form::Widget::Button
504             # object.
505             #
506             # Widgets are also sorted by type, and stored as object attribute:
507             #
508             # buttons all buttons
509             # inputs text area, text fields, password fields
510             # menus popup menus
511             # radios radio buttons
512             # checkboxes all checkboxes
513             # hidden all hidden fields
514             # widgets all widgets, whatever their type.
515             #
516             # The special attribute `radio_groups' is only built when there is at least
517             # one radio button.
518             #
519             # Although we extract ALL the widgets, caller is only interested in a
520             # specific list, given in $which. Therefore, returns a list ref on that
521             # particular set.
522             #
523             ######################################################################
524             sub _xtract
525             {
526 16     16   21 my $this = shift;
527 16         18 my ($which) = @_;
528              
529             #
530             # Initiate traversal to locate all widgets nodes.
531             #
532              
533 16         25 my %is_widget = map {$_ => 1} qw(input textarea select button isindex);
  80         128  
534 16     835   42 my @wg = $this->tree->look_down(sub {$is_widget{$_[ 0 ]->tag}});
  835         6290  
535              
536             #
537             # Initialize all lists to be empty
538             #
539              
540 16         215 for my $attr ( qw(buttons inputs radios checkboxes hidden menus widgets) )
541             {
542 112         142 $this->{$attr} = [];
543             }
544              
545             #
546             # And now sort them out.
547             #
548              
549 16         159 my %input = ( # [ class name, attribute ]
550             "submit" => [ 'Button::Submit', "buttons" ],
551             "reset" => [ 'Button::Reset', "buttons" ],
552             "image" => [ 'Button::Image', "buttons" ],
553             "text" => [ 'Input::Text_Field', "inputs" ],
554             "file" => [ 'Input::File', "inputs" ],
555             "password" => [ 'Input::Password', "inputs" ],
556             "radio" => [ 'Box::Radio', "radios" ],
557             "checkbox" => [ 'Box::Check', "checkboxes" ],
558             "hidden" => [ 'Hidden', "hidden" ],
559             );
560              
561 16         78 my %button = ( # [ class name, attribute ]
562             "submit" => [ 'Button::Submit', "buttons" ],
563             "reset" => [ 'Button::Reset', "buttons" ],
564             "button" => [ 'Button::Plain', "buttons" ],
565             );
566              
567 16         26 my $wlist = $this->{widgets}; # All widgets also inserted there
568              
569 16         21 foreach my $node (@wg)
570             {
571 371         498 my $tag = $node->tag;
572 371         1119 my ($class, $attr);
573 0         0 my $hlookup;
574              
575 371 100       474 if ($tag eq "input")
    100          
    50          
    0          
    0          
576             {
577 323         242 $hlookup = \%input;
578             }
579             elsif ($tag eq "textarea")
580             {
581 16         23 ($class, $attr) = ("Input::Text_Area", "inputs");
582             }
583             elsif ($tag eq "select")
584             {
585 32         30 $attr = "menus";
586 32 100 66     63 $class =
587             ($node->attr("multiple") || defined $node->attr("size"))
588             ? "Menu::List"
589             : "Menu::Popup";
590             }
591             elsif ($tag eq "button")
592             {
593 0         0 $hlookup = \%button;
594             }
595             elsif ($tag eq "isindex")
596             {
597 0         0 warn "ISINDEX is deprecated, ignoring %s", $node->starttag;
598 0         0 next;
599             }
600             else
601             {
602 0         0 confess "reached tag '$tag': invalid tree look_down()?";
603             }
604              
605             #
606             # If $hlookup is defined, we need to look at the TYPE attribute
607             # within the tag to determine the object to build.
608             #
609             # This handles and
610             #
611              
612 371 100       773 if (defined $hlookup)
613             {
614 323         397 my $type = $node->attr("type");
615 323 50       1629 unless (defined $type)
616             {
617 0         0 warn "missing TYPE indication in %s: %s", uc($tag),
618             $node->starttag;
619 0         0 next;
620             }
621 323         296 my $info = $hlookup->{lc($type)};
622 323 50       359 unless (defined $info)
623             {
624 0         0 warn "unknown TYPE '%s' in %s: %s", $type, uc($tag),
625             $node->starttag;
626 0         0 next;
627             }
628              
629 323         338 ($class, $attr) = @$info;
630             }
631              
632             #
633             # Create object of given class, insert into attribute list.
634             # Objects will not keep a reference on the node, but will reference us.
635             #
636              
637 371         1633 my $obj = "CGI::Test::Form::Widget::$class"->new($node, $this);
638 371         260 push @{$this->{$attr}}, $obj;
  371         393  
639 371         454 push @$wlist, $obj;
640             }
641              
642             #
643             # Special handling for radio buttons: they need to be groupped, so that
644             # selecting one automatically unselects others from the same group.
645             #
646             # Special handling for checkboxes: one may wish to get at a "group of
647             # checkboxes" instead of an individual checkbox widget.
648             #
649              
650 16         25 my $radios = $this->{radios};
651 16         20 my $checkboxes = $this->{checkboxes};
652              
653 16 50       38 if (@$radios)
654             {
655 16         5048 require CGI::Test::Form::Group;
656 16         93 $this->{radio_groups} = CGI::Test::Form::Group->new($radios);
657             }
658              
659 16 50       36 if (@$checkboxes)
660             {
661 16         61 require CGI::Test::Form::Group;
662 16         36 $this->{checkbox_groups} = CGI::Test::Form::Group->new($checkboxes);
663             }
664              
665             #
666             # Finally, return the list they asked for.
667             #
668              
669             return $this->{
670 16         161 $which};
671             }
672              
673             ######################################################################
674             #
675             # ->_by_name
676             #
677             # Access to widgets, by name, in an n-n fashion: one widget returned for
678             # each name asked, multiple names may be givem.
679             #
680             # Extract and return a list of widgets from a list, by comparing names.
681             # If no widget of corresponding name exists, returns undef.
682             #
683             # There is one returned element per requested name.
684             # When only one name is requested, either scalar or list context may be used.
685             #
686             # For widgets which may be groupped (e.g. radios or checkboxes), the item
687             # selected is the last one bearing that name within the form.
688             #
689             ######################################################################
690             sub _by_name
691             {
692 64     64   48 my $this = shift;
693 64         81 my ($wlist, @names) = @_;
694              
695 64 50       132 croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
696              
697 64         86 my %byname = map {$_->name => $_} @$wlist;
  333         570  
698 64         99 my @results = map {$byname{$_}} @names;
  64         101  
699              
700 64 50       120 if (@names == 1)
701             {
702 64 50       93 return @results if wantarray;
703 64         170 return $results[ 0 ];
704             }
705              
706 0         0 return @results;
707             }
708              
709             ######################################################################
710             #
711             # ->_all_named
712             #
713             # Access to widgets, by name, in a 1-n fashion: from one name, multiple widgets
714             # may be returned.
715             #
716             # Extract and return a list of widgets from a list, by comparing names.
717             # If no widget of corresponding name exists, returns an empty list.
718             # Otherwise returns the list of all widgets bearing that name.
719             #
720             ######################################################################
721             sub _all_named
722             {
723 7     7   9 my $this = shift;
724 7         11 my ($wlist, $name) = @_;
725              
726 7 50       14 croak 'wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
727              
728 7         9 return grep {$_->name eq $name} @$wlist;
  21         46  
729             }
730              
731             ######################################################################
732             #
733             # ->_matching
734             #
735             # Extract widgets from list via matching callback, invoked as:
736             #
737             # callback($widget, $context)
738             #
739             # where $context is one of the select routine parameters.
740             # Returns list of widgets for which the callback returned true.
741             #
742             ######################################################################
743             sub _matching
744             {
745 36     36   34 my $this = shift;
746 36         41 my ($wlist, $code, $context) = @_;
747              
748 36 50       85 croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
749 36 50       63 croak '$code is not CODE reference' unless ref $code eq 'CODE';
750              
751 36         54 return grep {&$code($_, $context)} @$wlist;
  526         479  
752             }
753              
754             ######################################################################
755             #
756             # ->delete
757             #
758             # Done with this page, cleanup by breaking circular & multiple refs.
759             #
760             ######################################################################
761             sub delete
762             {
763 0     0 0 0 my $this = shift;
764              
765 0         0 $this->{node} = undef;
766 0         0 $this->{page} = undef;
767              
768 0         0 delete $this->{submits};
769              
770             #
771             # Handle lazy attributes.
772             #
773              
774 0 0       0 if (ref $this->{widgets})
775             {
776              
777             #
778             # Each widget has a reference on us, which must be cleared.
779             #
780              
781 0         0 foreach my $w (@{$this->{widgets}})
  0         0  
782             {
783 0         0 $w->delete;
784             }
785              
786             #
787             # All widget objects have two references from here: one through their
788             # type list, and one through the general "widgets" list. Simply
789             # break the "widgets" list.
790             #
791              
792 0         0 $this->{widgets} = undef;
793             }
794              
795 0 0       0 $this->{radio_groups}->delete if ref $this->{radio_groups};
796 0 0       0 $this->{checkbox_groups}->delete if ref $this->{checkbox_groups};
797              
798 0         0 return;
799             }
800              
801             ######################################################################
802             #
803             # ->_output
804             #
805             # Create a CGI::Test::Input object and fill it with all the submitable
806             # widgets. That object can then generate the data to be used as input of
807             # the form's action URL, depending on the form's encoding type.
808             #
809             ######################################################################
810             sub _output
811             {
812 19     19   19 my $this = shift;
813              
814 19         50 my $enctype = $this->enctype;
815 19         16 my $input;
816              
817             #
818             # Create polymorphic form input object, holding this form's output.
819             #
820             # It's called "input" because its data are meant to be the input of the
821             # target CGI script.
822             #
823              
824 19 100       44 if ($enctype eq "multipart/form-data")
825             {
826 2         658 require CGI::Test::Input::Multipart;
827 2         10 $input = CGI::Test::Input::Multipart->new();
828             }
829             else
830             {
831 17 50       39 warn "unknown FORM encoding type $enctype, using default"
832             if $enctype ne "application/x-www-form-urlencoded";
833 17         3568 require CGI::Test::Input::URL;
834 17         123 $input = CGI::Test::Input::URL->new();
835             }
836              
837             #
838             # Add all submitable widgets.
839             #
840              
841 19     439   108 foreach my $w ($this->widgets_matching(sub {$_[ 0 ]->is_submitable}))
  439         889  
842             {
843 281         375 $input->add_widget($w);
844             }
845              
846 19         68 return $input;
847             }
848              
849             ######################################################################
850             #
851             # ->_action_url
852             #
853             # Compute the action URL, which is what is going to be requested in response
854             # to a form submit. It does not contain the query part.
855             #
856             # We force re-anchor to the server if the action URL is not tied to it
857             # explicitely (e.g. ACTION="/cgi-bin/foo").
858             #
859             ######################################################################
860             sub _action_url
861             {
862 19     19   14 my $this = shift;
863              
864 19         41 my $uri = $this->page->uri; # The URL that generated this form
865 19         173 my $host_port = $uri->host_port;
866              
867 19         669 require URI;
868              
869 19         47 my $action = URI->new($this->action, "http");
870 19         1738 $action->scheme("http");
871 19 100       1429 $action->host_port($uri->host_port) unless defined $action->host_port;
872              
873 19         1656 return $action;
874             }
875              
876             ######################################################################
877             #
878             # ->_submits
879             #
880             # Compute list of submit buttons.
881             # Returns ref to this list.
882             #
883             ######################################################################
884             sub _submits
885             {
886 16     16   18 my $this = shift;
887              
888 16     64   62 my @submit = $this->buttons_matching(sub {$_[ 0 ]->is_submit});
  64         209  
889              
890 16         106 return \@submit;
891             }
892              
893             1;
894              
895             =head1 NAME
896              
897             CGI::Test::Form - Querying interface to CGI form widgets
898              
899             =head1 SYNOPSIS
900              
901             my $form = $page->forms->[0]; # first form in CGI::Test::Page
902              
903             #
904             # Querying interface, to access form widgets
905             #
906              
907             my @buttons = $form->button_list; # ->buttons would give list ref
908             my $radio_listref = $form->radios; # ->radios_list would give list
909              
910             my $passwd_widget = $form->input_by_name("password");
911             my ($login, $passwd) = $form->input_by_name(qw(login password));
912              
913             my @menus = $form->widgets_matching(sub { $_[0]->is_menu });
914             my @menus = $form->menu_list; # same as line above
915              
916             my $rg = $form->radio_groups; # a CGI::Test::Form::Group or undef
917              
918             #
919             # attributes, as defined by HTML 4.0
920             #
921              
922             my $encoding = $form->enctype;
923             my $action = $form->action;
924             my $method = $form->method;
925             my $name = $form->name;
926             my $accept = $form->accept;
927             my $accept_charset = $form->accept_charset;
928              
929             #
930             # Miscellaneous
931             #
932              
933             # Low-level, direct calls normally not needed
934             $form->reset;
935             my $new_page = $form->submit;
936              
937             # Very low-level access
938             my $html_tree = $form->tree; # HTML::Element form tree
939             my $page = $form->page; # Page containing this form
940              
941             #
942             # Garbage collection -- needed to break circular references
943             #
944              
945             $form->delete;
946              
947             =head1 DESCRIPTION
948              
949             The C class provides an interface to the content of
950             the CGI forms. Instances are automatically created by C when
951             it analyzes an HTML output from a GET/POST request and encounters such
952             beasts.
953              
954             This class is really the basis of the C testing abilities:
955             it provides the necessary routines to query the CGI widgets present in the
956             form: buttons, input areas, menus, etc... Queries can be made by type, and
957             by name. There is also an interface to specifically access groupped widgets
958             like checkboxes and radio buttons.
959              
960             All widgets returned by the queries are polymorphic objects, heirs of
961             C. If the querying interface can be compared to
962             the human eye, enabling you to locate a particular graphical item on the
963             browser screen, the widget interface can be compared to the mouse and keyboard,
964             allowing you to interact with the located graphical components. Please
965             refer to L for interaction details.
966              
967             Apart from the widget querying interface, this class also offers a few
968             services to other C components, like handling of I and
969             I actions, which need not be used directly in practice.
970              
971             Finally, it provides inspection of the tag attributes (encoding
972             type, action, etc...) and, if you really need it, to the HTML tree of
973             the all content. This interface is based on the C
974             class, which represents a tree node. The tree is shared with other
975             C components, it is not a private copy. See L if
976             you are not already familiar with it.
977              
978             If memory is a problem, you must be aware that circular references are
979             used almost everywhere within C. Because Perl's garbage collector
980             cannot reclaim objects that are part of such a reference loop, you must
981             explicitely call the I method on C.
982             Simply forgetting about the reference to that object is not enough.
983             Don't bother with it if your regression test scripts die quickly.
984              
985             =head1 INTERFACE
986              
987             The interface is mostly a querying interface. Most of the routines return
988             widget objects, via lists or list references. See L
989             for details about the interface provided by widget objects, and the
990             classification.
991              
992             The order of the widgets returned lists is the same as the order the widgets
993             appear in the HTML representation.
994              
995             =head2 Type Querying Interface
996              
997             There are two groups or routines: one group returns expanded lists, the
998             other returns list references. They are listed in the table below.
999              
1000             The I column refers to the polymorphic dynamic
1001             type of items held within the list: each item is guaranteed to at least
1002             be of that type, but can be a descendant. Types are listed in the
1003             abridged form, and you have to prepend the string C
1004             in front of them to get the real type.
1005              
1006             Expanded List List Reference Item Polymorphic Type
1007             ------------- -------------- ----------------------
1008             button_list buttons Widget::Button
1009             checkbox_list checkboxes Widget::Box::Check
1010             hidden_list hidden Widget::Hidden
1011             input_list inputs Widget::Input
1012             menu_list menus Widget::Menu
1013             radio_list radios Widget::Box::Radio
1014             submit_list submits Widget::Button::Submit
1015             widget_list widgets Widget
1016              
1017             For instance:
1018              
1019             my @widgets = @{$form->widgets}; # heavy style
1020             my @widgets = $form->widget_list; # light style
1021              
1022             A given widget may appear in several lists, i.e.the above do not form a
1023             partition over the widget set. For instance, a submit button would appear
1024             in the C (which lists I widgets), in the C
1025             and in the C.
1026              
1027             =head2 Name Querying Interface
1028              
1029             Those routine take a name or a list of names, and return the widgets whose
1030             parameter name is B the given name (string comparison). You may
1031             query all widgets, or a particular class, like all buttons, or all input
1032             fields.
1033              
1034             There are two groups of routines:
1035              
1036             =over 4
1037              
1038             =item *
1039              
1040             One group allows for multiple name queries, and returns a list of widgets,
1041             one entry for each listed name. Some widgets like radio buttons may have
1042             multiple instances bearing the same name, and in that case only one is
1043             returned. When querying for one name, you are allowed to use scalar context:
1044              
1045             my @hidden = $form->hidden_by_name("foo", "bar");
1046             my ($context) = $form->hidden_by_name("context");
1047             my $context = $form->hidden_by_name("context");
1048              
1049             When no widget (of that particular type) bearing the requested name is found,
1050             C is returned for that particular slot, so don't blindly make method
1051             calls on each returned value.
1052              
1053             We shall call that group of query routines the B group.
1054              
1055             =item *
1056              
1057             The other group allows for a single name query, but returns a list of all
1058             the widgets (of some particular type when not querying the whole widget list)
1059             bearing that name.
1060              
1061             my @hidden = $form->hidden_named("foo");
1062              
1063             Don't assume that only radios and checkboxes can have multiple instances
1064             bearing the same name.
1065              
1066             We shall call that group of query routines the B group.
1067              
1068             =back
1069              
1070             The available routines are listed in the table below. Note that I
1071             queries are singular, because there is at most one returned widget per name
1072             asked, whereas I queries are plural, where possible.
1073              
1074             The I column refers to the polymorphic dynamic
1075             type of items held within the list: each defined item is guaranteed to at
1076             least be of that type, but can be a descendant. Types are listed in the
1077             abridged form, and you have to prepend the string C
1078             in front of them to get the real type.
1079              
1080             By-Name Queries All-Named Queries Item Polymorphic Type
1081             ---------------- ----------------- ----------------------
1082             button_by_name buttons_named Widget::Button
1083             checkbox_by_name checkboxes_named Widget::Box::Check
1084             hidden_by_name hidden_named Widget::Hidden
1085             input_by_name inputs_named Widget::Input
1086             menu_by_name menus_named Widget::Menu
1087             radio_by_name radios_named Widget::Box::Radio
1088             submit_by_name submits_named Widget::Button::Submit
1089             widget_by_name widgets_named Widget
1090              
1091             =head2 Match Querying Interface
1092              
1093             This is a general interface, which invokes a matching callback on each
1094             widget of a particular category. The signature of the matching routines is:
1095              
1096             my @matching = $form->widgets_matching(sub {code}, $arg);
1097              
1098             and the callback is invoked as:
1099              
1100             callback($widget, $arg);
1101              
1102             A widget is kept if, and only if, the callback returns true. Be sure to
1103             write your callback so that is only uses calls that apply to the particular
1104             widget. When you know you're matching on menu widgets, you can call
1105             menu-specific features, but should you use that same callback for buttons,
1106             you would get a runtime error.
1107              
1108             Each matching routine returns a list of matching widgets. Using the $arg
1109             parameter is optional, and should be avoided unless you have no other choice,
1110             so as to be as stateless as possible.
1111              
1112             The following table lists the available matching routines, along with the
1113             polymorphic widget type to be expected in the callback. As usual, you must
1114             prepend the string C to get the real type.
1115              
1116             Matching Routine Item Polymorphic Type
1117             ------------------- ---------------------
1118             buttons_matching Widget::Button
1119             checkboxes_matching Widget::Box::Check
1120             hidden_matching Widget::Hidden
1121             inputs_matching Widget::Input
1122             menus_matching Widget::Menu
1123             radios_matching Widget::Box::Radio
1124             submits_matching Widget::Button::Submit
1125             widgets_matching Widget
1126              
1127             For instance:
1128              
1129             my @menus = $form->widgets_matching(sub { $_[0]->is_menu });
1130             my @color = $form->widgets_matching(
1131             sub { $_[0]->is_menu && $_[0]->name eq "color" }
1132             );
1133              
1134             is an inefficient way of saying:
1135              
1136             my @menus = $form->menu_list;
1137             my @color = $form->menus_matching(sub { $_[0]->name eq "color" });
1138              
1139             and the latter can further be rewritten as:
1140              
1141             my @color = $form->menus_named("color");
1142              
1143             =head2 Form Interface
1144              
1145             This provides an interface to get at the attributes of the tag.
1146             For instance:
1147              
1148             my $enctype = $form->enctype;
1149              
1150             to get at the encoding type of that particular form.
1151             The following attributes are available:
1152              
1153             accept
1154             accept_charset
1155             action
1156             enctype
1157             method
1158             name
1159              
1160             as defined by HTML 4.0.
1161              
1162             =head2 Group Querying Interface
1163              
1164             There are two kinds of widgets that are architecturally groupped, meaning
1165             more that one instance of that widget can bear the same name: radio buttons
1166             and checkboxes (although you may have a single standalone checkbox).
1167              
1168             All radio buttons and checkboxes defined in a form are automatically
1169             inserted into a group of their own, which is an instance of the
1170             C class. This class contains all the defined
1171             groups for a particular kind. The routines:
1172              
1173             checkbox_groups
1174             radio_groups
1175              
1176             give you access to the C container. Both routines
1177             may return C when there is no checkbox or radio button in the form.
1178             See L for its querying interface.
1179              
1180             =head2 Memory Cleanup
1181              
1182             You B call the I method to break the circular references
1183             if you wish to dispose of the object.
1184              
1185             =head2 Internal Interface
1186              
1187             The following routines are available internally:
1188              
1189             =over 4
1190              
1191             =item reset
1192              
1193             Reset the form state, restoring all the controls to the value they
1194             had upon entry.
1195              
1196             =item submit
1197              
1198             Submit the form, returning a C reply.
1199              
1200             =back
1201              
1202             =head1 AUTHORS
1203              
1204             The original author is Raphael Manfredi.
1205              
1206             Steven Hilton was long time maintainer of this module.
1207              
1208             Current maintainer is Alexander Tokarev Ftokarev@cpan.orgE>.
1209              
1210             =head1 SEE ALSO
1211              
1212             CGI::Test(3), CGI::Test::Form::Widget(3), CGI::Test::Form::Group(3),
1213             CGI::Test::Page(3), HTML::Element(3).
1214              
1215             =cut
1216