File Coverage

blib/lib/HTML/Form.pm
Criterion Covered Total %
statement 510 552 92.3
branch 278 346 80.3
condition 115 146 78.7
subroutine 58 63 92.0
pod 13 15 86.6
total 974 1122 86.8


line stmt bran cond sub pod time code
1             package HTML::Form;
2              
3 10     10   477561 use strict;
  10         102  
  10         256  
4 10     10   6187 use URI;
  10         62349  
  10         269  
5 10     10   54 use Carp ();
  10         17  
  10         111  
6 10     10   4654 use Encode ();
  10         130924  
  10         12154  
7              
8             our $VERSION = '6.09';
9              
10             my %form_tags = map {$_ => 1} qw(input textarea button select option);
11              
12             my %type2class = (
13             text => "TextInput",
14             password => "TextInput",
15             hidden => "TextInput",
16             textarea => "TextInput",
17              
18             "reset" => "IgnoreInput",
19              
20             radio => "ListInput",
21             checkbox => "ListInput",
22             option => "ListInput",
23              
24             button => "SubmitInput",
25             submit => "SubmitInput",
26             image => "ImageInput",
27             file => "FileInput",
28              
29             keygen => "KeygenInput",
30             );
31              
32             # The new HTML5 input types
33             %type2class = (%type2class, map { $_ => 'TextInput' } qw(
34             tel search url email
35             datetime date month week time datetime-local
36             number range color
37             ));
38              
39             # ABSTRACT: Class that represents an HTML form element
40              
41              
42             sub parse
43             {
44 33     33 1 36021 my $class = shift;
45 33         86 my $html = shift;
46 33 100       110 unshift(@_, "base") if @_ == 1;
47 33         94 my %opt = @_;
48              
49 33         3840 require HTML::TokeParser;
50 33 100       81113 my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
51 33 50       4395 die "Failed to create HTML::TokeParser object" unless $p;
52              
53 33         79 my $base_uri = delete $opt{base};
54 33         56 my $charset = delete $opt{charset};
55 33         52 my $strict = delete $opt{strict};
56 33         80 my $verbose = delete $opt{verbose};
57              
58 33 50       106 if ($^W) {
59 0         0 Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
60             }
61              
62 33 100       74 unless (defined $base_uri) {
63 3 50       11 if (ref($html)) {
64 3         8 $base_uri = $html->base;
65             }
66             else {
67 0         0 Carp::croak("HTML::Form::parse: No \$base_uri provided");
68             }
69             }
70 33 50       102 unless (defined $charset) {
71 33 100 100     109 if (ref($html) and $html->can("content_charset")) {
72 2         22 $charset = $html->content_charset;
73             }
74 33 100       391 unless ($charset) {
75 32         49 $charset = "UTF-8";
76             }
77             }
78              
79 33         133 my @forms;
80             my $f; # current form
81              
82 33         0 my %openselect; # index to the open instance of a select
83              
84 33         92 while (my $t = $p->get_tag) {
85 59         2975 my($tag,$attr) = @$t;
86 59 100       185 if ($tag eq "form") {
    50          
87 37         61 my $action = delete $attr->{'action'};
88 37 100       84 $action = "" unless defined $action;
89 37         144 $action = URI->new_abs($action, $base_uri);
90             $f = $class->new($attr->{'method'},
91             $action,
92 37         68737 $attr->{'enctype'});
93 37 100       112 $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
94 37         61 $f->{default_charset} = $charset;
95 37         67 $f->{attr} = $attr;
96 37 100       86 $f->strict(1) if $strict;
97 37         62 %openselect = ();
98 37         60 push(@forms, $f);
99 37         52 my(%labels, $current_label);
100 37         133 while (my $t = $p->get_tag) {
101 204         4937 my($tag, $attr) = @$t;
102 204 100       491 last if $tag eq "/form";
103              
104 168 100       272 if ($tag ne 'textarea') {
105             # if we are inside a label tag, then keep
106             # appending any text to the current label
107 165 100       290 if(defined $current_label) {
108             $current_label = join " ",
109 13 50       28 grep { defined and length }
  26         646  
110             $current_label,
111             $p->get_phrase;
112             }
113             }
114              
115 168 100       583 if ($tag eq "input") {
116             $attr->{value_name} =
117             exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
118 66 100 100     310 defined $current_label ? $current_label :
    100          
119             $p->get_phrase;
120             }
121              
122 168 100       4762 if ($tag eq "label") {
    100          
    100          
    100          
    100          
    100          
    100          
123 7         19 $current_label = $p->get_phrase;
124             $labels{ $attr->{for} } = $current_label
125 7 100       439 if exists $attr->{for};
126             }
127             elsif ($tag eq "/label") {
128 7         18 $current_label = undef;
129             }
130             elsif ($tag eq "input") {
131 66   100     174 my $type = delete $attr->{type} || "text";
132 66         231 $f->push_input($type, $attr, $verbose);
133             }
134             elsif ($tag eq "button") {
135 2   50     7 my $type = delete $attr->{type} || "submit";
136 2         10 $f->push_input($type, $attr, $verbose);
137             }
138             elsif ($tag eq "textarea") {
139             $attr->{textarea_value} = $attr->{value}
140 3 50       12 if exists $attr->{value};
141 3         11 my $text = $p->get_text("/textarea");
142 3         152 $attr->{value} = $text;
143 3         10 $f->push_input("textarea", $attr, $verbose);
144             }
145             elsif ($tag eq "select") {
146             # rename attributes reserved to come for the option tag
147 25         81 for ("value", "value_name") {
148             $attr->{"select_$_"} = delete $attr->{$_}
149 50 100       125 if exists $attr->{$_};
150             }
151             # count this new select option separately
152 25         39 my $name = $attr->{name};
153 25 100       46 $name = "" unless defined $name;
154 25         72 $openselect{$name}++;
155              
156 25         59 while ($t = $p->get_tag) {
157 114         2455 my $tag = shift @$t;
158 114 100       229 last if $tag eq "/select";
159 93 50       158 next if $tag =~ m,/?optgroup,;
160 93 100       138 next if $tag eq "/option";
161 72 100       107 if ($tag eq "option") {
162 67         67 my %a = %{$t->[0]};
  67         201  
163             # rename keys so they don't clash with %attr
164 67         138 for (keys %a) {
165 52 100       97 next if $_ eq "value";
166 21         55 $a{"option_$_"} = delete $a{$_};
167             }
168 67         185 while (my($k,$v) = each %$attr) {
169 121         296 $a{$k} = $v;
170             }
171 67         145 $a{value_name} = $p->get_trimmed_text;
172             $a{value} = delete $a{value_name}
173 67 100       3542 unless defined $a{value};
174 67         122 $a{idx} = $openselect{$name};
175 67         123 $f->push_input("option", \%a, $verbose);
176             }
177             else {
178 5 50       11 warn("Bad
179 5 50 100     29 if ($tag eq "/form" ||
      66        
      66        
      33        
180             $tag eq "input" ||
181             $tag eq "textarea" ||
182             $tag eq "select" ||
183             $tag eq "keygen")
184             {
185             # MSIE implicitly terminates the
186             # try to do the same. Actually the MSIE behaviour
187             # appears really strange: and