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   58 use strict;
  14         15  
  14         452  
3 14     14   48 use warnings;
  14         19  
  14         422  
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   44 use Carp;
  14         14  
  14         849  
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   4686 use CGI::Test::Form::Widget::Button::Submit;
  14         24  
  14         286  
28 14     14   4901 use CGI::Test::Form::Widget::Button::Reset;
  14         23  
  14         263  
29 14     14   4823 use CGI::Test::Form::Widget::Button::Image;
  14         30  
  14         274  
30 14     14   4405 use CGI::Test::Form::Widget::Button::Plain;
  14         26  
  14         302  
31 14     14   4930 use CGI::Test::Form::Widget::Input::Text_Field;
  14         22  
  14         336  
32 14     14   4467 use CGI::Test::Form::Widget::Input::Text_Area;
  14         23  
  14         262  
33 14     14   4359 use CGI::Test::Form::Widget::Input::Password;
  14         28  
  14         318  
34 14     14   4325 use CGI::Test::Form::Widget::Input::File;
  14         24  
  14         255  
35 14     14   4335 use CGI::Test::Form::Widget::Menu::List;
  14         24  
  14         324  
36 14     14   5659 use CGI::Test::Form::Widget::Menu::Popup;
  14         21  
  14         279  
37 14     14   4512 use CGI::Test::Form::Widget::Box::Radio;
  14         31  
  14         317  
38 14     14   4623 use CGI::Test::Form::Widget::Box::Check;
  14         27  
  14         248  
39 14     14   4078 use CGI::Test::Form::Widget::Hidden;
  14         20  
  14         28449  
