summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/HTML/Form.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/HTML/Form.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/HTML/Form.pm1551
1 files changed, 0 insertions, 1551 deletions
diff --git a/Master/tlpkg/tlperl/lib/HTML/Form.pm b/Master/tlpkg/tlperl/lib/HTML/Form.pm
deleted file mode 100644
index bbbd7771716..00000000000
--- a/Master/tlpkg/tlperl/lib/HTML/Form.pm
+++ /dev/null
@@ -1,1551 +0,0 @@
-package HTML::Form;
-
-use strict;
-use URI;
-use Carp ();
-
-use vars qw($VERSION $Encode_available);
-$VERSION = "5.829";
-
-eval { require Encode };
-$Encode_available = !$@;
-
-my %form_tags = map {$_ => 1} qw(input textarea button select option);
-
-my %type2class = (
- text => "TextInput",
- password => "TextInput",
- hidden => "TextInput",
- textarea => "TextInput",
-
- "reset" => "IgnoreInput",
-
- radio => "ListInput",
- checkbox => "ListInput",
- option => "ListInput",
-
- button => "SubmitInput",
- submit => "SubmitInput",
- image => "ImageInput",
- file => "FileInput",
-
- keygen => "KeygenInput",
-);
-
-=head1 NAME
-
-HTML::Form - Class that represents an HTML form element
-
-=head1 SYNOPSIS
-
- use HTML::Form;
- $form = HTML::Form->parse($html, $base_uri);
- $form->value(query => "Perl");
-
- use LWP::UserAgent;
- $ua = LWP::UserAgent->new;
- $response = $ua->request($form->click);
-
-=head1 DESCRIPTION
-
-Objects of the C<HTML::Form> class represents a single HTML
-C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
-sequence of inputs that usually have names, and which can take on
-various values. The state of a form can be tweaked and it can then be
-asked to provide C<HTTP::Request> objects that can be passed to the
-request() method of C<LWP::UserAgent>.
-
-The following methods are available:
-
-=over 4
-
-=item @forms = HTML::Form->parse( $html_document, $base_uri )
-
-=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
-
-=item @forms = HTML::Form->parse( $response, %opt )
-
-The parse() class method will parse an HTML document and build up
-C<HTML::Form> objects for each <form> element found. If called in scalar
-context only returns the first <form>. Returns an empty list if there
-are no forms to be found.
-
-The required arguments is the HTML document to parse ($html_document) and the
-URI used to retrieve the document ($base_uri). The base URI is needed to resolve
-relative action URIs. The provided HTML document should be a Unicode string
-(or US-ASCII).
-
-By default HTML::Form assumes that the original document was UTF-8 encoded and
-thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
-The charset assumed can be overridden by providing the C<charset> option to
-parse(). It's a good idea to be explict about this parameter as well, thus
-the recommended simplest invocation becomes:
-
- my @forms = HTML::Form->parse(
- Encode::decode($encoding, $html_document_bytes),
- base => $base_uri,
- charset => $encoding,
- );
-
-If the document was retrieved with LWP then the response object provide methods
-to obtain a proper value for C<base> and C<charset>:
-
- my $ua = LWP::UserAgent->new;
- my $response = $ua->get("http://www.example.com/form.html");
- my @forms = HTML::Form->parse($response->decoded_content,
- base => $response->base,
- charset => $response->content_charset,
- );
-
-In fact, the parse() method can parse from an C<HTTP::Response> object
-directly, so the example above can be more conveniently written as:
-
- my $ua = LWP::UserAgent->new;
- my $response = $ua->get("http://www.example.com/form.html");
- my @forms = HTML::Form->parse($response);
-
-Note that any object that implements a decoded_content(), base() and
-content_charset() method with similar behaviour as C<HTTP::Response> will do.
-
-Additional options might be passed in to control how the parse method
-behaves. The following are all the options currently recognized:
-
-=over
-
-=item C<< base => $uri >>
-
-This is the URI used to retrive the original document. This option is not optional ;-)
-
-=item C<< charset => $str >>
-
-Specify what charset the original document was encoded in. This is used as
-the default for accept_charset. If not provided this defaults to "UTF-8".
-
-=item C<< verbose => $bool >>
-
-Warn (print messages to STDERR) about any bad HTML form constructs found.
-You can trap these with $SIG{__WARN__}.
-
-=item C<< strict => $bool >>
-
-Initialize any form objects with the given strict attribute.
-
-=back
-
-=cut
-
-sub parse
-{
- my $class = shift;
- my $html = shift;
- unshift(@_, "base") if @_ == 1;
- my %opt = @_;
-
- require HTML::TokeParser;
- my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
- die "Failed to create HTML::TokeParser object" unless $p;
-
- my $base_uri = delete $opt{base};
- my $charset = delete $opt{charset};
- my $strict = delete $opt{strict};
- my $verbose = delete $opt{verbose};
-
- if ($^W) {
- Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
- }
-
- unless (defined $base_uri) {
- if (ref($html)) {
- $base_uri = $html->base;
- }
- else {
- Carp::croak("HTML::Form::parse: No \$base_uri provided");
- }
- }
- unless (defined $charset) {
- if (ref($html) and $html->can("content_charset")) {
- $charset = $html->content_charset;
- }
- unless ($charset) {
- $charset = "UTF-8";
- }
- }
-
- my @forms;
- my $f; # current form
-
- my %openselect; # index to the open instance of a select
-
- while (my $t = $p->get_tag) {
- my($tag,$attr) = @$t;
- if ($tag eq "form") {
- my $action = delete $attr->{'action'};
- $action = "" unless defined $action;
- $action = URI->new_abs($action, $base_uri);
- $f = $class->new($attr->{'method'},
- $action,
- $attr->{'enctype'});
- $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
- $f->{default_charset} = $charset;
- $f->{attr} = $attr;
- $f->strict(1) if $strict;
- %openselect = ();
- push(@forms, $f);
- my(%labels, $current_label);
- while (my $t = $p->get_tag) {
- my($tag, $attr) = @$t;
- last if $tag eq "/form";
-
- # if we are inside a label tag, then keep
- # appending any text to the current label
- if(defined $current_label) {
- $current_label = join " ",
- grep { defined and length }
- $current_label,
- $p->get_phrase;
- }
-
- if ($tag eq "input") {
- $attr->{value_name} =
- exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
- defined $current_label ? $current_label :
- $p->get_phrase;
- }
-
- if ($tag eq "label") {
- $current_label = $p->get_phrase;
- $labels{ $attr->{for} } = $current_label
- if exists $attr->{for};
- }
- elsif ($tag eq "/label") {
- $current_label = undef;
- }
- elsif ($tag eq "input") {
- my $type = delete $attr->{type} || "text";
- $f->push_input($type, $attr, $verbose);
- }
- elsif ($tag eq "button") {
- my $type = delete $attr->{type} || "submit";
- $f->push_input($type, $attr, $verbose);
- }
- elsif ($tag eq "textarea") {
- $attr->{textarea_value} = $attr->{value}
- if exists $attr->{value};
- my $text = $p->get_text("/textarea");
- $attr->{value} = $text;
- $f->push_input("textarea", $attr, $verbose);
- }
- elsif ($tag eq "select") {
- # rename attributes reserved to come for the option tag
- for ("value", "value_name") {
- $attr->{"select_$_"} = delete $attr->{$_}
- if exists $attr->{$_};
- }
- # count this new select option separately
- my $name = $attr->{name};
- $name = "" unless defined $name;
- $openselect{$name}++;
-
- while ($t = $p->get_tag) {
- my $tag = shift @$t;
- last if $tag eq "/select";
- next if $tag =~ m,/?optgroup,;
- next if $tag eq "/option";
- if ($tag eq "option") {
- my %a = %{$t->[0]};
- # rename keys so they don't clash with %attr
- for (keys %a) {
- next if $_ eq "value";
- $a{"option_$_"} = delete $a{$_};
- }
- while (my($k,$v) = each %$attr) {
- $a{$k} = $v;
- }
- $a{value_name} = $p->get_trimmed_text;
- $a{value} = delete $a{value_name}
- unless defined $a{value};
- $a{idx} = $openselect{$name};
- $f->push_input("option", \%a, $verbose);
- }
- else {
- warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
- if ($tag eq "/form" ||
- $tag eq "input" ||
- $tag eq "textarea" ||
- $tag eq "select" ||
- $tag eq "keygen")
- {
- # MSIE implictly terminate the <select> here, so we
- # try to do the same. Actually the MSIE behaviour
- # appears really strange: <input> and <textarea>
- # do implictly close, but not <select>, <keygen> or
- # </form>.
- my $type = ($tag =~ s,^/,,) ? "E" : "S";
- $p->unget_token([$type, $tag, @$t]);
- last;
- }
- }
- }
- }
- elsif ($tag eq "keygen") {
- $f->push_input("keygen", $attr, $verbose);
- }
- }
- }
- elsif ($form_tags{$tag}) {
- warn("<$tag> outside <form> in $base_uri\n") if $verbose;
- }
- }
- for (@forms) {
- $_->fixup;
- }
-
- wantarray ? @forms : $forms[0];
-}
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
- $self->{method} = uc(shift || "GET");
- $self->{action} = shift || Carp::croak("No action defined");
- $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
- $self->{accept_charset} = "UNKNOWN";
- $self->{default_charset} = "UTF-8";
- $self->{inputs} = [@_];
- $self;
-}
-
-
-sub push_input
-{
- my($self, $type, $attr, $verbose) = @_;
- $type = lc $type;
- my $class = $type2class{$type};
- unless ($class) {
- Carp::carp("Unknown input type '$type'") if $verbose;
- $class = "TextInput";
- }
- $class = "HTML::Form::$class";
- my @extra;
- push(@extra, readonly => 1) if $type eq "hidden";
- push(@extra, strict => 1) if $self->{strict};
- if ($type eq "file" && exists $attr->{value}) {
- # it's not safe to trust the value set by the server
- # the user always need to explictly set the names of files to upload
- $attr->{orig_value} = delete $attr->{value};
- }
- delete $attr->{type}; # don't confuse the type argument
- my $input = $class->new(type => $type, %$attr, @extra);
- $input->add_to_form($self);
-}
-
-
-=item $method = $form->method
-
-=item $form->method( $new_method )
-
-This method is gets/sets the I<method> name used for the
-C<HTTP::Request> generated. It is a string like "GET" or "POST".
-
-=item $action = $form->action
-
-=item $form->action( $new_action )
-
-This method gets/sets the URI which we want to apply the request
-I<method> to.
-
-=item $enctype = $form->enctype
-
-=item $form->enctype( $new_enctype )
-
-This method gets/sets the encoding type for the form data. It is a
-string like "application/x-www-form-urlencoded" or "multipart/form-data".
-
-=item $accept = $form->accept_charset
-
-=item $form->accept_charset( $new_accept )
-
-This method gets/sets the list of charset encodings that the server processing
-the form accepts. Current implementation supports only one-element lists.
-Default value is "UNKNOWN" which we interpret as a request to use document
-charset as specified by the 'charset' parameter of the parse() method. To
-encode character strings you should have modern perl with Encode module. On
-older perls the setting of this attribute has no effect.
-
-=cut
-
-BEGIN {
- # Set up some accesor
- for (qw(method action enctype accept_charset)) {
- my $m = $_;
- no strict 'refs';
- *{$m} = sub {
- my $self = shift;
- my $old = $self->{$m};
- $self->{$m} = shift if @_;
- $old;
- };
- }
- *uri = \&action; # alias
-}
-
-=item $value = $form->attr( $name )
-
-=item $form->attr( $name, $new_value )
-
-This method give access to the original HTML attributes of the <form> tag.
-The $name should always be passed in lower case.
-
-Example:
-
- @f = HTML::Form->parse( $html, $foo );
- @f = grep $_->attr("id") eq "foo", @f;
- die "No form named 'foo' found" unless @f;
- $foo = shift @f;
-
-=cut
-
-sub attr {
- my $self = shift;
- my $name = shift;
- return undef unless defined $name;
-
- my $old = $self->{attr}{$name};
- $self->{attr}{$name} = shift if @_;
- return $old;
-}
-
-=item $bool = $form->strict
-
-=item $form->strict( $bool )
-
-Gets/sets the strict attribute of a form. If the strict is turned on
-the methods that change values of the form will croak if you try to
-set illegal values or modify readonly fields. The default is not to be strict.
-
-=cut
-
-sub strict {
- my $self = shift;
- my $old = $self->{strict};
- if (@_) {
- $self->{strict} = shift;
- for my $input (@{$self->{inputs}}) {
- $input->strict($self->{strict});
- }
- }
- return $old;
-}
-
-
-=item @inputs = $form->inputs
-
-This method returns the list of inputs in the form. If called in
-scalar context it returns the number of inputs contained in the form.
-See L</INPUTS> for what methods are available for the input objects
-returned.
-
-=cut
-
-sub inputs
-{
- my $self = shift;
- @{$self->{'inputs'}};
-}
-
-
-=item $input = $form->find_input( $selector )
-
-=item $input = $form->find_input( $selector, $type )
-
-=item $input = $form->find_input( $selector, $type, $index )
-
-This method is used to locate specific inputs within the form. All
-inputs that match the arguments given are returned. In scalar context
-only the first is returned, or C<undef> if none match.
-
-If $selector is specified, then the input's name, id, class attribute must
-match. A selector prefixed with '#' must match the id attribute of the input.
-A selector prefixed with '.' matches the class attribute. A selector prefixed
-with '^' or with no prefix matches the name attribute.
-
-If $type is specified, then the input must have the specified type.
-The following type names are used: "text", "password", "hidden",
-"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
-
-The $index is the sequence number of the input matched where 1 is the
-first. If combined with $name and/or $type then it select the I<n>th
-input with the given name and/or type.
-
-=cut
-
-sub find_input
-{
- my($self, $name, $type, $no) = @_;
- if (wantarray) {
- my @res;
- my $c;
- for (@{$self->{'inputs'}}) {
- next if defined($name) && !$_->selected($name);
- next if $type && $type ne $_->{type};
- $c++;
- next if $no && $no != $c;
- push(@res, $_);
- }
- return @res;
-
- }
- else {
- $no ||= 1;
- for (@{$self->{'inputs'}}) {
- next if defined($name) && !$_->selected($name);
- next if $type && $type ne $_->{type};
- next if --$no;
- return $_;
- }
- return undef;
- }
-}
-
-sub fixup
-{
- my $self = shift;
- for (@{$self->{'inputs'}}) {
- $_->fixup;
- }
-}
-
-
-=item $value = $form->value( $selector )
-
-=item $form->value( $selector, $new_value )
-
-The value() method can be used to get/set the value of some input. If
-strict is enabled and no input has the indicated name, then this method will croak.
-
-If multiple inputs have the same name, only the first one will be
-affected.
-
-The call:
-
- $form->value('foo')
-
-is basically a short-hand for:
-
- $form->find_input('foo')->value;
-
-=cut
-
-sub value
-{
- my $self = shift;
- my $key = shift;
- my $input = $self->find_input($key);
- unless ($input) {
- Carp::croak("No such field '$key'") if $self->{strict};
- return undef unless @_;
- $input = $self->push_input("text", { name => $key, value => "" });
- }
- local $Carp::CarpLevel = 1;
- $input->value(@_);
-}
-
-=item @names = $form->param
-
-=item @values = $form->param( $name )
-
-=item $form->param( $name, $value, ... )
-
-=item $form->param( $name, \@values )
-
-Alternative interface to examining and setting the values of the form.
-
-If called without arguments then it returns the names of all the
-inputs in the form. The names will not repeat even if multiple inputs
-have the same name. In scalar context the number of different names
-is returned.
-
-If called with a single argument then it returns the value or values
-of inputs with the given name. If called in scalar context only the
-first value is returned. If no input exists with the given name, then
-C<undef> is returned.
-
-If called with 2 or more arguments then it will set values of the
-named inputs. This form will croak if no inputs have the given name
-or if any of the values provided does not fit. Values can also be
-provided as a reference to an array. This form will allow unsetting
-all values with the given name as well.
-
-This interface resembles that of the param() function of the CGI
-module.
-
-=cut
-
-sub param {
- my $self = shift;
- if (@_) {
- my $name = shift;
- my @inputs;
- for ($self->inputs) {
- my $n = $_->name;
- next if !defined($n) || $n ne $name;
- push(@inputs, $_);
- }
-
- if (@_) {
- # set
- die "No '$name' parameter exists" unless @inputs;
- my @v = @_;
- @v = @{$v[0]} if @v == 1 && ref($v[0]);
- while (@v) {
- my $v = shift @v;
- my $err;
- for my $i (0 .. @inputs-1) {
- eval {
- $inputs[$i]->value($v);
- };
- unless ($@) {
- undef($err);
- splice(@inputs, $i, 1);
- last;
- }
- $err ||= $@;
- }
- die $err if $err;
- }
-
- # the rest of the input should be cleared
- for (@inputs) {
- $_->value(undef);
- }
- }
- else {
- # get
- my @v;
- for (@inputs) {
- if (defined(my $v = $_->value)) {
- push(@v, $v);
- }
- }
- return wantarray ? @v : $v[0];
- }
- }
- else {
- # list parameter names
- my @n;
- my %seen;
- for ($self->inputs) {
- my $n = $_->name;
- next if !defined($n) || $seen{$n}++;
- push(@n, $n);
- }
- return @n;
- }
-}
-
-
-=item $form->try_others( \&callback )
-
-This method will iterate over all permutations of unvisited enumerated
-values (<select>, <radio>, <checkbox>) and invoke the callback for
-each. The callback is passed the $form as argument. The return value
-from the callback is ignored and the try_others() method itself does
-not return anything.
-
-=cut
-
-sub try_others
-{
- my($self, $cb) = @_;
- my @try;
- for (@{$self->{'inputs'}}) {
- my @not_tried_yet = $_->other_possible_values;
- next unless @not_tried_yet;
- push(@try, [\@not_tried_yet, $_]);
- }
- return unless @try;
- $self->_try($cb, \@try, 0);
-}
-
-sub _try
-{
- my($self, $cb, $try, $i) = @_;
- for (@{$try->[$i][0]}) {
- $try->[$i][1]->value($_);
- &$cb($self);
- $self->_try($cb, $try, $i+1) if $i+1 < @$try;
- }
-}
-
-
-=item $request = $form->make_request
-
-Will return an C<HTTP::Request> object that reflects the current setting
-of the form. You might want to use the click() method instead.
-
-=cut
-
-sub make_request
-{
- my $self = shift;
- my $method = uc $self->{'method'};
- my $uri = $self->{'action'};
- my $enctype = $self->{'enctype'};
- my @form = $self->form;
-
- my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
- if ($Encode_available) {
- foreach my $fi (@form) {
- $fi = Encode::encode($charset, $fi) unless ref($fi);
- }
- }
-
- if ($method eq "GET") {
- require HTTP::Request;
- $uri = URI->new($uri, "http");
- $uri->query_form(@form);
- return HTTP::Request->new(GET => $uri);
- }
- elsif ($method eq "POST") {
- require HTTP::Request::Common;
- return HTTP::Request::Common::POST($uri, \@form,
- Content_Type => $enctype);
- }
- else {
- Carp::croak("Unknown method '$method'");
- }
-}
-
-
-=item $request = $form->click
-
-=item $request = $form->click( $selector )
-
-=item $request = $form->click( $x, $y )
-
-=item $request = $form->click( $selector, $x, $y )
-
-Will "click" on the first clickable input (which will be of type
-C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
-object that can then be passed to C<LWP::UserAgent> if you want to
-obtain the server response.
-
-If a $selector is specified, we will click on the first clickable input
-matching the selector, and the method will croak if no matching clickable
-input is found. If $selector is I<not> specified, then it
-is ok if the form contains no clickable inputs. In this case the
-click() method returns the same request as the make_request() method
-would do. See description of the find_input() method above for how
-the $selector is specified.
-
-If there are multiple clickable inputs with the same name, then there
-is no way to get the click() method of the C<HTML::Form> to click on
-any but the first. If you need this you would have to locate the
-input with find_input() and invoke the click() method on the given
-input yourself.
-
-A click coordinate pair can also be provided, but this only makes a
-difference if you clicked on an image. The default coordinate is
-(1,1). The upper-left corner of the image is (0,0), but some badly
-coded CGI scripts are known to not recognize this. Therefore (1,1) was
-selected as a safer default.
-
-=cut
-
-sub click
-{
- my $self = shift;
- my $name;
- $name = shift if (@_ % 2) == 1; # odd number of arguments
-
- # try to find first submit button to activate
- for (@{$self->{'inputs'}}) {
- next unless $_->can("click");
- next if $name && !$_->selected($name);
- next if $_->disabled;
- return $_->click($self, @_);
- }
- Carp::croak("No clickable input with name $name") if $name;
- $self->make_request;
-}
-
-
-=item @kw = $form->form
-
-Returns the current setting as a sequence of key/value pairs. Note
-that keys might be repeated, which means that some values might be
-lost if the return values are assigned to a hash.
-
-In scalar context this method returns the number of key/value pairs
-generated.
-
-=cut
-
-sub form
-{
- my $self = shift;
- map { $_->form_name_value($self) } @{$self->{'inputs'}};
-}
-
-
-=item $form->dump
-
-Returns a textual representation of current state of the form. Mainly
-useful for debugging. If called in void context, then the dump is
-printed on STDERR.
-
-=cut
-
-sub dump
-{
- my $self = shift;
- my $method = $self->{'method'};
- my $uri = $self->{'action'};
- my $enctype = $self->{'enctype'};
- my $dump = "$method $uri";
- $dump .= " ($enctype)"
- if $enctype ne "application/x-www-form-urlencoded";
- $dump .= " [$self->{attr}{name}]"
- if exists $self->{attr}{name};
- $dump .= "\n";
- for ($self->inputs) {
- $dump .= " " . $_->dump . "\n";
- }
- print STDERR $dump unless defined wantarray;
- $dump;
-}
-
-
-#---------------------------------------------------
-package HTML::Form::Input;
-
-=back
-
-=head1 INPUTS
-
-An C<HTML::Form> objects contains a sequence of I<inputs>. References to
-the inputs can be obtained with the $form->inputs or $form->find_input
-methods.
-
-Note that there is I<not> a one-to-one correspondence between input
-I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
-input object basically represents a name/value pair, so when multiple
-HTML elements contribute to the same name/value pair in the submitted
-form they are combined.
-
-The input elements that are mapped one-to-one are "text", "textarea",
-"password", "hidden", "file", "image", "submit" and "checkbox". For
-the "radio" and "option" inputs the story is not as simple: All
-E<lt>input type="radio"E<gt> elements with the same name will
-contribute to the same input radio object. The number of radio input
-objects will be the same as the number of distinct names used for the
-E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
-without the C<multiple> attribute there will be one input object of
-type of "option". For a E<lt>select multipleE<gt> element there will
-be one input object for each contained E<lt>optionE<gt> element. Each
-one of these option objects will have the same name.
-
-The following methods are available for the I<input> objects:
-
-=over 4
-
-=cut
-
-sub new
-{
- my $class = shift;
- my $self = bless {@_}, $class;
- $self;
-}
-
-sub add_to_form
-{
- my($self, $form) = @_;
- push(@{$form->{'inputs'}}, $self);
- $self;
-}
-
-sub strict {
- my $self = shift;
- my $old = $self->{strict};
- if (@_) {
- $self->{strict} = shift;
- }
- $old;
-}
-
-sub fixup {}
-
-
-=item $input->type
-
-Returns the type of this input. The type is one of the following
-strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
-"radio", "checkbox" or "option".
-
-=cut
-
-sub type
-{
- shift->{type};
-}
-
-=item $name = $input->name
-
-=item $input->name( $new_name )
-
-This method can be used to get/set the current name of the input.
-
-=item $input->id
-
-=item $input->class
-
-These methods can be used to get/set the current id or class attribute for the input.
-
-=item $input->selected( $selector )
-
-Returns TRUE if the given selector matched the input. See the description of
-the find_input() method above for a description of the selector syntax.
-
-=item $value = $input->value
-
-=item $input->value( $new_value )
-
-This method can be used to get/set the current value of an
-input.
-
-If strict is enabled and the input only can take an enumerated list of values,
-then it is an error to try to set it to something else and the method will
-croak if you try.
-
-You will also be able to set the value of read-only inputs, but a
-warning will be generated if running under C<perl -w>.
-
-=cut
-
-sub name
-{
- my $self = shift;
- my $old = $self->{name};
- $self->{name} = shift if @_;
- $old;
-}
-
-sub id
-{
- my $self = shift;
- my $old = $self->{id};
- $self->{id} = shift if @_;
- $old;
-}
-
-sub class
-{
- my $self = shift;
- my $old = $self->{class};
- $self->{class} = shift if @_;
- $old;
-}
-
-sub selected {
- my($self, $sel) = @_;
- return undef unless defined $sel;
- my $attr =
- $sel =~ s/^\^// ? "name" :
- $sel =~ s/^#// ? "id" :
- $sel =~ s/^\.// ? "class" :
- "name";
- return 0 unless defined $self->{$attr};
- return $self->{$attr} eq $sel;
-}
-
-sub value
-{
- my $self = shift;
- my $old = $self->{value};
- $self->{value} = shift if @_;
- $old;
-}
-
-=item $input->possible_values
-
-Returns a list of all values that an input can take. For inputs that
-do not have discrete values, this returns an empty list.
-
-=cut
-
-sub possible_values
-{
- return;
-}
-
-=item $input->other_possible_values
-
-Returns a list of all values not tried yet.
-
-=cut
-
-sub other_possible_values
-{
- return;
-}
-
-=item $input->value_names
-
-For some inputs the values can have names that are different from the
-values themselves. The number of names returned by this method will
-match the number of values reported by $input->possible_values.
-
-When setting values using the value() method it is also possible to
-use the value names in place of the value itself.
-
-=cut
-
-sub value_names {
- return
-}
-
-=item $bool = $input->readonly
-
-=item $input->readonly( $bool )
-
-This method is used to get/set the value of the readonly attribute.
-You are allowed to modify the value of readonly inputs, but setting
-the value will generate some noise when warnings are enabled. Hidden
-fields always start out readonly.
-
-=cut
-
-sub readonly {
- my $self = shift;
- my $old = $self->{readonly};
- $self->{readonly} = shift if @_;
- $old;
-}
-
-=item $bool = $input->disabled
-
-=item $input->disabled( $bool )
-
-This method is used to get/set the value of the disabled attribute.
-Disabled inputs do not contribute any key/value pairs for the form
-value.
-
-=cut
-
-sub disabled {
- my $self = shift;
- my $old = $self->{disabled};
- $self->{disabled} = shift if @_;
- $old;
-}
-
-=item $input->form_name_value
-
-Returns a (possible empty) list of key/value pairs that should be
-incorporated in the form value from this input.
-
-=cut
-
-sub form_name_value
-{
- my $self = shift;
- my $name = $self->{'name'};
- return unless defined $name;
- return if $self->disabled;
- my $value = $self->value;
- return unless defined $value;
- return ($name => $value);
-}
-
-sub dump
-{
- my $self = shift;
- my $name = $self->name;
- $name = "<NONAME>" unless defined $name;
- my $value = $self->value;
- $value = "<UNDEF>" unless defined $value;
- my $dump = "$name=$value";
-
- my $type = $self->type;
-
- $type .= " disabled" if $self->disabled;
- $type .= " readonly" if $self->readonly;
- return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
-
- my @menu;
- my $i = 0;
- for (@{$self->{menu}}) {
- my $opt = $_->{value};
- $opt = "<UNDEF>" unless defined $opt;
- $opt .= "/$_->{name}"
- if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
- substr($opt,0,0) = "-" if $_->{disabled};
- if (exists $self->{current} && $self->{current} == $i) {
- substr($opt,0,0) = "!" unless $_->{seen};
- substr($opt,0,0) = "*";
- }
- else {
- substr($opt,0,0) = ":" if $_->{seen};
- }
- push(@menu, $opt);
- $i++;
- }
-
- return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
-}
-
-
-#---------------------------------------------------
-package HTML::Form::TextInput;
-@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
-
-#input/text
-#input/password
-#input/hidden
-#textarea
-
-sub value
-{
- my $self = shift;
- my $old = $self->{value};
- $old = "" unless defined $old;
- if (@_) {
- Carp::croak("Input '$self->{name}' is readonly")
- if $self->{strict} && $self->{readonly};
- my $new = shift;
- my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
- Carp::croak("Input '$self->{name}' has maxlength '$n'")
- if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
- $self->{value} = $new;
- }
- $old;
-}
-
-#---------------------------------------------------
-package HTML::Form::IgnoreInput;
-@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
-
-#input/button
-#input/reset
-
-sub value { return }
-
-
-#---------------------------------------------------
-package HTML::Form::ListInput;
-@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
-
-#select/option (val1, val2, ....)
-#input/radio (undef, val1, val2,...)
-#input/checkbox (undef, value)
-#select-multiple/option (undef, value)
-
-sub new
-{
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- my $value = delete $self->{value};
- my $value_name = delete $self->{value_name};
- my $type = $self->{type};
-
- if ($type eq "checkbox") {
- $value = "on" unless defined $value;
- $self->{menu} = [
- { value => undef, name => "off", },
- { value => $value, name => $value_name, },
- ];
- $self->{current} = (delete $self->{checked}) ? 1 : 0;
- ;
- }
- else {
- $self->{option_disabled}++
- if $type eq "radio" && delete $self->{disabled};
- $self->{menu} = [
- {value => $value, name => $value_name},
- ];
- my $checked = $self->{checked} || $self->{option_selected};
- delete $self->{checked};
- delete $self->{option_selected};
- if (exists $self->{multiple}) {
- unshift(@{$self->{menu}}, { value => undef, name => "off"});
- $self->{current} = $checked ? 1 : 0;
- }
- else {
- $self->{current} = 0 if $checked;
- }
- }
- $self;
-}
-
-sub add_to_form
-{
- my($self, $form) = @_;
- my $type = $self->type;
-
- return $self->SUPER::add_to_form($form)
- if $type eq "checkbox";
-
- if ($type eq "option" && exists $self->{multiple}) {
- $self->{disabled} ||= delete $self->{option_disabled};
- return $self->SUPER::add_to_form($form);
- }
-
- die "Assert" if @{$self->{menu}} != 1;
- my $m = $self->{menu}[0];
- $m->{disabled}++ if delete $self->{option_disabled};
-
- my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
- return $self->SUPER::add_to_form($form) unless $prev;
-
- # merge menues
- $prev->{current} = @{$prev->{menu}} if exists $self->{current};
- push(@{$prev->{menu}}, $m);
-}
-
-sub fixup
-{
- my $self = shift;
- if ($self->{type} eq "option" && !(exists $self->{current})) {
- $self->{current} = 0;
- }
- $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
-}
-
-sub disabled
-{
- my $self = shift;
- my $type = $self->type;
-
- my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
- if (@_) {
- my $v = shift;
- $self->{disabled} = $v;
- for (@{$self->{menu}}) {
- $_->{disabled} = $v;
- }
- }
- return $old;
-}
-
-sub _menu_all_disabled {
- for (@_) {
- return 0 unless $_->{disabled};
- }
- return 1;
-}
-
-sub value
-{
- my $self = shift;
- my $old;
- $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
- $old = $self->{value} if exists $self->{value};
- if (@_) {
- my $i = 0;
- my $val = shift;
- my $cur;
- my $disabled;
- for (@{$self->{menu}}) {
- if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
- (!defined($val) && !defined($_->{value}))
- )
- {
- $cur = $i;
- $disabled = $_->{disabled};
- last unless $disabled;
- }
- $i++;
- }
- if (!(defined $cur) || $disabled) {
- if (defined $val) {
- # try to search among the alternative names as well
- my $i = 0;
- my $cur_ignorecase;
- my $lc_val = lc($val);
- for (@{$self->{menu}}) {
- if (defined $_->{name}) {
- if ($val eq $_->{name}) {
- $disabled = $_->{disabled};
- $cur = $i;
- last unless $disabled;
- }
- if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
- $cur_ignorecase = $i;
- }
- }
- $i++;
- }
- unless (defined $cur) {
- $cur = $cur_ignorecase;
- if (defined $cur) {
- $disabled = $self->{menu}[$cur]{disabled};
- }
- elsif ($self->{strict}) {
- my $n = $self->name;
- Carp::croak("Illegal value '$val' for field '$n'");
- }
- }
- }
- elsif ($self->{strict}) {
- my $n = $self->name;
- Carp::croak("The '$n' field can't be unchecked");
- }
- }
- if ($self->{strict} && $disabled) {
- my $n = $self->name;
- Carp::croak("The value '$val' has been disabled for field '$n'");
- }
- if (defined $cur) {
- $self->{current} = $cur;
- $self->{menu}[$cur]{seen}++;
- delete $self->{value};
- }
- else {
- $self->{value} = $val;
- delete $self->{current};
- }
- }
- $old;
-}
-
-=item $input->check
-
-Some input types represent toggles that can be turned on/off. This
-includes "checkbox" and "option" inputs. Calling this method turns
-this input on without having to know the value name. If the input is
-already on, then nothing happens.
-
-This has the same effect as:
-
- $input->value($input->possible_values[1]);
-
-The input can be turned off with:
-
- $input->value(undef);
-
-=cut
-
-sub check
-{
- my $self = shift;
- $self->{current} = 1;
- $self->{menu}[1]{seen}++;
-}
-
-sub possible_values
-{
- my $self = shift;
- map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
-}
-
-sub other_possible_values
-{
- my $self = shift;
- map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
-}
-
-sub value_names {
- my $self = shift;
- my @names;
- for (@{$self->{menu}}) {
- my $n = $_->{name};
- $n = $_->{value} unless defined $n;
- push(@names, $n);
- }
- @names;
-}
-
-
-#---------------------------------------------------
-package HTML::Form::SubmitInput;
-@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
-
-#input/image
-#input/submit
-
-=item $input->click($form, $x, $y)
-
-Some input types (currently "submit" buttons and "images") can be
-clicked to submit the form. The click() method returns the
-corresponding C<HTTP::Request> object.
-
-=cut
-
-sub click
-{
- my($self,$form,$x,$y) = @_;
- for ($x, $y) { $_ = 1 unless defined; }
- local($self->{clicked}) = [$x,$y];
- return $form->make_request;
-}
-
-sub form_name_value
-{
- my $self = shift;
- return unless $self->{clicked};
- return $self->SUPER::form_name_value(@_);
-}
-
-
-#---------------------------------------------------
-package HTML::Form::ImageInput;
-@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
-
-sub form_name_value
-{
- my $self = shift;
- my $clicked = $self->{clicked};
- return unless $clicked;
- return if $self->{disabled};
- my $name = $self->{name};
- $name = (defined($name) && length($name)) ? "$name." : "";
- return ("${name}x" => $clicked->[0],
- "${name}y" => $clicked->[1]
- );
-}
-
-#---------------------------------------------------
-package HTML::Form::FileInput;
-@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
-
-=back
-
-If the input is of type C<file>, then it has these additional methods:
-
-=over 4
-
-=item $input->file
-
-This is just an alias for the value() method. It sets the filename to
-read data from.
-
-For security reasons this field will never be initialized from the parsing
-of a form. This prevents the server from triggering stealth uploads of
-arbitrary files from the client machine.
-
-=cut
-
-sub file {
- my $self = shift;
- $self->value(@_);
-}
-
-=item $filename = $input->filename
-
-=item $input->filename( $new_filename )
-
-This get/sets the filename reported to the server during file upload.
-This attribute defaults to the value reported by the file() method.
-
-=cut
-
-sub filename {
- my $self = shift;
- my $old = $self->{filename};
- $self->{filename} = shift if @_;
- $old = $self->file unless defined $old;
- $old;
-}
-
-=item $content = $input->content
-
-=item $input->content( $new_content )
-
-This get/sets the file content provided to the server during file
-upload. This method can be used if you do not want the content to be
-read from an actual file.
-
-=cut
-
-sub content {
- my $self = shift;
- my $old = $self->{content};
- $self->{content} = shift if @_;
- $old;
-}
-
-=item @headers = $input->headers
-
-=item input->headers($key => $value, .... )
-
-This get/set additional header fields describing the file uploaded.
-This can for instance be used to set the C<Content-Type> reported for
-the file.
-
-=cut
-
-sub headers {
- my $self = shift;
- my $old = $self->{headers} || [];
- $self->{headers} = [@_] if @_;
- @$old;
-}
-
-sub form_name_value {
- my($self, $form) = @_;
- return $self->SUPER::form_name_value($form)
- if $form->method ne "POST" ||
- $form->enctype ne "multipart/form-data";
-
- my $name = $self->name;
- return unless defined $name;
- return if $self->{disabled};
-
- my $file = $self->file;
- my $filename = $self->filename;
- my @headers = $self->headers;
- my $content = $self->content;
- if (defined $content) {
- $filename = $file unless defined $filename;
- $file = undef;
- unshift(@headers, "Content" => $content);
- }
- elsif (!defined($file) || length($file) == 0) {
- return;
- }
-
- # legacy (this used to be the way to do it)
- if (ref($file) eq "ARRAY") {
- my $f = shift @$file;
- my $fn = shift @$file;
- push(@headers, @$file);
- $file = $f;
- $filename = $fn unless defined $filename;
- }
-
- return ($name => [$file, $filename, @headers]);
-}
-
-package HTML::Form::KeygenInput;
-@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
-
-sub challenge {
- my $self = shift;
- return $self->{challenge};
-}
-
-sub keytype {
- my $self = shift;
- return lc($self->{keytype} || 'rsa');
-}
-
-1;
-
-__END__
-
-=back
-
-=head1 SEE ALSO
-
-L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
-
-=head1 COPYRIGHT
-
-Copyright 1998-2008 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut