]>
jfr.im git - irc/SurrealServices/srsv.git/blob - tags/0.4.3.1-pre2/CPAN/HTML/Form.pm
11 my %form_tags = map {$_ => 1} qw(input textarea button select option);
15 password
=> "TextInput",
16 hidden
=> "TextInput",
17 textarea
=> "TextInput",
19 "reset" => "IgnoreInput",
22 checkbox
=> "ListInput",
23 option
=> "ListInput",
25 button
=> "SubmitInput",
26 submit
=> "SubmitInput",
27 image
=> "ImageInput",
30 keygen
=> "KeygenInput",
33 # The new HTML5 input types
34 %type2class = (%type2class, map { $_ => 'TextInput' } qw(
36 datetime date month week time datetime-local
42 HTML::Form - Class that represents an HTML form element
47 $form = HTML::Form->parse($html, $base_uri);
48 $form->value(query => "Perl");
51 $ua = LWP::UserAgent->new;
52 $response = $ua->request($form->click);
56 Objects of the C<HTML::Form> class represents a single HTML
57 C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
58 sequence of inputs that usually have names, and which can take on
59 various values. The state of a form can be tweaked and it can then be
60 asked to provide C<HTTP::Request> objects that can be passed to the
61 request() method of C<LWP::UserAgent>.
63 The following methods are available:
67 =item @forms = HTML::Form->parse( $html_document, $base_uri )
69 =item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
71 =item @forms = HTML::Form->parse( $response, %opt )
73 The parse() class method will parse an HTML document and build up
74 C<HTML::Form> objects for each <form> element found. If called in scalar
75 context only returns the first <form>. Returns an empty list if there
76 are no forms to be found.
78 The required arguments is the HTML document to parse ($html_document) and the
79 URI used to retrieve the document ($base_uri). The base URI is needed to resolve
80 relative action URIs. The provided HTML document should be a Unicode string
83 By default HTML::Form assumes that the original document was UTF-8 encoded and
84 thus encode forms that don't specify an explicit I<accept-charset> as UTF-8.
85 The charset assumed can be overridden by providing the C<charset> option to
86 parse(). It's a good idea to be explicit about this parameter as well, thus
87 the recommended simplest invocation becomes:
89 my @forms = HTML::Form->parse(
90 Encode::decode($encoding, $html_document_bytes),
95 If the document was retrieved with LWP then the response object provide methods
96 to obtain a proper value for C<base> and C<charset>:
98 my $ua = LWP::UserAgent->new;
99 my $response = $ua->get("http://www.example.com/form.html");
100 my @forms = HTML::Form->parse($response->decoded_content,
101 base => $response->base,
102 charset => $response->content_charset,
105 In fact, the parse() method can parse from an C<HTTP::Response> object
106 directly, so the example above can be more conveniently written as:
108 my $ua = LWP::UserAgent->new;
109 my $response = $ua->get("http://www.example.com/form.html");
110 my @forms = HTML::Form->parse($response);
112 Note that any object that implements a decoded_content(), base() and
113 content_charset() method with similar behaviour as C<HTTP::Response> will do.
115 Additional options might be passed in to control how the parse method
116 behaves. The following are all the options currently recognized:
120 =item C<< base => $uri >>
122 This is the URI used to retrive the original document. This option is not optional ;-)
124 =item C<< charset => $str >>
126 Specify what charset the original document was encoded in. This is used as
127 the default for accept_charset. If not provided this defaults to "UTF-8".
129 =item C<< verbose => $bool >>
131 Warn (print messages to STDERR) about any bad HTML form constructs found.
132 You can trap these with $SIG{__WARN__}. The default is not to issue warnings.
134 =item C<< strict => $bool >>
136 Initialize any form objects with the given strict attribute.
137 If the strict is turned on the methods that change values of the form will croak if you try
138 to set illegal values or modify readonly fields.
139 The default is not to be strict.
149 unshift(@_, "base") if @_ == 1;
152 require HTML
::TokeParser
;
153 my $p = HTML
::TokeParser-
>new(ref($html) ? $html->decoded_content(ref => 1) : \
$html);
154 die "Failed to create HTML::TokeParser object" unless $p;
156 my $base_uri = delete $opt{base
};
157 my $charset = delete $opt{charset
};
158 my $strict = delete $opt{strict
};
159 my $verbose = delete $opt{verbose
};
162 Carp
::carp
("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
165 unless (defined $base_uri) {
167 $base_uri = $html->base;
170 Carp
::croak
("HTML::Form::parse: No \$base_uri provided");
173 unless (defined $charset) {
174 if (ref($html) and $html->can("content_charset")) {
175 $charset = $html->content_charset;
183 my $f; # current form
185 my %openselect; # index to the open instance of a select
187 while (my $t = $p->get_tag) {
188 my($tag,$attr) = @$t;
189 if ($tag eq "form") {
190 my $action = delete $attr->{'action'};
191 $action = "" unless defined $action;
192 $action = URI-
>new_abs($action, $base_uri);
193 $f = $class->new($attr->{'method'},
196 $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
197 $f->{default_charset
} = $charset;
199 $f->strict(1) if $strict;
202 my(%labels, $current_label);
203 while (my $t = $p->get_tag) {
204 my($tag, $attr) = @$t;
205 last if $tag eq "/form";
207 if ($tag ne 'textarea') {
208 # if we are inside a label tag, then keep
209 # appending any text to the current label
210 if(defined $current_label) {
211 $current_label = join " ",
212 grep { defined and length }
218 if ($tag eq "input") {
219 $attr->{value_name
} =
220 exists $attr->{id
} && exists $labels{$attr->{id
}} ? $labels{$attr->{id
}} :
221 defined $current_label ? $current_label :
225 if ($tag eq "label") {
226 $current_label = $p->get_phrase;
227 $labels{ $attr->{for} } = $current_label
228 if exists $attr->{for};
230 elsif ($tag eq "/label") {
231 $current_label = undef;
233 elsif ($tag eq "input") {
234 my $type = delete $attr->{type
} || "text";
235 $f->push_input($type, $attr, $verbose);
237 elsif ($tag eq "button") {
238 my $type = delete $attr->{type
} || "submit";
239 $f->push_input($type, $attr, $verbose);
241 elsif ($tag eq "textarea") {
242 $attr->{textarea_value
} = $attr->{value
}
243 if exists $attr->{value
};
244 my $text = $p->get_text("/textarea");
245 $attr->{value
} = $text;
246 $f->push_input("textarea", $attr, $verbose);
248 elsif ($tag eq "select") {
249 # rename attributes reserved to come for the option tag
250 for ("value", "value_name") {
251 $attr->{"select_$_"} = delete $attr->{$_}
252 if exists $attr->{$_};
254 # count this new select option separately
255 my $name = $attr->{name
};
256 $name = "" unless defined $name;
257 $openselect{$name}++;
259 while ($t = $p->get_tag) {
261 last if $tag eq "/select";
262 next if $tag =~ m
,/?optgroup
,;
263 next if $tag eq "/option";
264 if ($tag eq "option") {
266 # rename keys so they don't clash with %attr
268 next if $_ eq "value";
269 $a{"option_$_"} = delete $a{$_};
271 while (my($k,$v) = each %$attr) {
274 $a{value_name
} = $p->get_trimmed_text;
275 $a{value
} = delete $a{value_name
}
276 unless defined $a{value
};
277 $a{idx
} = $openselect{$name};
278 $f->push_input("option", \
%a, $verbose);
281 warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
282 if ($tag eq "/form" ||
284 $tag eq "textarea" ||
288 # MSIE implictly terminate the <select> here, so we
289 # try to do the same. Actually the MSIE behaviour
290 # appears really strange: <input> and <textarea>
291 # do implictly close, but not <select>, <keygen> or
293 my $type = ($tag =~ s
,^/,,) ? "E" : "S";
294 $p->unget_token([$type, $tag, @$t]);
300 elsif ($tag eq "keygen") {
301 $f->push_input("keygen", $attr, $verbose);
305 elsif ($form_tags{$tag}) {
306 warn("<$tag> outside <form> in $base_uri\n") if $verbose;
313 wantarray ? @forms : $forms[0];
318 my $self = bless {}, $class;
319 $self->{method} = uc(shift || "GET");
320 $self->{action
} = shift || Carp
::croak
("No action defined");
321 $self->{enctype
} = lc(shift || "application/x-www-form-urlencoded");
322 $self->{accept_charset
} = "UNKNOWN";
323 $self->{default_charset
} = "UTF-8";
324 $self->{inputs
} = [@_];
331 my($self, $type, $attr, $verbose) = @_;
333 my $class = $type2class{$type};
335 Carp
::carp
("Unknown input type '$type'") if $verbose;
336 $class = "TextInput";
338 $class = "HTML::Form::$class";
340 push(@extra, readonly
=> 1) if $type eq "hidden";
341 push(@extra, strict
=> 1) if $self->{strict
};
342 if ($type eq "file" && exists $attr->{value
}) {
343 # it's not safe to trust the value set by the server
344 # the user always need to explictly set the names of files to upload
345 $attr->{orig_value
} = delete $attr->{value
};
347 delete $attr->{type
}; # don't confuse the type argument
348 my $input = $class->new(type
=> $type, %$attr, @extra);
349 $input->add_to_form($self);
353 =item $method = $form->method
355 =item $form->method( $new_method )
357 This method is gets/sets the I<method> name used for the
358 C<HTTP::Request> generated. It is a string like "GET" or "POST".
360 =item $action = $form->action
362 =item $form->action( $new_action )
364 This method gets/sets the URI which we want to apply the request
367 =item $enctype = $form->enctype
369 =item $form->enctype( $new_enctype )
371 This method gets/sets the encoding type for the form data. It is a
372 string like "application/x-www-form-urlencoded" or "multipart/form-data".
374 =item $accept = $form->accept_charset
376 =item $form->accept_charset( $new_accept )
378 This method gets/sets the list of charset encodings that the server processing
379 the form accepts. Current implementation supports only one-element lists.
380 Default value is "UNKNOWN" which we interpret as a request to use document
381 charset as specified by the 'charset' parameter of the parse() method.
386 # Set up some accesor
387 for (qw(method action enctype accept_charset)) {
392 my $old = $self->{$m};
393 $self->{$m} = shift if @_;
397 *uri
= \
&action
; # alias
400 =item $value = $form->attr( $name )
402 =item $form->attr( $name, $new_value )
404 This method give access to the original HTML attributes of the <form> tag.
405 The $name should always be passed in lower case.
409 @f = HTML::Form->parse( $html, $foo );
410 @f = grep $_->attr("id") eq "foo", @f;
411 die "No form named 'foo' found" unless @f;
419 return undef unless defined $name;
421 my $old = $self->{attr
}{$name};
422 $self->{attr
}{$name} = shift if @_;
426 =item $bool = $form->strict
428 =item $form->strict( $bool )
430 Gets/sets the strict attribute of a form. If the strict is turned on
431 the methods that change values of the form will croak if you try to
432 set illegal values or modify readonly fields. The default is not to be strict.
438 my $old = $self->{strict
};
440 $self->{strict
} = shift;
441 for my $input (@{$self->{inputs
}}) {
442 $input->strict($self->{strict
});
449 =item @inputs = $form->inputs
451 This method returns the list of inputs in the form. If called in
452 scalar context it returns the number of inputs contained in the form.
453 See L</INPUTS> for what methods are available for the input objects
461 @{$self->{'inputs'}};
465 =item $input = $form->find_input( $selector )
467 =item $input = $form->find_input( $selector, $type )
469 =item $input = $form->find_input( $selector, $type, $index )
471 This method is used to locate specific inputs within the form. All
472 inputs that match the arguments given are returned. In scalar context
473 only the first is returned, or C<undef> if none match.
475 If $selector is specified, then the input's name, id, class attribute must
476 match. A selector prefixed with '#' must match the id attribute of the input.
477 A selector prefixed with '.' matches the class attribute. A selector prefixed
478 with '^' or with no prefix matches the name attribute.
480 If $type is specified, then the input must have the specified type.
481 The following type names are used: "text", "password", "hidden",
482 "textarea", "file", "image", "submit", "radio", "checkbox" and "option".
484 The $index is the sequence number of the input matched where 1 is the
485 first. If combined with $name and/or $type then it select the I<n>th
486 input with the given name and/or type.
492 my($self, $name, $type, $no) = @_;
496 for (@{$self->{'inputs'}}) {
497 next if defined($name) && !$_->selected($name);
498 next if $type && $type ne $_->{type
};
500 next if $no && $no != $c;
508 for (@{$self->{'inputs'}}) {
509 next if defined($name) && !$_->selected($name);
510 next if $type && $type ne $_->{type
};
521 for (@{$self->{'inputs'}}) {
527 =item $value = $form->value( $selector )
529 =item $form->value( $selector, $new_value )
531 The value() method can be used to get/set the value of some input. If
532 strict is enabled and no input has the indicated name, then this method will croak.
534 If multiple inputs have the same name, only the first one will be
541 is basically a short-hand for:
543 $form->find_input('foo')->value;
551 my $input = $self->find_input($key);
553 Carp
::croak
("No such field '$key'") if $self->{strict
};
554 return undef unless @_;
555 $input = $self->push_input("text", { name
=> $key, value
=> "" });
557 local $Carp::CarpLevel
= 1;
561 =item @names = $form->param
563 =item @values = $form->param( $name )
565 =item $form->param( $name, $value, ... )
567 =item $form->param( $name, \@values )
569 Alternative interface to examining and setting the values of the form.
571 If called without arguments then it returns the names of all the
572 inputs in the form. The names will not repeat even if multiple inputs
573 have the same name. In scalar context the number of different names
576 If called with a single argument then it returns the value or values
577 of inputs with the given name. If called in scalar context only the
578 first value is returned. If no input exists with the given name, then
579 C<undef> is returned.
581 If called with 2 or more arguments then it will set values of the
582 named inputs. This form will croak if no inputs have the given name
583 or if any of the values provided does not fit. Values can also be
584 provided as a reference to an array. This form will allow unsetting
585 all values with the given name as well.
587 This interface resembles that of the param() function of the CGI
597 for ($self->inputs) {
599 next if !defined($n) || $n ne $name;
605 die "No '$name' parameter exists" unless @inputs;
607 @v = @{$v[0]} if @v == 1 && ref($v[0]);
611 for my $i (0 .. @inputs-1) {
613 $inputs[$i]->value($v);
617 splice(@inputs, $i, 1);
625 # the rest of the input should be cleared
634 if (defined(my $v = $_->value)) {
638 return wantarray ? @v : $v[0];
642 # list parameter names
645 for ($self->inputs) {
647 next if !defined($n) || $seen{$n}++;
655 =item $form->try_others( \&callback )
657 This method will iterate over all permutations of unvisited enumerated
658 values (<select>, <radio>, <checkbox>) and invoke the callback for
659 each. The callback is passed the $form as argument. The return value
660 from the callback is ignored and the try_others() method itself does
669 for (@{$self->{'inputs'}}) {
670 my @not_tried_yet = $_->other_possible_values;
671 next unless @not_tried_yet;
672 push(@try, [\
@not_tried_yet, $_]);
675 $self->_try($cb, \
@try, 0);
680 my($self, $cb, $try, $i) = @_;
681 for (@{$try->[$i][0]}) {
682 $try->[$i][1]->value($_);
684 $self->_try($cb, $try, $i+1) if $i+1 < @$try;
689 =item $request = $form->make_request
691 Will return an C<HTTP::Request> object that reflects the current setting
692 of the form. You might want to use the click() method instead.
699 my $method = uc $self->{'method'};
700 my $uri = $self->{'action'};
701 my $enctype = $self->{'enctype'};
702 my @form = $self->form;
704 my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset
} : $self->accept_charset;
705 foreach my $fi (@form) {
706 $fi = Encode
::encode
($charset, $fi) unless ref($fi);
709 if ($method eq "GET") {
710 require HTTP
::Request
;
711 $uri = URI-
>new($uri, "http");
712 $uri->query_form(@form);
713 return HTTP
::Request-
>new(GET
=> $uri);
715 elsif ($method eq "POST") {
716 require HTTP
::Request
::Common
;
717 return HTTP
::Request
::Common
::POST
($uri, \
@form,
718 Content_Type
=> $enctype);
721 Carp
::croak
("Unknown method '$method'");
726 =item $request = $form->click
728 =item $request = $form->click( $selector )
730 =item $request = $form->click( $x, $y )
732 =item $request = $form->click( $selector, $x, $y )
734 Will "click" on the first clickable input (which will be of type
735 C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
736 object that can then be passed to C<LWP::UserAgent> if you want to
737 obtain the server response.
739 If a $selector is specified, we will click on the first clickable input
740 matching the selector, and the method will croak if no matching clickable
741 input is found. If $selector is I<not> specified, then it
742 is ok if the form contains no clickable inputs. In this case the
743 click() method returns the same request as the make_request() method
744 would do. See description of the find_input() method above for how
745 the $selector is specified.
747 If there are multiple clickable inputs with the same name, then there
748 is no way to get the click() method of the C<HTML::Form> to click on
749 any but the first. If you need this you would have to locate the
750 input with find_input() and invoke the click() method on the given
753 A click coordinate pair can also be provided, but this only makes a
754 difference if you clicked on an image. The default coordinate is
755 (1,1). The upper-left corner of the image is (0,0), but some badly
756 coded CGI scripts are known to not recognize this. Therefore (1,1) was
757 selected as a safer default.
765 $name = shift if (@_ % 2) == 1; # odd number of arguments
767 # try to find first submit button to activate
768 for (@{$self->{'inputs'}}) {
769 next unless $_->can("click");
770 next if $name && !$_->selected($name);
771 next if $_->disabled;
772 return $_->click($self, @_);
774 Carp
::croak
("No clickable input with name $name") if $name;
779 =item @kw = $form->form
781 Returns the current setting as a sequence of key/value pairs. Note
782 that keys might be repeated, which means that some values might be
783 lost if the return values are assigned to a hash.
785 In scalar context this method returns the number of key/value pairs
793 map { $_->form_name_value($self) } @{$self->{'inputs'}};
799 Returns a textual representation of current state of the form. Mainly
800 useful for debugging. If called in void context, then the dump is
808 my $method = $self->{'method'};
809 my $uri = $self->{'action'};
810 my $enctype = $self->{'enctype'};
811 my $dump = "$method $uri";
812 $dump .= " ($enctype)"
813 if $enctype ne "application/x-www-form-urlencoded";
814 $dump .= " [$self->{attr}{name}]"
815 if exists $self->{attr
}{name
};
817 for ($self->inputs) {
818 $dump .= " " . $_->dump . "\n";
820 print STDERR
$dump unless defined wantarray;
825 #---------------------------------------------------
826 package HTML
::Form
::Input
;
832 An C<HTML::Form> objects contains a sequence of I<inputs>. References to
833 the inputs can be obtained with the $form->inputs or $form->find_input
836 Note that there is I<not> a one-to-one correspondence between input
837 I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
838 input object basically represents a name/value pair, so when multiple
839 HTML elements contribute to the same name/value pair in the submitted
840 form they are combined.
842 The input elements that are mapped one-to-one are "text", "textarea",
843 "password", "hidden", "file", "image", "submit" and "checkbox". For
844 the "radio" and "option" inputs the story is not as simple: All
845 E<lt>input type="radio"E<gt> elements with the same name will
846 contribute to the same input radio object. The number of radio input
847 objects will be the same as the number of distinct names used for the
848 E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
849 without the C<multiple> attribute there will be one input object of
850 type of "option". For a E<lt>select multipleE<gt> element there will
851 be one input object for each contained E<lt>optionE<gt> element. Each
852 one of these option objects will have the same name.
854 The following methods are available for the I<input> objects:
863 my $self = bless {@_}, $class;
869 my($self, $form) = @_;
870 push(@{$form->{'inputs'}}, $self);
876 my $old = $self->{strict
};
878 $self->{strict
} = shift;
888 Returns the type of this input. The type is one of the following
889 strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
890 "radio", "checkbox" or "option".
899 =item $name = $input->name
901 =item $input->name( $new_name )
903 This method can be used to get/set the current name of the input.
909 These methods can be used to get/set the current id or class attribute for the input.
911 =item $input->selected( $selector )
913 Returns TRUE if the given selector matched the input. See the description of
914 the find_input() method above for a description of the selector syntax.
916 =item $value = $input->value
918 =item $input->value( $new_value )
920 This method can be used to get/set the current value of an
923 If strict is enabled and the input only can take an enumerated list of values,
924 then it is an error to try to set it to something else and the method will
927 You will also be able to set the value of read-only inputs, but a
928 warning will be generated if running under C<perl -w>.
935 my $old = $self->{name
};
936 $self->{name
} = shift if @_;
943 my $old = $self->{id
};
944 $self->{id
} = shift if @_;
951 my $old = $self->{class};
952 $self->{class} = shift if @_;
957 my($self, $sel) = @_;
958 return undef unless defined $sel;
960 $sel =~ s/^\^// ? "name" :
961 $sel =~ s/^#// ? "id" :
962 $sel =~ s/^\.// ? "class" :
964 return 0 unless defined $self->{$attr};
965 return $self->{$attr} eq $sel;
971 my $old = $self->{value
};
972 $self->{value
} = shift if @_;
976 =item $input->possible_values
978 Returns a list of all values that an input can take. For inputs that
979 do not have discrete values, this returns an empty list.
988 =item $input->other_possible_values
990 Returns a list of all values not tried yet.
994 sub other_possible_values
999 =item $input->value_names
1001 For some inputs the values can have names that are different from the
1002 values themselves. The number of names returned by this method will
1003 match the number of values reported by $input->possible_values.
1005 When setting values using the value() method it is also possible to
1006 use the value names in place of the value itself.
1014 =item $bool = $input->readonly
1016 =item $input->readonly( $bool )
1018 This method is used to get/set the value of the readonly attribute.
1019 You are allowed to modify the value of readonly inputs, but setting
1020 the value will generate some noise when warnings are enabled. Hidden
1021 fields always start out readonly.
1027 my $old = $self->{readonly
};
1028 $self->{readonly
} = shift if @_;
1032 =item $bool = $input->disabled
1034 =item $input->disabled( $bool )
1036 This method is used to get/set the value of the disabled attribute.
1037 Disabled inputs do not contribute any key/value pairs for the form
1044 my $old = $self->{disabled
};
1045 $self->{disabled
} = shift if @_;
1049 =item $input->form_name_value
1051 Returns a (possible empty) list of key/value pairs that should be
1052 incorporated in the form value from this input.
1059 my $name = $self->{'name'};
1060 return unless defined $name;
1061 return if $self->disabled;
1062 my $value = $self->value;
1063 return unless defined $value;
1064 return ($name => $value);
1070 my $name = $self->name;
1071 $name = "<NONAME>" unless defined $name;
1072 my $value = $self->value;
1073 $value = "<UNDEF>" unless defined $value;
1074 my $dump = "$name=$value";
1076 my $type = $self->type;
1078 $type .= " disabled" if $self->disabled;
1079 $type .= " readonly" if $self->readonly;
1080 return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu
};
1084 for (@{$self->{menu
}}) {
1085 my $opt = $_->{value
};
1086 $opt = "<UNDEF>" unless defined $opt;
1087 $opt .= "/$_->{name}"
1088 if defined $_->{name
} && length $_->{name
} && $_->{name
} ne $opt;
1089 substr($opt,0,0) = "-" if $_->{disabled
};
1090 if (exists $self->{current
} && $self->{current
} == $i) {
1091 substr($opt,0,0) = "!" unless $_->{seen
};
1092 substr($opt,0,0) = "*";
1095 substr($opt,0,0) = ":" if $_->{seen
};
1101 return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
1105 #---------------------------------------------------
1106 package HTML
::Form
::TextInput
;
1107 @HTML::Form
::TextInput
::ISA
=qw(HTML::Form::Input);
1117 my $old = $self->{value
};
1118 $old = "" unless defined $old;
1120 Carp
::croak
("Input '$self->{name}' is readonly")
1121 if $self->{strict
} && $self->{readonly
};
1123 my $n = exists $self->{maxlength
} ? $self->{maxlength
} : undef;
1124 Carp
::croak
("Input '$self->{name}' has maxlength '$n'")
1125 if $self->{strict
} && defined($n) && defined($new) && length($new) > $n;
1126 $self->{value
} = $new;
1131 #---------------------------------------------------
1132 package HTML
::Form
::IgnoreInput
;
1133 @HTML::Form
::IgnoreInput
::ISA
=qw(HTML::Form::Input);
1138 sub value
{ return }
1141 #---------------------------------------------------
1142 package HTML
::Form
::ListInput
;
1143 @HTML::Form
::ListInput
::ISA
=qw(HTML::Form::Input);
1145 #select/option (val1, val2, ....)
1146 #input/radio (undef, val1, val2,...)
1147 #input/checkbox (undef, value)
1148 #select-multiple/option (undef, value)
1153 my $self = $class->SUPER::new
(@_);
1155 my $value = delete $self->{value
};
1156 my $value_name = delete $self->{value_name
};
1157 my $type = $self->{type
};
1159 if ($type eq "checkbox") {
1160 $value = "on" unless defined $value;
1162 { value
=> undef, name
=> "off", },
1163 { value
=> $value, name
=> $value_name, },
1165 $self->{current
} = (delete $self->{checked
}) ? 1 : 0;
1169 $self->{option_disabled
}++
1170 if $type eq "radio" && delete $self->{disabled
};
1172 {value
=> $value, name
=> $value_name},
1174 my $checked = $self->{checked
} || $self->{option_selected
};
1175 delete $self->{checked
};
1176 delete $self->{option_selected
};
1177 if (exists $self->{multiple
}) {
1178 unshift(@{$self->{menu
}}, { value
=> undef, name
=> "off"});
1179 $self->{current
} = $checked ? 1 : 0;
1182 $self->{current
} = 0 if $checked;
1190 my($self, $form) = @_;
1191 my $type = $self->type;
1193 return $self->SUPER::add_to_form
($form)
1194 if $type eq "checkbox";
1196 if ($type eq "option" && exists $self->{multiple
}) {
1197 $self->{disabled
} ||= delete $self->{option_disabled
};
1198 return $self->SUPER::add_to_form
($form);
1201 die "Assert" if @{$self->{menu
}} != 1;
1202 my $m = $self->{menu
}[0];
1203 $m->{disabled
}++ if delete $self->{option_disabled
};
1205 my $prev = $form->find_input($self->{name
}, $self->{type
}, $self->{idx
});
1206 return $self->SUPER::add_to_form
($form) unless $prev;
1209 $prev->{current
} = @{$prev->{menu
}} if exists $self->{current
};
1210 push(@{$prev->{menu
}}, $m);
1216 if ($self->{type
} eq "option" && !(exists $self->{current
})) {
1217 $self->{current
} = 0;
1219 $self->{menu
}[$self->{current
}]{seen
}++ if exists $self->{current
};
1225 my $type = $self->type;
1227 my $old = $self->{disabled
} || _menu_all_disabled
(@{$self->{menu
}});
1230 $self->{disabled
} = $v;
1231 for (@{$self->{menu
}}) {
1232 $_->{disabled
} = $v;
1238 sub _menu_all_disabled
{
1240 return 0 unless $_->{disabled
};
1249 $old = $self->{menu
}[$self->{current
}]{value
} if exists $self->{current
};
1250 $old = $self->{value
} if exists $self->{value
};
1256 for (@{$self->{menu
}}) {
1257 if ((defined($val) && defined($_->{value
}) && $val eq $_->{value
}) ||
1258 (!defined($val) && !defined($_->{value
}))
1262 $disabled = $_->{disabled
};
1263 last unless $disabled;
1267 if (!(defined $cur) || $disabled) {
1269 # try to search among the alternative names as well
1272 my $lc_val = lc($val);
1273 for (@{$self->{menu
}}) {
1274 if (defined $_->{name
}) {
1275 if ($val eq $_->{name
}) {
1276 $disabled = $_->{disabled
};
1278 last unless $disabled;
1280 if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name
})) {
1281 $cur_ignorecase = $i;
1286 unless (defined $cur) {
1287 $cur = $cur_ignorecase;
1289 $disabled = $self->{menu
}[$cur]{disabled
};
1291 elsif ($self->{strict
}) {
1292 my $n = $self->name;
1293 Carp
::croak
("Illegal value '$val' for field '$n'");
1297 elsif ($self->{strict
}) {
1298 my $n = $self->name;
1299 Carp
::croak
("The '$n' field can't be unchecked");
1302 if ($self->{strict
} && $disabled) {
1303 my $n = $self->name;
1304 Carp
::croak
("The value '$val' has been disabled for field '$n'");
1307 $self->{current
} = $cur;
1308 $self->{menu
}[$cur]{seen
}++;
1309 delete $self->{value
};
1312 $self->{value
} = $val;
1313 delete $self->{current
};
1321 Some input types represent toggles that can be turned on/off. This
1322 includes "checkbox" and "option" inputs. Calling this method turns
1323 this input on without having to know the value name. If the input is
1324 already on, then nothing happens.
1326 This has the same effect as:
1328 $input->value($input->possible_values[1]);
1330 The input can be turned off with:
1332 $input->value(undef);
1339 $self->{current
} = 1;
1340 $self->{menu
}[1]{seen
}++;
1346 map $_->{value
}, grep !$_->{disabled
}, @{$self->{menu
}};
1349 sub other_possible_values
1352 map $_->{value
}, grep !$_->{seen
} && !$_->{disabled
}, @{$self->{menu
}};
1358 for (@{$self->{menu
}}) {
1360 $n = $_->{value
} unless defined $n;
1367 #---------------------------------------------------
1368 package HTML
::Form
::SubmitInput
;
1369 @HTML::Form
::SubmitInput
::ISA
=qw(HTML::Form::Input);
1374 =item $input->click($form, $x, $y)
1376 Some input types (currently "submit" buttons and "images") can be
1377 clicked to submit the form. The click() method returns the
1378 corresponding C<HTTP::Request> object.
1384 my($self,$form,$x,$y) = @_;
1385 for ($x, $y) { $_ = 1 unless defined; }
1386 local($self->{clicked
}) = [$x,$y];
1387 return $form->make_request;
1393 return unless $self->{clicked
};
1394 return $self->SUPER::form_name_value
(@_);
1398 #---------------------------------------------------
1399 package HTML
::Form
::ImageInput
;
1400 @HTML::Form
::ImageInput
::ISA
=qw(HTML::Form::SubmitInput);
1405 my $clicked = $self->{clicked
};
1406 return unless $clicked;
1407 return if $self->{disabled
};
1408 my $name = $self->{name
};
1409 $name = (defined($name) && length($name)) ? "$name." : "";
1410 return ("${name}x" => $clicked->[0],
1411 "${name}y" => $clicked->[1]
1415 #---------------------------------------------------
1416 package HTML
::Form
::FileInput
;
1417 @HTML::Form
::FileInput
::ISA
=qw(HTML::Form::TextInput);
1421 If the input is of type C<file>, then it has these additional methods:
1427 This is just an alias for the value() method. It sets the filename to
1430 For security reasons this field will never be initialized from the parsing
1431 of a form. This prevents the server from triggering stealth uploads of
1432 arbitrary files from the client machine.
1441 =item $filename = $input->filename
1443 =item $input->filename( $new_filename )
1445 This get/sets the filename reported to the server during file upload.
1446 This attribute defaults to the value reported by the file() method.
1452 my $old = $self->{filename
};
1453 $self->{filename
} = shift if @_;
1454 $old = $self->file unless defined $old;
1458 =item $content = $input->content
1460 =item $input->content( $new_content )
1462 This get/sets the file content provided to the server during file
1463 upload. This method can be used if you do not want the content to be
1464 read from an actual file.
1470 my $old = $self->{content
};
1471 $self->{content
} = shift if @_;
1475 =item @headers = $input->headers
1477 =item input->headers($key => $value, .... )
1479 This get/set additional header fields describing the file uploaded.
1480 This can for instance be used to set the C<Content-Type> reported for
1487 my $old = $self->{headers
} || [];
1488 $self->{headers
} = [@_] if @_;
1492 sub form_name_value
{
1493 my($self, $form) = @_;
1494 return $self->SUPER::form_name_value
($form)
1495 if $form->method ne "POST" ||
1496 $form->enctype ne "multipart/form-data";
1498 my $name = $self->name;
1499 return unless defined $name;
1500 return if $self->{disabled
};
1502 my $file = $self->file;
1503 my $filename = $self->filename;
1504 my @headers = $self->headers;
1505 my $content = $self->content;
1506 if (defined $content) {
1507 $filename = $file unless defined $filename;
1509 unshift(@headers, "Content" => $content);
1511 elsif (!defined($file) || length($file) == 0) {
1515 # legacy (this used to be the way to do it)
1516 if (ref($file) eq "ARRAY") {
1517 my $f = shift @$file;
1518 my $fn = shift @$file;
1519 push(@headers, @$file);
1521 $filename = $fn unless defined $filename;
1524 return ($name => [$file, $filename, @headers]);
1527 package HTML
::Form
::KeygenInput
;
1528 @HTML::Form
::KeygenInput
::ISA
=qw(HTML::Form::Input);
1532 return $self->{challenge
};
1537 return lc($self->{keytype
} || 'rsa');
1548 L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
1552 Copyright 1998-2008 Gisle Aas.
1554 This library is free software; you can redistribute it and/or
1555 modify it under the same terms as Perl itself.