1 | package HTML::Form;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use URI;
|
---|
5 | use Carp ();
|
---|
6 |
|
---|
7 | use vars qw($VERSION $Encode_available);
|
---|
8 | $VERSION = "5.829";
|
---|
9 |
|
---|
10 | eval { require Encode };
|
---|
11 | $Encode_available = !$@;
|
---|
12 |
|
---|
13 | my %form_tags = map {$_ => 1} qw(input textarea button select option);
|
---|
14 |
|
---|
15 | my %type2class = (
|
---|
16 | text => "TextInput",
|
---|
17 | password => "TextInput",
|
---|
18 | hidden => "TextInput",
|
---|
19 | textarea => "TextInput",
|
---|
20 |
|
---|
21 | "reset" => "IgnoreInput",
|
---|
22 |
|
---|
23 | radio => "ListInput",
|
---|
24 | checkbox => "ListInput",
|
---|
25 | option => "ListInput",
|
---|
26 |
|
---|
27 | button => "SubmitInput",
|
---|
28 | submit => "SubmitInput",
|
---|
29 | image => "ImageInput",
|
---|
30 | file => "FileInput",
|
---|
31 |
|
---|
32 | keygen => "KeygenInput",
|
---|
33 | );
|
---|
34 |
|
---|
35 | =head1 NAME
|
---|
36 |
|
---|
37 | HTML::Form - Class that represents an HTML form element
|
---|
38 |
|
---|
39 | =head1 SYNOPSIS
|
---|
40 |
|
---|
41 | use HTML::Form;
|
---|
42 | $form = HTML::Form->parse($html, $base_uri);
|
---|
43 | $form->value(query => "Perl");
|
---|
44 |
|
---|
45 | use LWP::UserAgent;
|
---|
46 | $ua = LWP::UserAgent->new;
|
---|
47 | $response = $ua->request($form->click);
|
---|
48 |
|
---|
49 | =head1 DESCRIPTION
|
---|
50 |
|
---|
51 | Objects of the C<HTML::Form> class represents a single HTML
|
---|
52 | C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
|
---|
53 | sequence of inputs that usually have names, and which can take on
|
---|
54 | various values. The state of a form can be tweaked and it can then be
|
---|
55 | asked to provide C<HTTP::Request> objects that can be passed to the
|
---|
56 | request() method of C<LWP::UserAgent>.
|
---|
57 |
|
---|
58 | The following methods are available:
|
---|
59 |
|
---|
60 | =over 4
|
---|
61 |
|
---|
62 | =item @forms = HTML::Form->parse( $html_document, $base_uri )
|
---|
63 |
|
---|
64 | =item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
|
---|
65 |
|
---|
66 | =item @forms = HTML::Form->parse( $response, %opt )
|
---|
67 |
|
---|
68 | The parse() class method will parse an HTML document and build up
|
---|
69 | C<HTML::Form> objects for each <form> element found. If called in scalar
|
---|
70 | context only returns the first <form>. Returns an empty list if there
|
---|
71 | are no forms to be found.
|
---|
72 |
|
---|
73 | The required arguments is the HTML document to parse ($html_document) and the
|
---|
74 | URI used to retrieve the document ($base_uri). The base URI is needed to resolve
|
---|
75 | relative action URIs. The provided HTML document should be a Unicode string
|
---|
76 | (or US-ASCII).
|
---|
77 |
|
---|
78 | By default HTML::Form assumes that the original document was UTF-8 encoded and
|
---|
79 | thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
|
---|
80 | The charset assumed can be overridden by providing the C<charset> option to
|
---|
81 | parse(). It's a good idea to be explict about this parameter as well, thus
|
---|
82 | the recommended simplest invocation becomes:
|
---|
83 |
|
---|
84 | my @forms = HTML::Form->parse(
|
---|
85 | Encode::decode($encoding, $html_document_bytes),
|
---|
86 | base => $base_uri,
|
---|
87 | charset => $encoding,
|
---|
88 | );
|
---|
89 |
|
---|
90 | If the document was retrieved with LWP then the response object provide methods
|
---|
91 | to obtain a proper value for C<base> and C<charset>:
|
---|
92 |
|
---|
93 | my $ua = LWP::UserAgent->new;
|
---|
94 | my $response = $ua->get("http://www.example.com/form.html");
|
---|
95 | my @forms = HTML::Form->parse($response->decoded_content,
|
---|
96 | base => $response->base,
|
---|
97 | charset => $response->content_charset,
|
---|
98 | );
|
---|
99 |
|
---|
100 | In fact, the parse() method can parse from an C<HTTP::Response> object
|
---|
101 | directly, so the example above can be more conveniently written as:
|
---|
102 |
|
---|
103 | my $ua = LWP::UserAgent->new;
|
---|
104 | my $response = $ua->get("http://www.example.com/form.html");
|
---|
105 | my @forms = HTML::Form->parse($response);
|
---|
106 |
|
---|
107 | Note that any object that implements a decoded_content(), base() and
|
---|
108 | content_charset() method with similar behaviour as C<HTTP::Response> will do.
|
---|
109 |
|
---|
110 | Additional options might be passed in to control how the parse method
|
---|
111 | behaves. The following are all the options currently recognized:
|
---|
112 |
|
---|
113 | =over
|
---|
114 |
|
---|
115 | =item C<< base => $uri >>
|
---|
116 |
|
---|
117 | This is the URI used to retrive the original document. This option is not optional ;-)
|
---|
118 |
|
---|
119 | =item C<< charset => $str >>
|
---|
120 |
|
---|
121 | Specify what charset the original document was encoded in. This is used as
|
---|
122 | the default for accept_charset. If not provided this defaults to "UTF-8".
|
---|
123 |
|
---|
124 | =item C<< verbose => $bool >>
|
---|
125 |
|
---|
126 | Warn (print messages to STDERR) about any bad HTML form constructs found.
|
---|
127 | You can trap these with $SIG{__WARN__}.
|
---|
128 |
|
---|
129 | =item C<< strict => $bool >>
|
---|
130 |
|
---|
131 | Initialize any form objects with the given strict attribute.
|
---|
132 |
|
---|
133 | =back
|
---|
134 |
|
---|
135 | =cut
|
---|
136 |
|
---|
137 | sub parse
|
---|
138 | {
|
---|
139 | my $class = shift;
|
---|
140 | my $html = shift;
|
---|
141 | unshift(@_, "base") if @_ == 1;
|
---|
142 | my %opt = @_;
|
---|
143 |
|
---|
144 | require HTML::TokeParser;
|
---|
145 | my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
|
---|
146 | die "Failed to create HTML::TokeParser object" unless $p;
|
---|
147 |
|
---|
148 | my $base_uri = delete $opt{base};
|
---|
149 | my $charset = delete $opt{charset};
|
---|
150 | my $strict = delete $opt{strict};
|
---|
151 | my $verbose = delete $opt{verbose};
|
---|
152 |
|
---|
153 | if ($^W) {
|
---|
154 | Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
|
---|
155 | }
|
---|
156 |
|
---|
157 | unless (defined $base_uri) {
|
---|
158 | if (ref($html)) {
|
---|
159 | $base_uri = $html->base;
|
---|
160 | }
|
---|
161 | else {
|
---|
162 | Carp::croak("HTML::Form::parse: No \$base_uri provided");
|
---|
163 | }
|
---|
164 | }
|
---|
165 | unless (defined $charset) {
|
---|
166 | if (ref($html) and $html->can("content_charset")) {
|
---|
167 | $charset = $html->content_charset;
|
---|
168 | }
|
---|
169 | unless ($charset) {
|
---|
170 | $charset = "UTF-8";
|
---|
171 | }
|
---|
172 | }
|
---|
173 |
|
---|
174 | my @forms;
|
---|
175 | my $f; # current form
|
---|
176 |
|
---|
177 | my %openselect; # index to the open instance of a select
|
---|
178 |
|
---|
179 | while (my $t = $p->get_tag) {
|
---|
180 | my($tag,$attr) = @$t;
|
---|
181 | if ($tag eq "form") {
|
---|
182 | my $action = delete $attr->{'action'};
|
---|
183 | $action = "" unless defined $action;
|
---|
184 | $action = URI->new_abs($action, $base_uri);
|
---|
185 | $f = $class->new($attr->{'method'},
|
---|
186 | $action,
|
---|
187 | $attr->{'enctype'});
|
---|
188 | $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
|
---|
189 | $f->{default_charset} = $charset;
|
---|
190 | $f->{attr} = $attr;
|
---|
191 | $f->strict(1) if $strict;
|
---|
192 | %openselect = ();
|
---|
193 | push(@forms, $f);
|
---|
194 | my(%labels, $current_label);
|
---|
195 | while (my $t = $p->get_tag) {
|
---|
196 | my($tag, $attr) = @$t;
|
---|
197 | last if $tag eq "/form";
|
---|
198 |
|
---|
199 | # if we are inside a label tag, then keep
|
---|
200 | # appending any text to the current label
|
---|
201 | if(defined $current_label) {
|
---|
202 | $current_label = join " ",
|
---|
203 | grep { defined and length }
|
---|
204 | $current_label,
|
---|
205 | $p->get_phrase;
|
---|
206 | }
|
---|
207 |
|
---|
208 | if ($tag eq "input") {
|
---|
209 | $attr->{value_name} =
|
---|
210 | exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
|
---|
211 | defined $current_label ? $current_label :
|
---|
212 | $p->get_phrase;
|
---|
213 | }
|
---|
214 |
|
---|
215 | if ($tag eq "label") {
|
---|
216 | $current_label = $p->get_phrase;
|
---|
217 | $labels{ $attr->{for} } = $current_label
|
---|
218 | if exists $attr->{for};
|
---|
219 | }
|
---|
220 | elsif ($tag eq "/label") {
|
---|
221 | $current_label = undef;
|
---|
222 | }
|
---|
223 | elsif ($tag eq "input") {
|
---|
224 | my $type = delete $attr->{type} || "text";
|
---|
225 | $f->push_input($type, $attr, $verbose);
|
---|
226 | }
|
---|
227 | elsif ($tag eq "button") {
|
---|
228 | my $type = delete $attr->{type} || "submit";
|
---|
229 | $f->push_input($type, $attr, $verbose);
|
---|
230 | }
|
---|
231 | elsif ($tag eq "textarea") {
|
---|
232 | $attr->{textarea_value} = $attr->{value}
|
---|
233 | if exists $attr->{value};
|
---|
234 | my $text = $p->get_text("/textarea");
|
---|
235 | $attr->{value} = $text;
|
---|
236 | $f->push_input("textarea", $attr, $verbose);
|
---|
237 | }
|
---|
238 | elsif ($tag eq "select") {
|
---|
239 | # rename attributes reserved to come for the option tag
|
---|
240 | for ("value", "value_name") {
|
---|
241 | $attr->{"select_$_"} = delete $attr->{$_}
|
---|
242 | if exists $attr->{$_};
|
---|
243 | }
|
---|
244 | # count this new select option separately
|
---|
245 | my $name = $attr->{name};
|
---|
246 | $name = "" unless defined $name;
|
---|
247 | $openselect{$name}++;
|
---|
248 |
|
---|
249 | while ($t = $p->get_tag) {
|
---|
250 | my $tag = shift @$t;
|
---|
251 | last if $tag eq "/select";
|
---|
252 | next if $tag =~ m,/?optgroup,;
|
---|
253 | next if $tag eq "/option";
|
---|
254 | if ($tag eq "option") {
|
---|
255 | my %a = %{$t->[0]};
|
---|
256 | # rename keys so they don't clash with %attr
|
---|
257 | for (keys %a) {
|
---|
258 | next if $_ eq "value";
|
---|
259 | $a{"option_$_"} = delete $a{$_};
|
---|
260 | }
|
---|
261 | while (my($k,$v) = each %$attr) {
|
---|
262 | $a{$k} = $v;
|
---|
263 | }
|
---|
264 | $a{value_name} = $p->get_trimmed_text;
|
---|
265 | $a{value} = delete $a{value_name}
|
---|
266 | unless defined $a{value};
|
---|
267 | $a{idx} = $openselect{$name};
|
---|
268 | $f->push_input("option", \%a, $verbose);
|
---|
269 | }
|
---|
270 | else {
|
---|
271 | warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
|
---|
272 | if ($tag eq "/form" ||
|
---|
273 | $tag eq "input" ||
|
---|
274 | $tag eq "textarea" ||
|
---|
275 | $tag eq "select" ||
|
---|
276 | $tag eq "keygen")
|
---|
277 | {
|
---|
278 | # MSIE implictly terminate the <select> here, so we
|
---|
279 | # try to do the same. Actually the MSIE behaviour
|
---|
280 | # appears really strange: <input> and <textarea>
|
---|
281 | # do implictly close, but not <select>, <keygen> or
|
---|
282 | # </form>.
|
---|
283 | my $type = ($tag =~ s,^/,,) ? "E" : "S";
|
---|
284 | $p->unget_token([$type, $tag, @$t]);
|
---|
285 | last;
|
---|
286 | }
|
---|
287 | }
|
---|
288 | }
|
---|
289 | }
|
---|
290 | elsif ($tag eq "keygen") {
|
---|
291 | $f->push_input("keygen", $attr, $verbose);
|
---|
292 | }
|
---|
293 | }
|
---|
294 | }
|
---|
295 | elsif ($form_tags{$tag}) {
|
---|
296 | warn("<$tag> outside <form> in $base_uri\n") if $verbose;
|
---|
297 | }
|
---|
298 | }
|
---|
299 | for (@forms) {
|
---|
300 | $_->fixup;
|
---|
301 | }
|
---|
302 |
|
---|
303 | wantarray ? @forms : $forms[0];
|
---|
304 | }
|
---|
305 |
|
---|
306 | sub new {
|
---|
307 | my $class = shift;
|
---|
308 | my $self = bless {}, $class;
|
---|
309 | $self->{method} = uc(shift || "GET");
|
---|
310 | $self->{action} = shift || Carp::croak("No action defined");
|
---|
311 | $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
|
---|
312 | $self->{accept_charset} = "UNKNOWN";
|
---|
313 | $self->{default_charset} = "UTF-8";
|
---|
314 | $self->{inputs} = [@_];
|
---|
315 | $self;
|
---|
316 | }
|
---|
317 |
|
---|
318 |
|
---|
319 | sub push_input
|
---|
320 | {
|
---|
321 | my($self, $type, $attr, $verbose) = @_;
|
---|
322 | $type = lc $type;
|
---|
323 | my $class = $type2class{$type};
|
---|
324 | unless ($class) {
|
---|
325 | Carp::carp("Unknown input type '$type'") if $verbose;
|
---|
326 | $class = "TextInput";
|
---|
327 | }
|
---|
328 | $class = "HTML::Form::$class";
|
---|
329 | my @extra;
|
---|
330 | push(@extra, readonly => 1) if $type eq "hidden";
|
---|
331 | push(@extra, strict => 1) if $self->{strict};
|
---|
332 | if ($type eq "file" && exists $attr->{value}) {
|
---|
333 | # it's not safe to trust the value set by the server
|
---|
334 | # the user always need to explictly set the names of files to upload
|
---|
335 | $attr->{orig_value} = delete $attr->{value};
|
---|
336 | }
|
---|
337 | delete $attr->{type}; # don't confuse the type argument
|
---|
338 | my $input = $class->new(type => $type, %$attr, @extra);
|
---|
339 | $input->add_to_form($self);
|
---|
340 | }
|
---|
341 |
|
---|
342 |
|
---|
343 | =item $method = $form->method
|
---|
344 |
|
---|
345 | =item $form->method( $new_method )
|
---|
346 |
|
---|
347 | This method is gets/sets the I<method> name used for the
|
---|
348 | C<HTTP::Request> generated. It is a string like "GET" or "POST".
|
---|
349 |
|
---|
350 | =item $action = $form->action
|
---|
351 |
|
---|
352 | =item $form->action( $new_action )
|
---|
353 |
|
---|
354 | This method gets/sets the URI which we want to apply the request
|
---|
355 | I<method> to.
|
---|
356 |
|
---|
357 | =item $enctype = $form->enctype
|
---|
358 |
|
---|
359 | =item $form->enctype( $new_enctype )
|
---|
360 |
|
---|
361 | This method gets/sets the encoding type for the form data. It is a
|
---|
362 | string like "application/x-www-form-urlencoded" or "multipart/form-data".
|
---|
363 |
|
---|
364 | =item $accept = $form->accept_charset
|
---|
365 |
|
---|
366 | =item $form->accept_charset( $new_accept )
|
---|
367 |
|
---|
368 | This method gets/sets the list of charset encodings that the server processing
|
---|
369 | the form accepts. Current implementation supports only one-element lists.
|
---|
370 | Default value is "UNKNOWN" which we interpret as a request to use document
|
---|
371 | charset as specified by the 'charset' parameter of the parse() method. To
|
---|
372 | encode character strings you should have modern perl with Encode module. On
|
---|
373 | older perls the setting of this attribute has no effect.
|
---|
374 |
|
---|
375 | =cut
|
---|
376 |
|
---|
377 | BEGIN {
|
---|
378 | # Set up some accesor
|
---|
379 | for (qw(method action enctype accept_charset)) {
|
---|
380 | my $m = $_;
|
---|
381 | no strict 'refs';
|
---|
382 | *{$m} = sub {
|
---|
383 | my $self = shift;
|
---|
384 | my $old = $self->{$m};
|
---|
385 | $self->{$m} = shift if @_;
|
---|
386 | $old;
|
---|
387 | };
|
---|
388 | }
|
---|
389 | *uri = \&action; # alias
|
---|
390 | }
|
---|
391 |
|
---|
392 | =item $value = $form->attr( $name )
|
---|
393 |
|
---|
394 | =item $form->attr( $name, $new_value )
|
---|
395 |
|
---|
396 | This method give access to the original HTML attributes of the <form> tag.
|
---|
397 | The $name should always be passed in lower case.
|
---|
398 |
|
---|
399 | Example:
|
---|
400 |
|
---|
401 | @f = HTML::Form->parse( $html, $foo );
|
---|
402 | @f = grep $_->attr("id") eq "foo", @f;
|
---|
403 | die "No form named 'foo' found" unless @f;
|
---|
404 | $foo = shift @f;
|
---|
405 |
|
---|
406 | =cut
|
---|
407 |
|
---|
408 | sub attr {
|
---|
409 | my $self = shift;
|
---|
410 | my $name = shift;
|
---|
411 | return undef unless defined $name;
|
---|
412 |
|
---|
413 | my $old = $self->{attr}{$name};
|
---|
414 | $self->{attr}{$name} = shift if @_;
|
---|
415 | return $old;
|
---|
416 | }
|
---|
417 |
|
---|
418 | =item $bool = $form->strict
|
---|
419 |
|
---|
420 | =item $form->strict( $bool )
|
---|
421 |
|
---|
422 | Gets/sets the strict attribute of a form. If the strict is turned on
|
---|
423 | the methods that change values of the form will croak if you try to
|
---|
424 | set illegal values or modify readonly fields. The default is not to be strict.
|
---|
425 |
|
---|
426 | =cut
|
---|
427 |
|
---|
428 | sub strict {
|
---|
429 | my $self = shift;
|
---|
430 | my $old = $self->{strict};
|
---|
431 | if (@_) {
|
---|
432 | $self->{strict} = shift;
|
---|
433 | for my $input (@{$self->{inputs}}) {
|
---|
434 | $input->strict($self->{strict});
|
---|
435 | }
|
---|
436 | }
|
---|
437 | return $old;
|
---|
438 | }
|
---|
439 |
|
---|
440 |
|
---|
441 | =item @inputs = $form->inputs
|
---|
442 |
|
---|
443 | This method returns the list of inputs in the form. If called in
|
---|
444 | scalar context it returns the number of inputs contained in the form.
|
---|
445 | See L</INPUTS> for what methods are available for the input objects
|
---|
446 | returned.
|
---|
447 |
|
---|
448 | =cut
|
---|
449 |
|
---|
450 | sub inputs
|
---|
451 | {
|
---|
452 | my $self = shift;
|
---|
453 | @{$self->{'inputs'}};
|
---|
454 | }
|
---|
455 |
|
---|
456 |
|
---|
457 | =item $input = $form->find_input( $selector )
|
---|
458 |
|
---|
459 | =item $input = $form->find_input( $selector, $type )
|
---|
460 |
|
---|
461 | =item $input = $form->find_input( $selector, $type, $index )
|
---|
462 |
|
---|
463 | This method is used to locate specific inputs within the form. All
|
---|
464 | inputs that match the arguments given are returned. In scalar context
|
---|
465 | only the first is returned, or C<undef> if none match.
|
---|
466 |
|
---|
467 | If $selector is specified, then the input's name, id, class attribute must
|
---|
468 | match. A selector prefixed with '#' must match the id attribute of the input.
|
---|
469 | A selector prefixed with '.' matches the class attribute. A selector prefixed
|
---|
470 | with '^' or with no prefix matches the name attribute.
|
---|
471 |
|
---|
472 | If $type is specified, then the input must have the specified type.
|
---|
473 | The following type names are used: "text", "password", "hidden",
|
---|
474 | "textarea", "file", "image", "submit", "radio", "checkbox" and "option".
|
---|
475 |
|
---|
476 | The $index is the sequence number of the input matched where 1 is the
|
---|
477 | first. If combined with $name and/or $type then it select the I<n>th
|
---|
478 | input with the given name and/or type.
|
---|
479 |
|
---|
480 | =cut
|
---|
481 |
|
---|
482 | sub find_input
|
---|
483 | {
|
---|
484 | my($self, $name, $type, $no) = @_;
|
---|
485 | if (wantarray) {
|
---|
486 | my @res;
|
---|
487 | my $c;
|
---|
488 | for (@{$self->{'inputs'}}) {
|
---|
489 | next if defined($name) && !$_->selected($name);
|
---|
490 | next if $type && $type ne $_->{type};
|
---|
491 | $c++;
|
---|
492 | next if $no && $no != $c;
|
---|
493 | push(@res, $_);
|
---|
494 | }
|
---|
495 | return @res;
|
---|
496 |
|
---|
497 | }
|
---|
498 | else {
|
---|
499 | $no ||= 1;
|
---|
500 | for (@{$self->{'inputs'}}) {
|
---|
501 | next if defined($name) && !$_->selected($name);
|
---|
502 | next if $type && $type ne $_->{type};
|
---|
503 | next if --$no;
|
---|
504 | return $_;
|
---|
505 | }
|
---|
506 | return undef;
|
---|
507 | }
|
---|
508 | }
|
---|
509 |
|
---|
510 | sub fixup
|
---|
511 | {
|
---|
512 | my $self = shift;
|
---|
513 | for (@{$self->{'inputs'}}) {
|
---|
514 | $_->fixup;
|
---|
515 | }
|
---|
516 | }
|
---|
517 |
|
---|
518 |
|
---|
519 | =item $value = $form->value( $selector )
|
---|
520 |
|
---|
521 | =item $form->value( $selector, $new_value )
|
---|
522 |
|
---|
523 | The value() method can be used to get/set the value of some input. If
|
---|
524 | strict is enabled and no input has the indicated name, then this method will croak.
|
---|
525 |
|
---|
526 | If multiple inputs have the same name, only the first one will be
|
---|
527 | affected.
|
---|
528 |
|
---|
529 | The call:
|
---|
530 |
|
---|
531 | $form->value('foo')
|
---|
532 |
|
---|
533 | is basically a short-hand for:
|
---|
534 |
|
---|
535 | $form->find_input('foo')->value;
|
---|
536 |
|
---|
537 | =cut
|
---|
538 |
|
---|
539 | sub value
|
---|
540 | {
|
---|
541 | my $self = shift;
|
---|
542 | my $key = shift;
|
---|
543 | my $input = $self->find_input($key);
|
---|
544 | unless ($input) {
|
---|
545 | Carp::croak("No such field '$key'") if $self->{strict};
|
---|
546 | return undef unless @_;
|
---|
547 | $input = $self->push_input("text", { name => $key, value => "" });
|
---|
548 | }
|
---|
549 | local $Carp::CarpLevel = 1;
|
---|
550 | $input->value(@_);
|
---|
551 | }
|
---|
552 |
|
---|
553 | =item @names = $form->param
|
---|
554 |
|
---|
555 | =item @values = $form->param( $name )
|
---|
556 |
|
---|
557 | =item $form->param( $name, $value, ... )
|
---|
558 |
|
---|
559 | =item $form->param( $name, \@values )
|
---|
560 |
|
---|
561 | Alternative interface to examining and setting the values of the form.
|
---|
562 |
|
---|
563 | If called without arguments then it returns the names of all the
|
---|
564 | inputs in the form. The names will not repeat even if multiple inputs
|
---|
565 | have the same name. In scalar context the number of different names
|
---|
566 | is returned.
|
---|
567 |
|
---|
568 | If called with a single argument then it returns the value or values
|
---|
569 | of inputs with the given name. If called in scalar context only the
|
---|
570 | first value is returned. If no input exists with the given name, then
|
---|
571 | C<undef> is returned.
|
---|
572 |
|
---|
573 | If called with 2 or more arguments then it will set values of the
|
---|
574 | named inputs. This form will croak if no inputs have the given name
|
---|
575 | or if any of the values provided does not fit. Values can also be
|
---|
576 | provided as a reference to an array. This form will allow unsetting
|
---|
577 | all values with the given name as well.
|
---|
578 |
|
---|
579 | This interface resembles that of the param() function of the CGI
|
---|
580 | module.
|
---|
581 |
|
---|
582 | =cut
|
---|
583 |
|
---|
584 | sub param {
|
---|
585 | my $self = shift;
|
---|
586 | if (@_) {
|
---|
587 | my $name = shift;
|
---|
588 | my @inputs;
|
---|
589 | for ($self->inputs) {
|
---|
590 | my $n = $_->name;
|
---|
591 | next if !defined($n) || $n ne $name;
|
---|
592 | push(@inputs, $_);
|
---|
593 | }
|
---|
594 |
|
---|
595 | if (@_) {
|
---|
596 | # set
|
---|
597 | die "No '$name' parameter exists" unless @inputs;
|
---|
598 | my @v = @_;
|
---|
599 | @v = @{$v[0]} if @v == 1 && ref($v[0]);
|
---|
600 | while (@v) {
|
---|
601 | my $v = shift @v;
|
---|
602 | my $err;
|
---|
603 | for my $i (0 .. @inputs-1) {
|
---|
604 | eval {
|
---|
605 | $inputs[$i]->value($v);
|
---|
606 | };
|
---|
607 | unless ($@) {
|
---|
608 | undef($err);
|
---|
609 | splice(@inputs, $i, 1);
|
---|
610 | last;
|
---|
611 | }
|
---|
612 | $err ||= $@;
|
---|
613 | }
|
---|
614 | die $err if $err;
|
---|
615 | }
|
---|
616 |
|
---|
617 | # the rest of the input should be cleared
|
---|
618 | for (@inputs) {
|
---|
619 | $_->value(undef);
|
---|
620 | }
|
---|
621 | }
|
---|
622 | else {
|
---|
623 | # get
|
---|
624 | my @v;
|
---|
625 | for (@inputs) {
|
---|
626 | if (defined(my $v = $_->value)) {
|
---|
627 | push(@v, $v);
|
---|
628 | }
|
---|
629 | }
|
---|
630 | return wantarray ? @v : $v[0];
|
---|
631 | }
|
---|
632 | }
|
---|
633 | else {
|
---|
634 | # list parameter names
|
---|
635 | my @n;
|
---|
636 | my %seen;
|
---|
637 | for ($self->inputs) {
|
---|
638 | my $n = $_->name;
|
---|
639 | next if !defined($n) || $seen{$n}++;
|
---|
640 | push(@n, $n);
|
---|
641 | }
|
---|
642 | return @n;
|
---|
643 | }
|
---|
644 | }
|
---|
645 |
|
---|
646 |
|
---|
647 | =item $form->try_others( \&callback )
|
---|
648 |
|
---|
649 | This method will iterate over all permutations of unvisited enumerated
|
---|
650 | values (<select>, <radio>, <checkbox>) and invoke the callback for
|
---|
651 | each. The callback is passed the $form as argument. The return value
|
---|
652 | from the callback is ignored and the try_others() method itself does
|
---|
653 | not return anything.
|
---|
654 |
|
---|
655 | =cut
|
---|
656 |
|
---|
657 | sub try_others
|
---|
658 | {
|
---|
659 | my($self, $cb) = @_;
|
---|
660 | my @try;
|
---|
661 | for (@{$self->{'inputs'}}) {
|
---|
662 | my @not_tried_yet = $_->other_possible_values;
|
---|
663 | next unless @not_tried_yet;
|
---|
664 | push(@try, [\@not_tried_yet, $_]);
|
---|
665 | }
|
---|
666 | return unless @try;
|
---|
667 | $self->_try($cb, \@try, 0);
|
---|
668 | }
|
---|
669 |
|
---|
670 | sub _try
|
---|
671 | {
|
---|
672 | my($self, $cb, $try, $i) = @_;
|
---|
673 | for (@{$try->[$i][0]}) {
|
---|
674 | $try->[$i][1]->value($_);
|
---|
675 | &$cb($self);
|
---|
676 | $self->_try($cb, $try, $i+1) if $i+1 < @$try;
|
---|
677 | }
|
---|
678 | }
|
---|
679 |
|
---|
680 |
|
---|
681 | =item $request = $form->make_request
|
---|
682 |
|
---|
683 | Will return an C<HTTP::Request> object that reflects the current setting
|
---|
684 | of the form. You might want to use the click() method instead.
|
---|
685 |
|
---|
686 | =cut
|
---|
687 |
|
---|
688 | sub make_request
|
---|
689 | {
|
---|
690 | my $self = shift;
|
---|
691 | my $method = uc $self->{'method'};
|
---|
692 | my $uri = $self->{'action'};
|
---|
693 | my $enctype = $self->{'enctype'};
|
---|
694 | my @form = $self->form;
|
---|
695 |
|
---|
696 | my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
|
---|
697 | if ($Encode_available) {
|
---|
698 | foreach my $fi (@form) {
|
---|
699 | $fi = Encode::encode($charset, $fi) unless ref($fi);
|
---|
700 | }
|
---|
701 | }
|
---|
702 |
|
---|
703 | if ($method eq "GET") {
|
---|
704 | require HTTP::Request;
|
---|
705 | $uri = URI->new($uri, "http");
|
---|
706 | $uri->query_form(@form);
|
---|
707 | return HTTP::Request->new(GET => $uri);
|
---|
708 | }
|
---|
709 | elsif ($method eq "POST") {
|
---|
710 | require HTTP::Request::Common;
|
---|
711 | return HTTP::Request::Common::POST($uri, \@form,
|
---|
712 | Content_Type => $enctype);
|
---|
713 | }
|
---|
714 | else {
|
---|
715 | Carp::croak("Unknown method '$method'");
|
---|
716 | }
|
---|
717 | }
|
---|
718 |
|
---|
719 |
|
---|
720 | =item $request = $form->click
|
---|
721 |
|
---|
722 | =item $request = $form->click( $selector )
|
---|
723 |
|
---|
724 | =item $request = $form->click( $x, $y )
|
---|
725 |
|
---|
726 | =item $request = $form->click( $selector, $x, $y )
|
---|
727 |
|
---|
728 | Will "click" on the first clickable input (which will be of type
|
---|
729 | C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
|
---|
730 | object that can then be passed to C<LWP::UserAgent> if you want to
|
---|
731 | obtain the server response.
|
---|
732 |
|
---|
733 | If a $selector is specified, we will click on the first clickable input
|
---|
734 | matching the selector, and the method will croak if no matching clickable
|
---|
735 | input is found. If $selector is I<not> specified, then it
|
---|
736 | is ok if the form contains no clickable inputs. In this case the
|
---|
737 | click() method returns the same request as the make_request() method
|
---|
738 | would do. See description of the find_input() method above for how
|
---|
739 | the $selector is specified.
|
---|
740 |
|
---|
741 | If there are multiple clickable inputs with the same name, then there
|
---|
742 | is no way to get the click() method of the C<HTML::Form> to click on
|
---|
743 | any but the first. If you need this you would have to locate the
|
---|
744 | input with find_input() and invoke the click() method on the given
|
---|
745 | input yourself.
|
---|
746 |
|
---|
747 | A click coordinate pair can also be provided, but this only makes a
|
---|
748 | difference if you clicked on an image. The default coordinate is
|
---|
749 | (1,1). The upper-left corner of the image is (0,0), but some badly
|
---|
750 | coded CGI scripts are known to not recognize this. Therefore (1,1) was
|
---|
751 | selected as a safer default.
|
---|
752 |
|
---|
753 | =cut
|
---|
754 |
|
---|
755 | sub click
|
---|
756 | {
|
---|
757 | my $self = shift;
|
---|
758 | my $name;
|
---|
759 | $name = shift if (@_ % 2) == 1; # odd number of arguments
|
---|
760 |
|
---|
761 | # try to find first submit button to activate
|
---|
762 | for (@{$self->{'inputs'}}) {
|
---|
763 | next unless $_->can("click");
|
---|
764 | next if $name && !$_->selected($name);
|
---|
765 | next if $_->disabled;
|
---|
766 | return $_->click($self, @_);
|
---|
767 | }
|
---|
768 | Carp::croak("No clickable input with name $name") if $name;
|
---|
769 | $self->make_request;
|
---|
770 | }
|
---|
771 |
|
---|
772 |
|
---|
773 | =item @kw = $form->form
|
---|
774 |
|
---|
775 | Returns the current setting as a sequence of key/value pairs. Note
|
---|
776 | that keys might be repeated, which means that some values might be
|
---|
777 | lost if the return values are assigned to a hash.
|
---|
778 |
|
---|
779 | In scalar context this method returns the number of key/value pairs
|
---|
780 | generated.
|
---|
781 |
|
---|
782 | =cut
|
---|
783 |
|
---|
784 | sub form
|
---|
785 | {
|
---|
786 | my $self = shift;
|
---|
787 | map { $_->form_name_value($self) } @{$self->{'inputs'}};
|
---|
788 | }
|
---|
789 |
|
---|
790 |
|
---|
791 | =item $form->dump
|
---|
792 |
|
---|
793 | Returns a textual representation of current state of the form. Mainly
|
---|
794 | useful for debugging. If called in void context, then the dump is
|
---|
795 | printed on STDERR.
|
---|
796 |
|
---|
797 | =cut
|
---|
798 |
|
---|
799 | sub dump
|
---|
800 | {
|
---|
801 | my $self = shift;
|
---|
802 | my $method = $self->{'method'};
|
---|
803 | my $uri = $self->{'action'};
|
---|
804 | my $enctype = $self->{'enctype'};
|
---|
805 | my $dump = "$method $uri";
|
---|
806 | $dump .= " ($enctype)"
|
---|
807 | if $enctype ne "application/x-www-form-urlencoded";
|
---|
808 | $dump .= " [$self->{attr}{name}]"
|
---|
809 | if exists $self->{attr}{name};
|
---|
810 | $dump .= "\n";
|
---|
811 | for ($self->inputs) {
|
---|
812 | $dump .= " " . $_->dump . "\n";
|
---|
813 | }
|
---|
814 | print STDERR $dump unless defined wantarray;
|
---|
815 | $dump;
|
---|
816 | }
|
---|
817 |
|
---|
818 |
|
---|
819 | #---------------------------------------------------
|
---|
820 | package HTML::Form::Input;
|
---|
821 |
|
---|
822 | =back
|
---|
823 |
|
---|
824 | =head1 INPUTS
|
---|
825 |
|
---|
826 | An C<HTML::Form> objects contains a sequence of I<inputs>. References to
|
---|
827 | the inputs can be obtained with the $form->inputs or $form->find_input
|
---|
828 | methods.
|
---|
829 |
|
---|
830 | Note that there is I<not> a one-to-one correspondence between input
|
---|
831 | I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
|
---|
832 | input object basically represents a name/value pair, so when multiple
|
---|
833 | HTML elements contribute to the same name/value pair in the submitted
|
---|
834 | form they are combined.
|
---|
835 |
|
---|
836 | The input elements that are mapped one-to-one are "text", "textarea",
|
---|
837 | "password", "hidden", "file", "image", "submit" and "checkbox". For
|
---|
838 | the "radio" and "option" inputs the story is not as simple: All
|
---|
839 | E<lt>input type="radio"E<gt> elements with the same name will
|
---|
840 | contribute to the same input radio object. The number of radio input
|
---|
841 | objects will be the same as the number of distinct names used for the
|
---|
842 | E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
|
---|
843 | without the C<multiple> attribute there will be one input object of
|
---|
844 | type of "option". For a E<lt>select multipleE<gt> element there will
|
---|
845 | be one input object for each contained E<lt>optionE<gt> element. Each
|
---|
846 | one of these option objects will have the same name.
|
---|
847 |
|
---|
848 | The following methods are available for the I<input> objects:
|
---|
849 |
|
---|
850 | =over 4
|
---|
851 |
|
---|
852 | =cut
|
---|
853 |
|
---|
854 | sub new
|
---|
855 | {
|
---|
856 | my $class = shift;
|
---|
857 | my $self = bless {@_}, $class;
|
---|
858 | $self;
|
---|
859 | }
|
---|
860 |
|
---|
861 | sub add_to_form
|
---|
862 | {
|
---|
863 | my($self, $form) = @_;
|
---|
864 | push(@{$form->{'inputs'}}, $self);
|
---|
865 | $self;
|
---|
866 | }
|
---|
867 |
|
---|
868 | sub strict {
|
---|
869 | my $self = shift;
|
---|
870 | my $old = $self->{strict};
|
---|
871 | if (@_) {
|
---|
872 | $self->{strict} = shift;
|
---|
873 | }
|
---|
874 | $old;
|
---|
875 | }
|
---|
876 |
|
---|
877 | sub fixup {}
|
---|
878 |
|
---|
879 |
|
---|
880 | =item $input->type
|
---|
881 |
|
---|
882 | Returns the type of this input. The type is one of the following
|
---|
883 | strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
|
---|
884 | "radio", "checkbox" or "option".
|
---|
885 |
|
---|
886 | =cut
|
---|
887 |
|
---|
888 | sub type
|
---|
889 | {
|
---|
890 | shift->{type};
|
---|
891 | }
|
---|
892 |
|
---|
893 | =item $name = $input->name
|
---|
894 |
|
---|
895 | =item $input->name( $new_name )
|
---|
896 |
|
---|
897 | This method can be used to get/set the current name of the input.
|
---|
898 |
|
---|
899 | =item $input->id
|
---|
900 |
|
---|
901 | =item $input->class
|
---|
902 |
|
---|
903 | These methods can be used to get/set the current id or class attribute for the input.
|
---|
904 |
|
---|
905 | =item $input->selected( $selector )
|
---|
906 |
|
---|
907 | Returns TRUE if the given selector matched the input. See the description of
|
---|
908 | the find_input() method above for a description of the selector syntax.
|
---|
909 |
|
---|
910 | =item $value = $input->value
|
---|
911 |
|
---|
912 | =item $input->value( $new_value )
|
---|
913 |
|
---|
914 | This method can be used to get/set the current value of an
|
---|
915 | input.
|
---|
916 |
|
---|
917 | If strict is enabled and the input only can take an enumerated list of values,
|
---|
918 | then it is an error to try to set it to something else and the method will
|
---|
919 | croak if you try.
|
---|
920 |
|
---|
921 | You will also be able to set the value of read-only inputs, but a
|
---|
922 | warning will be generated if running under C<perl -w>.
|
---|
923 |
|
---|
924 | =cut
|
---|
925 |
|
---|
926 | sub name
|
---|
927 | {
|
---|
928 | my $self = shift;
|
---|
929 | my $old = $self->{name};
|
---|
930 | $self->{name} = shift if @_;
|
---|
931 | $old;
|
---|
932 | }
|
---|
933 |
|
---|
934 | sub id
|
---|
935 | {
|
---|
936 | my $self = shift;
|
---|
937 | my $old = $self->{id};
|
---|
938 | $self->{id} = shift if @_;
|
---|
939 | $old;
|
---|
940 | }
|
---|
941 |
|
---|
942 | sub class
|
---|
943 | {
|
---|
944 | my $self = shift;
|
---|
945 | my $old = $self->{class};
|
---|
946 | $self->{class} = shift if @_;
|
---|
947 | $old;
|
---|
948 | }
|
---|
949 |
|
---|
950 | sub selected {
|
---|
951 | my($self, $sel) = @_;
|
---|
952 | return undef unless defined $sel;
|
---|
953 | my $attr =
|
---|
954 | $sel =~ s/^\^// ? "name" :
|
---|
955 | $sel =~ s/^#// ? "id" :
|
---|
956 | $sel =~ s/^\.// ? "class" :
|
---|
957 | "name";
|
---|
958 | return 0 unless defined $self->{$attr};
|
---|
959 | return $self->{$attr} eq $sel;
|
---|
960 | }
|
---|
961 |
|
---|
962 | sub value
|
---|
963 | {
|
---|
964 | my $self = shift;
|
---|
965 | my $old = $self->{value};
|
---|
966 | $self->{value} = shift if @_;
|
---|
967 | $old;
|
---|
968 | }
|
---|
969 |
|
---|
970 | =item $input->possible_values
|
---|
971 |
|
---|
972 | Returns a list of all values that an input can take. For inputs that
|
---|
973 | do not have discrete values, this returns an empty list.
|
---|
974 |
|
---|
975 | =cut
|
---|
976 |
|
---|
977 | sub possible_values
|
---|
978 | {
|
---|
979 | return;
|
---|
980 | }
|
---|
981 |
|
---|
982 | =item $input->other_possible_values
|
---|
983 |
|
---|
984 | Returns a list of all values not tried yet.
|
---|
985 |
|
---|
986 | =cut
|
---|
987 |
|
---|
988 | sub other_possible_values
|
---|
989 | {
|
---|
990 | return;
|
---|
991 | }
|
---|
992 |
|
---|
993 | =item $input->value_names
|
---|
994 |
|
---|
995 | For some inputs the values can have names that are different from the
|
---|
996 | values themselves. The number of names returned by this method will
|
---|
997 | match the number of values reported by $input->possible_values.
|
---|
998 |
|
---|
999 | When setting values using the value() method it is also possible to
|
---|
1000 | use the value names in place of the value itself.
|
---|
1001 |
|
---|
1002 | =cut
|
---|
1003 |
|
---|
1004 | sub value_names {
|
---|
1005 | return
|
---|
1006 | }
|
---|
1007 |
|
---|
1008 | =item $bool = $input->readonly
|
---|
1009 |
|
---|
1010 | =item $input->readonly( $bool )
|
---|
1011 |
|
---|
1012 | This method is used to get/set the value of the readonly attribute.
|
---|
1013 | You are allowed to modify the value of readonly inputs, but setting
|
---|
1014 | the value will generate some noise when warnings are enabled. Hidden
|
---|
1015 | fields always start out readonly.
|
---|
1016 |
|
---|
1017 | =cut
|
---|
1018 |
|
---|
1019 | sub readonly {
|
---|
1020 | my $self = shift;
|
---|
1021 | my $old = $self->{readonly};
|
---|
1022 | $self->{readonly} = shift if @_;
|
---|
1023 | $old;
|
---|
1024 | }
|
---|
1025 |
|
---|
1026 | =item $bool = $input->disabled
|
---|
1027 |
|
---|
1028 | =item $input->disabled( $bool )
|
---|
1029 |
|
---|
1030 | This method is used to get/set the value of the disabled attribute.
|
---|
1031 | Disabled inputs do not contribute any key/value pairs for the form
|
---|
1032 | value.
|
---|
1033 |
|
---|
1034 | =cut
|
---|
1035 |
|
---|
1036 | sub disabled {
|
---|
1037 | my $self = shift;
|
---|
1038 | my $old = $self->{disabled};
|
---|
1039 | $self->{disabled} = shift if @_;
|
---|
1040 | $old;
|
---|
1041 | }
|
---|
1042 |
|
---|
1043 | =item $input->form_name_value
|
---|
1044 |
|
---|
1045 | Returns a (possible empty) list of key/value pairs that should be
|
---|
1046 | incorporated in the form value from this input.
|
---|
1047 |
|
---|
1048 | =cut
|
---|
1049 |
|
---|
1050 | sub form_name_value
|
---|
1051 | {
|
---|
1052 | my $self = shift;
|
---|
1053 | my $name = $self->{'name'};
|
---|
1054 | return unless defined $name;
|
---|
1055 | return if $self->disabled;
|
---|
1056 | my $value = $self->value;
|
---|
1057 | return unless defined $value;
|
---|
1058 | return ($name => $value);
|
---|
1059 | }
|
---|
1060 |
|
---|
1061 | sub dump
|
---|
1062 | {
|
---|
1063 | my $self = shift;
|
---|
1064 | my $name = $self->name;
|
---|
1065 | $name = "<NONAME>" unless defined $name;
|
---|
1066 | my $value = $self->value;
|
---|
1067 | $value = "<UNDEF>" unless defined $value;
|
---|
1068 | my $dump = "$name=$value";
|
---|
1069 |
|
---|
1070 | my $type = $self->type;
|
---|
1071 |
|
---|
1072 | $type .= " disabled" if $self->disabled;
|
---|
1073 | $type .= " readonly" if $self->readonly;
|
---|
1074 | return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
|
---|
1075 |
|
---|
1076 | my @menu;
|
---|
1077 | my $i = 0;
|
---|
1078 | for (@{$self->{menu}}) {
|
---|
1079 | my $opt = $_->{value};
|
---|
1080 | $opt = "<UNDEF>" unless defined $opt;
|
---|
1081 | $opt .= "/$_->{name}"
|
---|
1082 | if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
|
---|
1083 | substr($opt,0,0) = "-" if $_->{disabled};
|
---|
1084 | if (exists $self->{current} && $self->{current} == $i) {
|
---|
1085 | substr($opt,0,0) = "!" unless $_->{seen};
|
---|
1086 | substr($opt,0,0) = "*";
|
---|
1087 | }
|
---|
1088 | else {
|
---|
1089 | substr($opt,0,0) = ":" if $_->{seen};
|
---|
1090 | }
|
---|
1091 | push(@menu, $opt);
|
---|
1092 | $i++;
|
---|
1093 | }
|
---|
1094 |
|
---|
1095 | return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
|
---|
1096 | }
|
---|
1097 |
|
---|
1098 |
|
---|
1099 | #---------------------------------------------------
|
---|
1100 | package HTML::Form::TextInput;
|
---|
1101 | @HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
|
---|
1102 |
|
---|
1103 | #input/text
|
---|
1104 | #input/password
|
---|
1105 | #input/hidden
|
---|
1106 | #textarea
|
---|
1107 |
|
---|
1108 | sub value
|
---|
1109 | {
|
---|
1110 | my $self = shift;
|
---|
1111 | my $old = $self->{value};
|
---|
1112 | $old = "" unless defined $old;
|
---|
1113 | if (@_) {
|
---|
1114 | Carp::croak("Input '$self->{name}' is readonly")
|
---|
1115 | if $self->{strict} && $self->{readonly};
|
---|
1116 | my $new = shift;
|
---|
1117 | my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
|
---|
1118 | Carp::croak("Input '$self->{name}' has maxlength '$n'")
|
---|
1119 | if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
|
---|
1120 | $self->{value} = $new;
|
---|
1121 | }
|
---|
1122 | $old;
|
---|
1123 | }
|
---|
1124 |
|
---|
1125 | #---------------------------------------------------
|
---|
1126 | package HTML::Form::IgnoreInput;
|
---|
1127 | @HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
|
---|
1128 |
|
---|
1129 | #input/button
|
---|
1130 | #input/reset
|
---|
1131 |
|
---|
1132 | sub value { return }
|
---|
1133 |
|
---|
1134 |
|
---|
1135 | #---------------------------------------------------
|
---|
1136 | package HTML::Form::ListInput;
|
---|
1137 | @HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
|
---|
1138 |
|
---|
1139 | #select/option (val1, val2, ....)
|
---|
1140 | #input/radio (undef, val1, val2,...)
|
---|
1141 | #input/checkbox (undef, value)
|
---|
1142 | #select-multiple/option (undef, value)
|
---|
1143 |
|
---|
1144 | sub new
|
---|
1145 | {
|
---|
1146 | my $class = shift;
|
---|
1147 | my $self = $class->SUPER::new(@_);
|
---|
1148 |
|
---|
1149 | my $value = delete $self->{value};
|
---|
1150 | my $value_name = delete $self->{value_name};
|
---|
1151 | my $type = $self->{type};
|
---|
1152 |
|
---|
1153 | if ($type eq "checkbox") {
|
---|
1154 | $value = "on" unless defined $value;
|
---|
1155 | $self->{menu} = [
|
---|
1156 | { value => undef, name => "off", },
|
---|
1157 | { value => $value, name => $value_name, },
|
---|
1158 | ];
|
---|
1159 | $self->{current} = (delete $self->{checked}) ? 1 : 0;
|
---|
1160 | ;
|
---|
1161 | }
|
---|
1162 | else {
|
---|
1163 | $self->{option_disabled}++
|
---|
1164 | if $type eq "radio" && delete $self->{disabled};
|
---|
1165 | $self->{menu} = [
|
---|
1166 | {value => $value, name => $value_name},
|
---|
1167 | ];
|
---|
1168 | my $checked = $self->{checked} || $self->{option_selected};
|
---|
1169 | delete $self->{checked};
|
---|
1170 | delete $self->{option_selected};
|
---|
1171 | if (exists $self->{multiple}) {
|
---|
1172 | unshift(@{$self->{menu}}, { value => undef, name => "off"});
|
---|
1173 | $self->{current} = $checked ? 1 : 0;
|
---|
1174 | }
|
---|
1175 | else {
|
---|
1176 | $self->{current} = 0 if $checked;
|
---|
1177 | }
|
---|
1178 | }
|
---|
1179 | $self;
|
---|
1180 | }
|
---|
1181 |
|
---|
1182 | sub add_to_form
|
---|
1183 | {
|
---|
1184 | my($self, $form) = @_;
|
---|
1185 | my $type = $self->type;
|
---|
1186 |
|
---|
1187 | return $self->SUPER::add_to_form($form)
|
---|
1188 | if $type eq "checkbox";
|
---|
1189 |
|
---|
1190 | if ($type eq "option" && exists $self->{multiple}) {
|
---|
1191 | $self->{disabled} ||= delete $self->{option_disabled};
|
---|
1192 | return $self->SUPER::add_to_form($form);
|
---|
1193 | }
|
---|
1194 |
|
---|
1195 | die "Assert" if @{$self->{menu}} != 1;
|
---|
1196 | my $m = $self->{menu}[0];
|
---|
1197 | $m->{disabled}++ if delete $self->{option_disabled};
|
---|
1198 |
|
---|
1199 | my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
|
---|
1200 | return $self->SUPER::add_to_form($form) unless $prev;
|
---|
1201 |
|
---|
1202 | # merge menues
|
---|
1203 | $prev->{current} = @{$prev->{menu}} if exists $self->{current};
|
---|
1204 | push(@{$prev->{menu}}, $m);
|
---|
1205 | }
|
---|
1206 |
|
---|
1207 | sub fixup
|
---|
1208 | {
|
---|
1209 | my $self = shift;
|
---|
1210 | if ($self->{type} eq "option" && !(exists $self->{current})) {
|
---|
1211 | $self->{current} = 0;
|
---|
1212 | }
|
---|
1213 | $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
|
---|
1214 | }
|
---|
1215 |
|
---|
1216 | sub disabled
|
---|
1217 | {
|
---|
1218 | my $self = shift;
|
---|
1219 | my $type = $self->type;
|
---|
1220 |
|
---|
1221 | my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
|
---|
1222 | if (@_) {
|
---|
1223 | my $v = shift;
|
---|
1224 | $self->{disabled} = $v;
|
---|
1225 | for (@{$self->{menu}}) {
|
---|
1226 | $_->{disabled} = $v;
|
---|
1227 | }
|
---|
1228 | }
|
---|
1229 | return $old;
|
---|
1230 | }
|
---|
1231 |
|
---|
1232 | sub _menu_all_disabled {
|
---|
1233 | for (@_) {
|
---|
1234 | return 0 unless $_->{disabled};
|
---|
1235 | }
|
---|
1236 | return 1;
|
---|
1237 | }
|
---|
1238 |
|
---|
1239 | sub value
|
---|
1240 | {
|
---|
1241 | my $self = shift;
|
---|
1242 | my $old;
|
---|
1243 | $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
|
---|
1244 | $old = $self->{value} if exists $self->{value};
|
---|
1245 | if (@_) {
|
---|
1246 | my $i = 0;
|
---|
1247 | my $val = shift;
|
---|
1248 | my $cur;
|
---|
1249 | my $disabled;
|
---|
1250 | for (@{$self->{menu}}) {
|
---|
1251 | if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
|
---|
1252 | (!defined($val) && !defined($_->{value}))
|
---|
1253 | )
|
---|
1254 | {
|
---|
1255 | $cur = $i;
|
---|
1256 | $disabled = $_->{disabled};
|
---|
1257 | last unless $disabled;
|
---|
1258 | }
|
---|
1259 | $i++;
|
---|
1260 | }
|
---|
1261 | if (!(defined $cur) || $disabled) {
|
---|
1262 | if (defined $val) {
|
---|
1263 | # try to search among the alternative names as well
|
---|
1264 | my $i = 0;
|
---|
1265 | my $cur_ignorecase;
|
---|
1266 | my $lc_val = lc($val);
|
---|
1267 | for (@{$self->{menu}}) {
|
---|
1268 | if (defined $_->{name}) {
|
---|
1269 | if ($val eq $_->{name}) {
|
---|
1270 | $disabled = $_->{disabled};
|
---|
1271 | $cur = $i;
|
---|
1272 | last unless $disabled;
|
---|
1273 | }
|
---|
1274 | if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
|
---|
1275 | $cur_ignorecase = $i;
|
---|
1276 | }
|
---|
1277 | }
|
---|
1278 | $i++;
|
---|
1279 | }
|
---|
1280 | unless (defined $cur) {
|
---|
1281 | $cur = $cur_ignorecase;
|
---|
1282 | if (defined $cur) {
|
---|
1283 | $disabled = $self->{menu}[$cur]{disabled};
|
---|
1284 | }
|
---|
1285 | elsif ($self->{strict}) {
|
---|
1286 | my $n = $self->name;
|
---|
1287 | Carp::croak("Illegal value '$val' for field '$n'");
|
---|
1288 | }
|
---|
1289 | }
|
---|
1290 | }
|
---|
1291 | elsif ($self->{strict}) {
|
---|
1292 | my $n = $self->name;
|
---|
1293 | Carp::croak("The '$n' field can't be unchecked");
|
---|
1294 | }
|
---|
1295 | }
|
---|
1296 | if ($self->{strict} && $disabled) {
|
---|
1297 | my $n = $self->name;
|
---|
1298 | Carp::croak("The value '$val' has been disabled for field '$n'");
|
---|
1299 | }
|
---|
1300 | if (defined $cur) {
|
---|
1301 | $self->{current} = $cur;
|
---|
1302 | $self->{menu}[$cur]{seen}++;
|
---|
1303 | delete $self->{value};
|
---|
1304 | }
|
---|
1305 | else {
|
---|
1306 | $self->{value} = $val;
|
---|
1307 | delete $self->{current};
|
---|
1308 | }
|
---|
1309 | }
|
---|
1310 | $old;
|
---|
1311 | }
|
---|
1312 |
|
---|
1313 | =item $input->check
|
---|
1314 |
|
---|
1315 | Some input types represent toggles that can be turned on/off. This
|
---|
1316 | includes "checkbox" and "option" inputs. Calling this method turns
|
---|
1317 | this input on without having to know the value name. If the input is
|
---|
1318 | already on, then nothing happens.
|
---|
1319 |
|
---|
1320 | This has the same effect as:
|
---|
1321 |
|
---|
1322 | $input->value($input->possible_values[1]);
|
---|
1323 |
|
---|
1324 | The input can be turned off with:
|
---|
1325 |
|
---|
1326 | $input->value(undef);
|
---|
1327 |
|
---|
1328 | =cut
|
---|
1329 |
|
---|
1330 | sub check
|
---|
1331 | {
|
---|
1332 | my $self = shift;
|
---|
1333 | $self->{current} = 1;
|
---|
1334 | $self->{menu}[1]{seen}++;
|
---|
1335 | }
|
---|
1336 |
|
---|
1337 | sub possible_values
|
---|
1338 | {
|
---|
1339 | my $self = shift;
|
---|
1340 | map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
|
---|
1341 | }
|
---|
1342 |
|
---|
1343 | sub other_possible_values
|
---|
1344 | {
|
---|
1345 | my $self = shift;
|
---|
1346 | map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
|
---|
1347 | }
|
---|
1348 |
|
---|
1349 | sub value_names {
|
---|
1350 | my $self = shift;
|
---|
1351 | my @names;
|
---|
1352 | for (@{$self->{menu}}) {
|
---|
1353 | my $n = $_->{name};
|
---|
1354 | $n = $_->{value} unless defined $n;
|
---|
1355 | push(@names, $n);
|
---|
1356 | }
|
---|
1357 | @names;
|
---|
1358 | }
|
---|
1359 |
|
---|
1360 |
|
---|
1361 | #---------------------------------------------------
|
---|
1362 | package HTML::Form::SubmitInput;
|
---|
1363 | @HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
|
---|
1364 |
|
---|
1365 | #input/image
|
---|
1366 | #input/submit
|
---|
1367 |
|
---|
1368 | =item $input->click($form, $x, $y)
|
---|
1369 |
|
---|
1370 | Some input types (currently "submit" buttons and "images") can be
|
---|
1371 | clicked to submit the form. The click() method returns the
|
---|
1372 | corresponding C<HTTP::Request> object.
|
---|
1373 |
|
---|
1374 | =cut
|
---|
1375 |
|
---|
1376 | sub click
|
---|
1377 | {
|
---|
1378 | my($self,$form,$x,$y) = @_;
|
---|
1379 | for ($x, $y) { $_ = 1 unless defined; }
|
---|
1380 | local($self->{clicked}) = [$x,$y];
|
---|
1381 | return $form->make_request;
|
---|
1382 | }
|
---|
1383 |
|
---|
1384 | sub form_name_value
|
---|
1385 | {
|
---|
1386 | my $self = shift;
|
---|
1387 | return unless $self->{clicked};
|
---|
1388 | return $self->SUPER::form_name_value(@_);
|
---|
1389 | }
|
---|
1390 |
|
---|
1391 |
|
---|
1392 | #---------------------------------------------------
|
---|
1393 | package HTML::Form::ImageInput;
|
---|
1394 | @HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
|
---|
1395 |
|
---|
1396 | sub form_name_value
|
---|
1397 | {
|
---|
1398 | my $self = shift;
|
---|
1399 | my $clicked = $self->{clicked};
|
---|
1400 | return unless $clicked;
|
---|
1401 | return if $self->{disabled};
|
---|
1402 | my $name = $self->{name};
|
---|
1403 | $name = (defined($name) && length($name)) ? "$name." : "";
|
---|
1404 | return ("${name}x" => $clicked->[0],
|
---|
1405 | "${name}y" => $clicked->[1]
|
---|
1406 | );
|
---|
1407 | }
|
---|
1408 |
|
---|
1409 | #---------------------------------------------------
|
---|
1410 | package HTML::Form::FileInput;
|
---|
1411 | @HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
|
---|
1412 |
|
---|
1413 | =back
|
---|
1414 |
|
---|
1415 | If the input is of type C<file>, then it has these additional methods:
|
---|
1416 |
|
---|
1417 | =over 4
|
---|
1418 |
|
---|
1419 | =item $input->file
|
---|
1420 |
|
---|
1421 | This is just an alias for the value() method. It sets the filename to
|
---|
1422 | read data from.
|
---|
1423 |
|
---|
1424 | For security reasons this field will never be initialized from the parsing
|
---|
1425 | of a form. This prevents the server from triggering stealth uploads of
|
---|
1426 | arbitrary files from the client machine.
|
---|
1427 |
|
---|
1428 | =cut
|
---|
1429 |
|
---|
1430 | sub file {
|
---|
1431 | my $self = shift;
|
---|
1432 | $self->value(@_);
|
---|
1433 | }
|
---|
1434 |
|
---|
1435 | =item $filename = $input->filename
|
---|
1436 |
|
---|
1437 | =item $input->filename( $new_filename )
|
---|
1438 |
|
---|
1439 | This get/sets the filename reported to the server during file upload.
|
---|
1440 | This attribute defaults to the value reported by the file() method.
|
---|
1441 |
|
---|
1442 | =cut
|
---|
1443 |
|
---|
1444 | sub filename {
|
---|
1445 | my $self = shift;
|
---|
1446 | my $old = $self->{filename};
|
---|
1447 | $self->{filename} = shift if @_;
|
---|
1448 | $old = $self->file unless defined $old;
|
---|
1449 | $old;
|
---|
1450 | }
|
---|
1451 |
|
---|
1452 | =item $content = $input->content
|
---|
1453 |
|
---|
1454 | =item $input->content( $new_content )
|
---|
1455 |
|
---|
1456 | This get/sets the file content provided to the server during file
|
---|
1457 | upload. This method can be used if you do not want the content to be
|
---|
1458 | read from an actual file.
|
---|
1459 |
|
---|
1460 | =cut
|
---|
1461 |
|
---|
1462 | sub content {
|
---|
1463 | my $self = shift;
|
---|
1464 | my $old = $self->{content};
|
---|
1465 | $self->{content} = shift if @_;
|
---|
1466 | $old;
|
---|
1467 | }
|
---|
1468 |
|
---|
1469 | =item @headers = $input->headers
|
---|
1470 |
|
---|
1471 | =item input->headers($key => $value, .... )
|
---|
1472 |
|
---|
1473 | This get/set additional header fields describing the file uploaded.
|
---|
1474 | This can for instance be used to set the C<Content-Type> reported for
|
---|
1475 | the file.
|
---|
1476 |
|
---|
1477 | =cut
|
---|
1478 |
|
---|
1479 | sub headers {
|
---|
1480 | my $self = shift;
|
---|
1481 | my $old = $self->{headers} || [];
|
---|
1482 | $self->{headers} = [@_] if @_;
|
---|
1483 | @$old;
|
---|
1484 | }
|
---|
1485 |
|
---|
1486 | sub form_name_value {
|
---|
1487 | my($self, $form) = @_;
|
---|
1488 | return $self->SUPER::form_name_value($form)
|
---|
1489 | if $form->method ne "POST" ||
|
---|
1490 | $form->enctype ne "multipart/form-data";
|
---|
1491 |
|
---|
1492 | my $name = $self->name;
|
---|
1493 | return unless defined $name;
|
---|
1494 | return if $self->{disabled};
|
---|
1495 |
|
---|
1496 | my $file = $self->file;
|
---|
1497 | my $filename = $self->filename;
|
---|
1498 | my @headers = $self->headers;
|
---|
1499 | my $content = $self->content;
|
---|
1500 | if (defined $content) {
|
---|
1501 | $filename = $file unless defined $filename;
|
---|
1502 | $file = undef;
|
---|
1503 | unshift(@headers, "Content" => $content);
|
---|
1504 | }
|
---|
1505 | elsif (!defined($file) || length($file) == 0) {
|
---|
1506 | return;
|
---|
1507 | }
|
---|
1508 |
|
---|
1509 | # legacy (this used to be the way to do it)
|
---|
1510 | if (ref($file) eq "ARRAY") {
|
---|
1511 | my $f = shift @$file;
|
---|
1512 | my $fn = shift @$file;
|
---|
1513 | push(@headers, @$file);
|
---|
1514 | $file = $f;
|
---|
1515 | $filename = $fn unless defined $filename;
|
---|
1516 | }
|
---|
1517 |
|
---|
1518 | return ($name => [$file, $filename, @headers]);
|
---|
1519 | }
|
---|
1520 |
|
---|
1521 | package HTML::Form::KeygenInput;
|
---|
1522 | @HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
|
---|
1523 |
|
---|
1524 | sub challenge {
|
---|
1525 | my $self = shift;
|
---|
1526 | return $self->{challenge};
|
---|
1527 | }
|
---|
1528 |
|
---|
1529 | sub keytype {
|
---|
1530 | my $self = shift;
|
---|
1531 | return lc($self->{keytype} || 'rsa');
|
---|
1532 | }
|
---|
1533 |
|
---|
1534 | 1;
|
---|
1535 |
|
---|
1536 | __END__
|
---|
1537 |
|
---|
1538 | =back
|
---|
1539 |
|
---|
1540 | =head1 SEE ALSO
|
---|
1541 |
|
---|
1542 | L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
|
---|
1543 |
|
---|
1544 | =head1 COPYRIGHT
|
---|
1545 |
|
---|
1546 | Copyright 1998-2008 Gisle Aas.
|
---|
1547 |
|
---|
1548 | This library is free software; you can redistribute it and/or
|
---|
1549 | modify it under the same terms as Perl itself.
|
---|
1550 |
|
---|
1551 | =cut
|
---|