File Coverage

blib/lib/HTML/Form.pm
Criterion Covered Total %
statement 516 558 92.4
branch 289 358 80.7
condition 115 148 77.7
subroutine 58 63 92.0
pod 13 15 86.6
total 991 1142 86.7


line stmt bran cond sub pod time code
1             package HTML::Form;
2              
3 10     10   478423 use strict;
  10         94  
  10         264  
4 10     10   4501 use URI;
  10         62355  
  10         277  
5 10     10   60 use Carp ();
  10         17  
  10         110  
6 10     10   4719 use Encode ();
  10         132242  
  10         12368  
7              
8             our $VERSION = '6.10';
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 34     34 1 44143 my $class = shift;
45 34         68 my $html = shift;
46 34 100       137 unshift(@_, "base") if @_ == 1;
47 34         116 my %opt = @_;
48              
49 34         3883 require HTML::TokeParser;
50 34 100       79685 my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
51 34 50       4933 Carp::croak "Failed to create HTML::TokeParser object" unless $p;
52              
53 34         77 my $base_uri = delete $opt{base};
54 34         64 my $charset = delete $opt{charset};
55 34         64 my $strict = delete $opt{strict};
56 34         66 my $verbose = delete $opt{verbose};
57              
58 34 50       128 if ($^W) {
59 0         0 Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
60             }
61              
62 34 100       86 unless (defined $base_uri) {
63 3 50       7 if (ref($html)) {
64 3         12 $base_uri = $html->base;
65             }
66             else {
67 0         0 Carp::croak("HTML::Form::parse: No \$base_uri provided");
68             }
69             }
70 34 50       82 unless (defined $charset) {
71 34 100 100     120 if (ref($html) and $html->can("content_charset")) {
72 2         20 $charset = $html->content_charset;
73             }
74 34 100       423 unless ($charset) {
75 33         51 $charset = "UTF-8";
76             }
77             }
78              
79 34         79 my @forms;
80             my $f; # current form
81              
82 34         0 my %openselect; # index to the open instance of a select
83              
84 34         105 while (my $t = $p->get_tag) {
85 60         3308 my($tag,$attr) = @$t;
86 60 100       181 if ($tag eq "form") {
    50          
87 38         67 my $action = delete $attr->{'action'};
88 38 100       94 $action = "" unless defined $action;
89 38         167 $action = URI->new_abs($action, $base_uri);
90             $f = $class->new($attr->{'method'},
91             $action,
92 38         67383 $attr->{'enctype'});
93 38 100       122 $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
94 38         76 $f->{default_charset} = $charset;
95 38         83 $f->{attr} = $attr;
96 38 100       87 $f->strict(1) if $strict;
97 38         72 %openselect = ();
98 38         66 push(@forms, $f);
99 38         59 my(%labels, $current_label);
100 38         129 while (my $t = $p->get_tag) {
101 208         4789 my($tag, $attr) = @$t;
102 208 100       464 last if $tag eq "/form";
103              
104 172 100       289 if ($tag ne 'textarea') {
105             # if we are inside a label tag, then keep
106             # appending any text to the current label
107 169 100       269 if(defined $current_label) {
108             $current_label = join " ",
109 13 50       26 grep { defined and length }
  26         644  
110             $current_label,
111             $p->get_phrase;
112             }
113             }
114              
115 172 100       264 if ($tag eq "input") {
116             $attr->{value_name} =
117             exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
118 66 100 100     299 defined $current_label ? $current_label :
    100          
119             $p->get_phrase;
120             }
121              
122 172 100       4262 if ($tag eq "label") {
    100          
    100          
    100          
    100          
    100          
    100          
123 7         16 $current_label = $p->get_phrase;
124             $labels{ $attr->{for} } = $current_label
125 7 100       423 if exists $attr->{for};
126             }
127             elsif ($tag eq "/label") {
128 7         16 $current_label = undef;
129             }
130             elsif ($tag eq "input") {
131 66   100     172 my $type = delete $attr->{type} || "text";
132 66         225 $f->push_input($type, $attr, $verbose);
133             }
134             elsif ($tag eq "button") {
135 2   50     7 my $type = delete $attr->{type} || "submit";
136 2         4 $f->push_input($type, $attr, $verbose);
137             }
138             elsif ($tag eq "textarea") {
139             $attr->{textarea_value} = $attr->{value}
140 3 50       8 if exists $attr->{value};
141 3         21 my $text = $p->get_text("/textarea");
142 3         157 $attr->{value} = $text;
143 3         9 $f->push_input("textarea", $attr, $verbose);
144             }
145             elsif ($tag eq "select") {
146             # rename attributes reserved to come for the option tag
147 29         60 for ("value", "value_name") {
148             $attr->{"select_$_"} = delete $attr->{$_}
149 58 100       108 if exists $attr->{$_};
150             }
151             # count this new select option separately
152 29         44 my $name = $attr->{name};
153 29 100       58 $name = "" unless defined $name;
154 29         59 $openselect{$name}++;
155              
156 29         67 while ($t = $p->get_tag) {
157 126         2729 my $tag = shift @$t;
158 126 100       260 last if $tag eq "/select";
159 101 50       159 next if $tag =~ m,/?optgroup,;
160 101 100       160 next if $tag eq "/option";
161 76 100       114 if ($tag eq "option") {
162 71         64 my %a = %{$t->[0]};
  71         189  
163             # rename keys so they don't clash with %attr
164 71         144 for (keys %a) {
165 56 100       98 next if $_ eq "value";
166 25         62 $a{"option_$_"} = delete $a{$_};
167             }
168 71         187 while (my($k,$v) = each %$attr) {
169 123         299 $a{$k} = $v;
170             }
171 71         165 $a{value_name} = $p->get_trimmed_text;
172             $a{value} = delete $a{value_name}
173 71 100       3764 unless defined $a{value};
174 71         159 $a{idx} = $openselect{$name};
175 71         161 $f->push_input("option", \%a, $verbose);
176             }
177             else {
178 5 50       11 warn("Bad
179 5 50 100     44 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