local-lib5/lib/perl5/HTML/Form.pm

   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