File Coverage

blib/lib/HTML/Form.pm
Criterion Covered Total %
statement 291 312 93.2
branch 154 190 81.0
condition 50 67 74.6
subroutine 28 30 93.3
pod 13 15 86.6
total 536 614 87.3


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