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   1043455 use strict;
  11         35  
  11         461  
4 11     11   8190 use URI;
  11         99681  
  11         408  
5 11     11   97 use Carp ();
  11         22  
  11         157  
6 11     11   6652 use Encode ();
  11         229940  
  11         636  
7              
8 11     11   6039 use HTML::Form::TextInput ();
  11         29  
  11         284  
9 11     11   4680 use HTML::Form::IgnoreInput ();
  11         30  
  11         256  
10 11     11   4910 use HTML::Form::ListInput ();
  11         33  
  11         284  
11 11     11   5402 use HTML::Form::SubmitInput ();
  11         30  
  11         244  
12 11     11   4908 use HTML::Form::ImageInput ();
  11         30  
  11         270  
13 11     11   5014 use HTML::Form::FileInput ();
  11         31  
  11         352  
14 11     11   5048 use HTML::Form::KeygenInput ();
  11         34  
  11         19349  
15              
16             our $VERSION = '6.13';
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 4949343 my $class = shift;
54 35         93 my $html = shift;
55 35 100       175 unshift( @_, "base" ) if @_ == 1;
56 35         183 my %opt = @_;
57              
58 35         6861 require HTML::TokeParser;
59 35 100       125145 my $p = HTML::TokeParser->new(
60             ref($html) ? $html->decoded_content( ref => 1 ) : \$html );
61 35 50       5871 Carp::croak "Failed to create HTML::TokeParser object" unless $p;
62              
63 35         96 my $base_uri = delete $opt{base};
64 35         65 my $charset = delete $opt{charset};
65 35         68 my $strict = delete $opt{strict};
66 35         84 my $verbose = delete $opt{verbose};
67              
68 35 100       137 if ($^W) {
69             Carp::carp("Unrecognized option $_ in HTML::Form->parse")
70 1         241 for sort keys %opt;
71             }
72              
73 35 100       141 unless ( defined $base_uri ) {
74 3 50       12 if ( ref($html) ) {
75 3         43 $base_uri = $html->base;
76             }
77             else {
78 0         0 Carp::croak("HTML::Form::parse: No \$base_uri provided");
79             }
80             }
81 35 50       97 unless ( defined $charset ) {
82 35 100 100     160 if ( ref($html) and $html->can("content_charset") ) {
83 2         21 $charset = $html->content_charset;
84             }
85 35 100       395 unless ($charset) {
86 34         60 $charset = "UTF-8";
87             }
88             }
89              
90 35         114 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         3909 my ( $tag, $attr ) = @$t;
97 60 100       239 if ( $tag eq "form" ) {
    50          
98 38         168 my $action = delete $attr->{'action'};
99 38 100       135 $action = "" unless defined $action;
100 38         248 $action = URI->new_abs( $action, $base_uri );
101             $f = $class->new(
102             $attr->{'method'},
103             $action,
104 38         135434 $attr->{'enctype'}
105             );
106             $f->accept_charset( $attr->{'accept-charset'} )
107 38 100       136 if $attr->{'accept-charset'};
108 38         95 $f->{default_charset} = $charset;
109 38         97 $f->{attr} = $attr;
110 38 100       148 $f->strict(1) if $strict;
111 38         78 %openselect = ();
112 38         122 push( @forms, $f );
113 38         59 my ( %labels, $current_label );
114 38         149 while ( my $t = $p->get_tag ) {
115 208         5100 my ( $tag, $attr ) = @$t;
116 208 100       554 last if $tag eq "/form";
117              
118 172 100       348 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       320 if ( defined $current_label ) {
123             $current_label = join " ",
124 13 50       29 grep { defined and length } $current_label,
  26         787  
125             $p->get_phrase;
126             }
127             }
128              
129 172 100       304 if ( $tag eq "input" ) {
130             $attr->{value_name}
131             = exists $attr->{id} && exists $labels{ $attr->{id} }
132             ? $labels{ $attr->{id} }
133 66 100 100     368 : defined $current_label ? $current_label
    100          
134             : $p->get_phrase;
135             }
136              
137 172 100       4967 if ( $tag eq "label" ) {
    100          
    100          
    100          
    100          
    100          
    100          
138 7         19 $current_label = $p->get_phrase;
139             $labels{ $attr->{for} } = $current_label
140 7 100       465 if exists $attr->{for};
141             }
142             elsif ( $tag eq "/label" ) {
143 7         19 $current_label = undef;
144             }
145             elsif ( $tag eq "input" ) {
146 66   100     176 my $type = delete $attr->{type} || "text";
147 66         162 $f->push_input( $type, $attr, $verbose );
148             }
149             elsif ( $tag eq "button" ) {
150 2   50     7 my $type = delete $attr->{type} || "submit";
151 2         7 $f->push_input( $type, $attr, $verbose );
152             }
153             elsif ( $tag eq "textarea" ) {
154             $attr->{textarea_value} = $attr->{value}
155 3 50       11 if exists $attr->{value};
156 3         15 my $text = $p->get_text("/textarea");
157 3         171 $attr->{value} = $text;
158 3         12 $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         56 for ( "value", "value_name" ) {
164             $attr->{"select_$_"} = delete $attr->{$_}
165 58 100       124 if exists $attr->{$_};
166             }
167              
168             # count this new select option separately
169 29         47 my $name = $attr->{name};
170 29 100       66 $name = "" unless defined $name;
171 29         78 $openselect{$name}++;
172              
173 29         64 while ( $t = $p->get_tag ) {
174 126         2969 my $tag = shift @$t;
175 126 100       293 last if $tag eq "/select";
176 101 50       194 next if $tag =~ m,/?optgroup,;
177 101 100       188 next if $tag eq "/option";
178 76 100       144 if ( $tag eq "option" ) {
179 71         87 my %a = %{ $t->[0] };
  71         206  
180              
181             # rename keys so they don't clash with %attr
182 71         157 for ( keys %a ) {
183 56 100       109 next if $_ eq "value";
184 25         67 $a{"option_$_"} = delete $a{$_};
185             }
186 71         206 while ( my ( $k, $v ) = each %$attr ) {
187 123         346 $a{$k} = $v;
188             }
189 71         162 $a{value_name} = $p->get_trimmed_text;
190             $a{value} = delete $a{value_name}
191 71 100       4281 unless defined $a{value};
192 71         134 $a{idx} = $openselect{$name};
193 71         221 $f->push_input( "option", \%a, $verbose );
194             }
195             else {
196 5 50       11 warn("Bad
197             if $verbose;
198 5 50 100     28 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