40              
41             ######################################################################
42             #
43             # ->new
44             #
45             # Creation routine
46             #
47             ######################################################################
48             sub new
49             {
50 16     16 0 44 my $this = bless {}, shift;
51 16         29 my ($node, $page) = @_;
52              
53 16         86 $this->{tree} = $node; # is the root node of the tree
54 16         29 $this->{page} = $page;
55              
56 16   50     60 $this->{enctype} = $node->attr("enctype")
57             || "application/x-www-form-urlencoded";
58 16   50     231 $this->{method} = uc $node->attr("method") || "POST";
59              
60 16         137 foreach my $attr (qw(action name accept accept-charset))
61             {
62 64         54 my $oattr = $attr;
63 64         102 $oattr =~ s/-/_/g;
64 64         89 my $value = $node->attr($attr);
65 64 100       376 $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       49 $this->{action} = $page->uri->as_string unless exists $this->{action};
74              
75 16         60 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 20 my $this = shift;
95 16         72 return $this->{tree};
96             }
97              
98             ######################################################################
99             sub page
100             {
101 38     38 0 56 my $this = shift;
102 38         179 return $this->{page};
103             }
104              
105             ######################################################################
106             sub enctype
107             {
108 25     25 0 38 my $this = shift;
109 25         86 return $this->{enctype};
110             }
111              
112             ######################################################################
113             sub action
114             {
115 38     38 0 304 my $this = shift;
116 38         307 return $this->{action};
117             }
118              
119             ######################################################################
120             sub method
121             {
122 29     29 0 17845 my $this = shift;
123 29         98 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 250 my $this = shift;
155 17   66     84 return $this->{buttons} || $this->_xtract("buttons");
156             }
157              
158             ######################################################################
159             sub inputs
160             {
161 19     19 0 22 my $this = shift;
162 19   33     66 return $this->{inputs} || $this->_xtract("inputs");
163             }
164              
165             ######################################################################
166             sub menus
167             {
168 15     15 0 248 my $this = shift;
169 15   33     56 return $this->{menus} || $this->_xtract("menus");
170             }
171              
172             ######################################################################
173             sub radios
174             {
175 8     8 0 15 my $this = shift;
176 8   66     66 return $this->{radios} || $this->_xtract("radios");
177             }
178              
179             ######################################################################
180             sub checkboxes
181             {
182 9     9 0 362 my $this = shift;
183 9   33     42 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     133 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 25 my $this = shift;
208 20   66     99 return $this->{submits} || ($this->{submits} = $this->_submits);
209             }
210              
211             ######################################################################
212             sub radio_groups
213             {
214 1     1 0 468 my $this = shift;
215 1   33     2 return $this->radios()
216             && $this->{radio_groups};
217             }
218             ######################################################################
219             sub checkbox_groups
220             {
221 1     1 0 2 my $this = shift;
222 1   33     3 return $this->checkboxes()
223             && $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 2 my $this = shift;
276 1         1 @{$this->submits()};
  1         3  
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 64 my $this = shift;
293 18         42 $this->_by_name($this->inputs, @_);
294             }
295             ######################################################################
296             sub menu_by_name
297             {
298 14     14 0 280 my $this = shift;
299 14         35 $this->_by_name($this->menus, @_);
300             }
301             ######################################################################
302             sub radio_by_name
303             {
304 6     6 0 27540 my $this = shift;
305 6         42 $this->_by_name($this->radios, @_);
306             }
307             ######################################################################
308             sub checkbox_by_name
309             {
310 7     7 0 25 my $this = shift;
311 7         20 $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 1348 my $this = shift;
323 6         17 $this->_by_name($this->widgets, @_);
324             }
325             ######################################################################
326             sub submit_by_name
327             {
328 13     13 0 26 my $this = shift;
329 13         35 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 237 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 21 my $this = shift;
382 6         18 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 20 my $this = shift;
393 16         47 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 26 my $this = shift;
429 20         54 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 19 my $this = shift;
468              
469 19         60 my $method = $this->method;
470 19         60 my $input = $this->_output; # Input to the request we're about to make
471 19         51 my $action = $this->_action_url;
472 19         49 my $page = $this->page;
473 19         132 my $server = $page->server;
474 19         22 my $result;
475              
476 19 100       62 if ($method eq "GET")
    50          
477             {
478 17 50       70 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         67 $action->query($input->data);
483 17         691 $result = $server->GET($action->as_string, $page->user);
484             }
485             elsif ($method eq "POST")
486             {
487 2         14 $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         548 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   16 my $this = shift;
527 16         43 my ($which) = @_;
528              
529             #
530             # Initiate traversal to locate all widgets nodes.
531             #
532              
533 16         26 my %is_widget = map {$_ => 1} qw(input textarea select button isindex);
  80         131  
534 16     835   44 my @wg = $this->tree->look_down(sub {$is_widget{$_[ 0 ]->tag}});
  835         6387  
535              
536             #
537             # Initialize all lists to be empty
538             #
539              
540 16         208 for my $attr ( qw(buttons inputs radios checkboxes hidden menus widgets) )
541             {
542 112         157 $this->{$attr} = [];
543             }
544              
545             #
546             # And now sort them out.
547             #
548              
549 16         167 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         63 my %button = ( # [ class name, attribute ]
562             "submit" => [ 'Button::Submit', "buttons" ],
563             "reset" => [ 'Button::Reset', "buttons" ],
564             "button" => [ 'Button::Plain', "buttons" ],
565             );
566              
567 16         41 my $wlist = $this->{widgets}; # All widgets also inserted there
568              
569 16         22 foreach my $node (@wg)
570             {
571 371         651 my $tag = $node->tag;
572 371         1102 my ($class, $attr);
573 0         0 my $hlookup;
574              
575 371 100       498 if ($tag eq "input")
    100          
    50          
    0          
    0          
576             {
577 323         277 $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         43 $attr = "menus";
586 32 100 66     60 $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       777 if (defined $hlookup)
613             {
614 323         593 my $type = $node->attr("type");
615 323 50       1725 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         325 my $info = $hlookup->{lc($type)};
622 323 50       489 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         362 ($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         2071 my $obj = "CGI::Test::Form::Widget::$class"->new($node, $this);
638 371         272 push @{$this->{$attr}}, $obj;
  371         462  
639 371         460 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         28 my $radios = $this->{radios};
651 16         23 my $checkboxes = $this->{checkboxes};
652              
653 16 50       34 if (@$radios)
654             {
655 16         5655 require CGI::Test::Form::Group;
656 16         101 $this->{radio_groups} = CGI::Test::Form::Group->new($radios);
657             }
658              
659 16 50       39 if (@$checkboxes)
660             {
661 16         53 require CGI::Test::Form::Group;
662 16         44 $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         176 $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   68 my $this = shift;
693 64         106 my ($wlist, @names) = @_;
694              
695 64 50       135 croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
696              
697 64         100 my %byname = map {$_->name => $_} @$wlist;
  333         675  
698 64         116 my @results = map {$byname{$_}} @names;
  64         120  
699              
700 64 50       117 if (@names == 1)
701             {
702 64 50       106 return @results if wantarray;
703 64         191 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   12 my $this = shift;
724 7         12 my ($wlist, $name) = @_;
725              
726 7 50       18 croak 'wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
727              
728 7         8 return grep {$_->name eq $name} @$wlist;
  21         53  
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   52 my $this = shift;
746 36         41 my ($wlist, $code, $context) = @_;
747              
748 36 50       89 croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
749 36 50       66 croak '$code is not CODE reference' unless ref $code eq 'CODE';
750              
751 36         55 return grep {&$code($_, $context)} @$wlist;
  526         486  
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   25 my $this = shift;
813              
814 19         43 my $enctype = $this->enctype;
815 19         22 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       69 if ($enctype eq "multipart/form-data")
825             {
826 2         642 require CGI::Test::Input::Multipart;
827 2         10 $input = CGI::Test::Input::Multipart->new();
828             }
829             else
830             {
831 17 50       37 warn "unknown FORM encoding type $enctype, using default"
832             if $enctype ne "application/x-www-form-urlencoded";
833 17         3497 require CGI::Test::Input::URL;
834 17         106 $input = CGI::Test::Input::URL->new();
835             }
836              
837             #
838             # Add all submitable widgets.
839             #
840              
841 19     439   122 foreach my $w ($this->widgets_matching(sub {$_[ 0 ]->is_submitable}))
  439         1421  
842             {
843 281         473 $input->add_widget($w);
844             }
845              
846 19         77 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   33 my $this = shift;
863              
864 19         61 my $uri = $this->page->uri; # The URL that generated this form
865 19         204 my $host_port = $uri->host_port;
866              
867 19         772 require URI;
868              
869 19         62 my $action = URI->new($this->action, "http");
870 19         1777 $action->scheme("http");
871 19 100       1595 $action->host_port($uri->host_port) unless defined $action->host_port;
872              
873 19         1747 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   69 my @submit = $this->buttons_matching(sub {$_[ 0 ]->is_submit});
  64         226  
889              
890 16         108 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