branches/0.4.3/CPAN/HTML/Form.pm

   1 package HTML::Form;
   2
   3 use strict;
   4 use URI;
   5 use Carp ();
   6 use Encode ();
   7
   8 use vars qw($VERSION);
   9 $VERSION = "6.03";
  10
  11 my %form_tags = map {$_ => 1} qw(input textarea button select option);
  12
  13 my %type2class = (
  14  text     => "TextInput",
  15  password => "TextInput",
  16  hidden   => "TextInput",
  17  textarea => "TextInput",
  18
  19  "reset"  => "IgnoreInput",
  20
  21  radio    => "ListInput",
  22  checkbox => "ListInput",
  23  option   => "ListInput",
  24
  25  button   => "SubmitInput",
  26  submit   => "SubmitInput",
  27  image    => "ImageInput",
  28  file     => "FileInput",
  29
  30  keygen   => "KeygenInput",
  31 );
  32
  33 # The new HTML5 input types
  34 %type2class = (%type2class, map { $_ => 'TextInput' } qw(
  35     tel search url email
  36     datetime date month week time datetime-local
  37     number range color
  38 ));
  39
  40 =head1 NAME
  41
  42 HTML::Form - Class that represents an HTML form element
  43
  44 =head1 SYNOPSIS
  45
  46  use HTML::Form;
  47  $form = HTML::Form->parse($html, $base_uri);
  48  $form->value(query => "Perl");
  49
  50  use LWP::UserAgent;
  51  $ua = LWP::UserAgent->new;
  52  $response = $ua->request($form->click);
  53
  54 =head1 DESCRIPTION
  55
  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>.
  62
  63 The following methods are available:
  64
  65 =over 4
  66
  67 =item @forms = HTML::Form->parse( $html_document, $base_uri )
  68
  69 =item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
  70
  71 =item @forms = HTML::Form->parse( $response, %opt )
  72
  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.
  77
  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
  81 (or US-ASCII).
  82
  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:
  88
  89     my @forms = HTML::Form->parse(
  90         Encode::decode($encoding, $html_document_bytes),
  91         base => $base_uri,
  92         charset => $encoding,
  93     );
  94
  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>:
  97
  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,
 103     );
 104
 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:
 107
 108     my $ua = LWP::UserAgent->new;
 109     my $response = $ua->get("http://www.example.com/form.html");
 110     my @forms = HTML::Form->parse($response);
 111
 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.
 114
 115 Additional options might be passed in to control how the parse method
 116 behaves.  The following are all the options currently recognized:
 117
 118 =over
 119
 120 =item C<< base => $uri >>
 121
 122 This is the URI used to retrive the original document.  This option is not optional ;-)
 123
 124 =item C<< charset => $str >>
 125
 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".
 128
 129 =item C<< verbose => $bool >>
 130
 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.
 133
 134 =item C<< strict => $bool >>
 135
 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.
 140
 141 =back
 142
 143 =cut
 144
 145 sub parse
 146 {
 147     my $class = shift;
 148     my $html = shift;
 149     unshift(@_, "base") if @_ == 1;
 150     my %opt = @_;
 151
 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;
 155
 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};
 160
 161     if ($^W) {
 162         Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
 163     }
 164
 165     unless (defined $base_uri) {
 166         if (ref($html)) {
 167             $base_uri = $html->base;
 168         }
 169         else {
 170             Carp::croak("HTML::Form::parse: No \$base_uri provided");
 171         }
 172     }
 173     unless (defined $charset) {
 174         if (ref($html) and $html->can("content_charset")) {
 175             $charset = $html->content_charset;
 176         }
 177         unless ($charset) {
 178             $charset = "UTF-8";
 179         }
 180     }
 181
 182     my @forms;
 183     my $f;  # current form
 184
 185     my %openselect; # index to the open instance of a select
 186
 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'},
 194                              $action,
 195                              $attr->{'enctype'});
 196             $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
 197             $f->{default_charset} = $charset;
 198             $f->{attr} = $attr;
 199             $f->strict(1) if $strict;
 200             %openselect = ();
 201             push(@forms, $f);
 202             my(%labels, $current_label);
 203             while (my $t = $p->get_tag) {
 204                 my($tag, $attr) = @$t;
 205                 last if $tag eq "/form";
 206
 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 }
 213                             $current_label,
 214                             $p->get_phrase;
 215                     }
 216                 }
 217
 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      :
 222                         $p->get_phrase;
 223                 }
 224
 225                 if ($tag eq "label") {
 226                     $current_label = $p->get_phrase;
 227                     $labels{ $attr->{for} } = $current_label
 228                         if exists $attr->{for};
 229                 }
 230                 elsif ($tag eq "/label") {
 231                     $current_label = undef;
 232                 }
 233                 elsif ($tag eq "input") {
 234                     my $type = delete $attr->{type} || "text";
 235                     $f->push_input($type, $attr, $verbose);
 236                 }
 237                 elsif ($tag eq "button") {
 238                     my $type = delete $attr->{type} || "submit";
 239                     $f->push_input($type, $attr, $verbose);
 240                 }
 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);
 247                 }
 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->{$_};
 253                     }
 254                     # count this new select option separately
 255                     my $name = $attr->{name};
 256                     $name = "" unless defined $name;
 257                     $openselect{$name}++;
 258
 259                     while ($t = $p->get_tag) {
 260                         my $tag = shift @$t;
 261                         last if $tag eq "/select";
 262                         next if $tag =~ m,/?optgroup,;
 263                         next if $tag eq "/option";
 264                         if ($tag eq "option") {
 265                             my %a = %{$t->[0]};
 266                             # rename keys so they don't clash with %attr
 267                             for (keys %a) {
 268                                 next if $_ eq "value";
 269                                 $a{"option_$_"} = delete $a{$_};
 270                             }
 271                             while (my($k,$v) = each %$attr) {
 272                                 $a{$k} = $v;
 273                             }
 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);
 279                         }
 280                         else {
 281                             warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
 282                             if ($tag eq "/form" ||
 283                                 $tag eq "input" ||
 284                                 $tag eq "textarea" ||
 285                                 $tag eq "select" ||
 286                                 $tag eq "keygen")
 287                             {
 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
 292                                 # </form>.
 293                                 my $type = ($tag =~ s,^/,,) ? "E" : "S";
 294                                 $p->unget_token([$type, $tag, @$t]);
 295                                 last;
 296                             }
 297                         }
 298                     }
 299                 }
 300                 elsif ($tag eq "keygen") {
 301                     $f->push_input("keygen", $attr, $verbose);
 302                 }
 303             }
 304         }
 305         elsif ($form_tags{$tag}) {
 306             warn("<$tag> outside <form> in $base_uri\n") if $verbose;
 307         }
 308     }
 309     for (@forms) {
 310         $_->fixup;
 311     }
 312
 313     wantarray ? @forms : $forms[0];
 314 }
 315
 316 sub new {
 317     my $class = shift;
 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} = [@_];
 325     $self;
 326 }
 327
 328
 329 sub push_input
 330 {
 331     my($self, $type, $attr, $verbose) = @_;
 332     $type = lc $type;
 333     my $class = $type2class{$type};
 334     unless ($class) {
 335         Carp::carp("Unknown input type '$type'") if $verbose;
 336         $class = "TextInput";
 337     }
 338     $class = "HTML::Form::$class";
 339     my @extra;
 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};
 346     }
 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);
 350 }
 351
 352
 353 =item $method = $form->method
 354
 355 =item $form->method( $new_method )
 356
 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".
 359
 360 =item $action = $form->action
 361
 362 =item $form->action( $new_action )
 363
 364 This method gets/sets the URI which we want to apply the request
 365 I<method> to.
 366
 367 =item $enctype = $form->enctype
 368
 369 =item $form->enctype( $new_enctype )
 370
 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".
 373
 374 =item $accept = $form->accept_charset
 375
 376 =item $form->accept_charset( $new_accept )
 377
 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.
 382
 383 =cut
 384
 385 BEGIN {
 386     # Set up some accesor
 387     for (qw(method action enctype accept_charset)) {
 388         my $m = $_;
 389         no strict 'refs';
 390         *{$m} = sub {
 391             my $self = shift;
 392             my $old = $self->{$m};
 393             $self->{$m} = shift if @_;
 394             $old;
 395         };
 396     }
 397     *uri = \&action;  # alias
 398 }
 399
 400 =item $value = $form->attr( $name )
 401
 402 =item $form->attr( $name, $new_value )
 403
 404 This method give access to the original HTML attributes of the <form> tag.
 405 The $name should always be passed in lower case.
 406
 407 Example:
 408
 409    @f = HTML::Form->parse( $html, $foo );
 410    @f = grep $_->attr("id") eq "foo", @f;
 411    die "No form named 'foo' found" unless @f;
 412    $foo = shift @f;
 413
 414 =cut
 415
 416 sub attr {
 417     my $self = shift;
 418     my $name = shift;
 419     return undef unless defined $name;
 420
 421     my $old = $self->{attr}{$name};
 422     $self->{attr}{$name} = shift if @_;
 423     return $old;
 424 }
 425
 426 =item $bool = $form->strict
 427
 428 =item $form->strict( $bool )
 429
 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.
 433
 434 =cut
 435
 436 sub strict {
 437     my $self = shift;
 438     my $old = $self->{strict};
 439     if (@_) {
 440         $self->{strict} = shift;
 441         for my $input (@{$self->{inputs}}) {
 442             $input->strict($self->{strict});
 443         }
 444     }
 445     return $old;
 446 }
 447
 448
 449 =item @inputs = $form->inputs
 450
 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
 454 returned.
 455
 456 =cut
 457
 458 sub inputs
 459 {
 460     my $self = shift;
 461     @{$self->{'inputs'}};
 462 }
 463
 464
 465 =item $input = $form->find_input( $selector )
 466
 467 =item $input = $form->find_input( $selector, $type )
 468
 469 =item $input = $form->find_input( $selector, $type, $index )
 470
 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.
 474
 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.
 479
 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".
 483
 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.
 487
 488 =cut
 489
 490 sub find_input
 491 {
 492     my($self, $name, $type, $no) = @_;
 493     if (wantarray) {
 494         my @res;
 495         my $c;
 496         for (@{$self->{'inputs'}}) {
 497             next if defined($name) && !$_->selected($name);
 498             next if $type && $type ne $_->{type};
 499             $c++;
 500             next if $no && $no != $c;
 501             push(@res, $_);
 502         }
 503         return @res;
 504
 505     }
 506     else {
 507         $no ||= 1;
 508         for (@{$self->{'inputs'}}) {
 509             next if defined($name) && !$_->selected($name);
 510             next if $type && $type ne $_->{type};
 511             next if --$no;
 512             return $_;
 513         }
 514         return undef;
 515     }
 516 }
 517
 518 sub fixup
 519 {
 520     my $self = shift;
 521     for (@{$self->{'inputs'}}) {
 522         $_->fixup;
 523     }
 524 }
 525
 526
 527 =item $value = $form->value( $selector )
 528
 529 =item $form->value( $selector, $new_value )
 530
 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.
 533
 534 If multiple inputs have the same name, only the first one will be
 535 affected.
 536
 537 The call:
 538
 539     $form->value('foo')
 540
 541 is basically a short-hand for:
 542
 543     $form->find_input('foo')->value;
 544
 545 =cut
 546
 547 sub value
 548 {
 549     my $self = shift;
 550     my $key  = shift;
 551     my $input = $self->find_input($key);
 552     unless ($input) {
 553         Carp::croak("No such field '$key'") if $self->{strict};
 554         return undef unless @_;
 555         $input = $self->push_input("text", { name => $key, value => "" });
 556     }
 557     local $Carp::CarpLevel = 1;
 558     $input->value(@_);
 559 }
 560
 561 =item @names = $form->param
 562
 563 =item @values = $form->param( $name )
 564
 565 =item $form->param( $name, $value, ... )
 566
 567 =item $form->param( $name, \@values )
 568
 569 Alternative interface to examining and setting the values of the form.
 570
 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
 574 is returned.
 575
 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.
 580
 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.
 586
 587 This interface resembles that of the param() function of the CGI
 588 module.
 589
 590 =cut
 591
 592 sub param {
 593     my $self = shift;
 594     if (@_) {
 595         my $name = shift;
 596         my @inputs;
 597         for ($self->inputs) {
 598             my $n = $_->name;
 599             next if !defined($n) || $n ne $name;
 600             push(@inputs, $_);
 601         }
 602
 603         if (@_) {
 604             # set
 605             die "No '$name' parameter exists" unless @inputs;
 606             my @v = @_;
 607             @v = @{$v[0]} if @v == 1 && ref($v[0]);
 608             while (@v) {
 609                 my $v = shift @v;
 610                 my $err;
 611                 for my $i (0 .. @inputs-1) {
 612                     eval {
 613                         $inputs[$i]->value($v);
 614                     };
 615                     unless ($@) {
 616                         undef($err);
 617                         splice(@inputs, $i, 1);
 618                         last;
 619                     }
 620                     $err ||= $@;
 621                 }
 622                 die $err if $err;
 623             }
 624
 625             # the rest of the input should be cleared
 626             for (@inputs) {
 627                 $_->value(undef);
 628             }
 629         }
 630         else {
 631             # get
 632             my @v;
 633             for (@inputs) {
 634                 if (defined(my $v = $_->value)) {
 635                     push(@v, $v);
 636                 }
 637             }
 638             return wantarray ? @v : $v[0];
 639         }
 640     }
 641     else {
 642         # list parameter names
 643         my @n;
 644         my %seen;
 645         for ($self->inputs) {
 646             my $n = $_->name;
 647             next if !defined($n) || $seen{$n}++;
 648             push(@n, $n);
 649         }
 650         return @n;
 651     }
 652 }
 653
 654
 655 =item $form->try_others( \&callback )
 656
 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
 661 not return anything.
 662
 663 =cut
 664
 665 sub try_others
 666 {
 667     my($self, $cb) = @_;
 668     my @try;
 669     for (@{$self->{'inputs'}}) {
 670         my @not_tried_yet = $_->other_possible_values;
 671         next unless @not_tried_yet;
 672         push(@try, [\@not_tried_yet, $_]);
 673     }
 674     return unless @try;
 675     $self->_try($cb, \@try, 0);
 676 }
 677
 678 sub _try
 679 {
 680     my($self, $cb, $try, $i) = @_;
 681     for (@{$try->[$i][0]}) {
 682         $try->[$i][1]->value($_);
 683         &$cb($self);
 684         $self->_try($cb, $try, $i+1) if $i+1 < @$try;
 685     }
 686 }
 687
 688
 689 =item $request = $form->make_request
 690
 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.
 693
 694 =cut
 695
 696 sub make_request
 697 {
 698     my $self = shift;
 699     my $method  = uc $self->{'method'};
 700     my $uri     = $self->{'action'};
 701     my $enctype = $self->{'enctype'};
 702     my @form    = $self->form;
 703
 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);
 707     }
 708
 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);
 714     }
 715     elsif ($method eq "POST") {
 716         require HTTP::Request::Common;
 717         return HTTP::Request::Common::POST($uri, \@form,
 718                                            Content_Type => $enctype);
 719     }
 720     else {
 721         Carp::croak("Unknown method '$method'");
 722     }
 723 }
 724
 725
 726 =item $request = $form->click
 727
 728 =item $request = $form->click( $selector )
 729
 730 =item $request = $form->click( $x, $y )
 731
 732 =item $request = $form->click( $selector, $x, $y )
 733
 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.
 738
 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.
 746
 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
 751 input yourself.
 752
 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.
 758
 759 =cut
 760
 761 sub click
 762 {
 763     my $self = shift;
 764     my $name;
 765     $name = shift if (@_ % 2) == 1;  # odd number of arguments
 766
 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, @_);
 773     }
 774     Carp::croak("No clickable input with name $name") if $name;
 775     $self->make_request;
 776 }
 777
 778
 779 =item @kw = $form->form
 780
 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.
 784
 785 In scalar context this method returns the number of key/value pairs
 786 generated.
 787
 788 =cut
 789
 790 sub form
 791 {
 792     my $self = shift;
 793     map { $_->form_name_value($self) } @{$self->{'inputs'}};
 794 }
 795
 796
 797 =item $form->dump
 798
 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
 801 printed on STDERR.
 802
 803 =cut
 804
 805 sub dump
 806 {
 807     my $self = shift;
 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};
 816     $dump .= "\n";
 817     for ($self->inputs) {
 818         $dump .= "  " . $_->dump . "\n";
 819     }
 820     print STDERR $dump unless defined wantarray;
 821     $dump;
 822 }
 823
 824
 825 #---------------------------------------------------
 826 package HTML::Form::Input;
 827
 828 =back
 829
 830 =head1 INPUTS
 831
 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
 834 methods.
 835
 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.
 841
 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.
 853
 854 The following methods are available for the I<input> objects:
 855
 856 =over 4
 857
 858 =cut
 859
 860 sub new
 861 {
 862     my $class = shift;
 863     my $self = bless {@_}, $class;
 864     $self;
 865 }
 866
 867 sub add_to_form
 868 {
 869     my($self, $form) = @_;
 870     push(@{$form->{'inputs'}}, $self);
 871     $self;
 872 }
 873
 874 sub strict {
 875     my $self = shift;
 876     my $old = $self->{strict};
 877     if (@_) {
 878         $self->{strict} = shift;
 879     }
 880     $old;
 881 }
 882
 883 sub fixup {}
 884
 885
 886 =item $input->type
 887
 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".
 891
 892 =cut
 893
 894 sub type
 895 {
 896     shift->{type};
 897 }
 898
 899 =item $name = $input->name
 900
 901 =item $input->name( $new_name )
 902
 903 This method can be used to get/set the current name of the input.
 904
 905 =item $input->id
 906
 907 =item $input->class
 908
 909 These methods can be used to get/set the current id or class attribute for the input.
 910
 911 =item $input->selected( $selector )
 912
 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.
 915
 916 =item $value = $input->value
 917
 918 =item $input->value( $new_value )
 919
 920 This method can be used to get/set the current value of an
 921 input.
 922
 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
 925 croak if you try.
 926
 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>.
 929
 930 =cut
 931
 932 sub name
 933 {
 934     my $self = shift;
 935     my $old = $self->{name};
 936     $self->{name} = shift if @_;
 937     $old;
 938 }
 939
 940 sub id
 941 {
 942     my $self = shift;
 943     my $old = $self->{id};
 944     $self->{id} = shift if @_;
 945     $old;
 946 }
 947
 948 sub class
 949 {
 950     my $self = shift;
 951     my $old = $self->{class};
 952     $self->{class} = shift if @_;
 953     $old;
 954 }
 955
 956 sub selected {
 957     my($self, $sel) = @_;
 958     return undef unless defined $sel;
 959     my $attr =
 960         $sel =~ s/^\^// ? "name"  :
 961         $sel =~ s/^#//  ? "id"    :
 962         $sel =~ s/^\.// ? "class" :
 963                           "name";
 964     return 0 unless defined $self->{$attr};
 965     return $self->{$attr} eq $sel;
 966 }
 967
 968 sub value
 969 {
 970     my $self = shift;
 971     my $old = $self->{value};
 972     $self->{value} = shift if @_;
 973     $old;
 974 }
 975
 976 =item $input->possible_values
 977
 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.
 980
 981 =cut
 982
 983 sub possible_values
 984 {
 985     return;
 986 }
 987
 988 =item $input->other_possible_values
 989
 990 Returns a list of all values not tried yet.
 991
 992 =cut
 993
 994 sub other_possible_values
 995 {
 996     return;
 997 }
 998
 999 =item $input->value_names
1000
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.
1004
1005 When setting values using the value() method it is also possible to
1006 use the value names in place of the value itself.
1007
1008 =cut
1009
1010 sub value_names {
1011     return
1012 }
1013
1014 =item $bool = $input->readonly
1015
1016 =item $input->readonly( $bool )
1017
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.
1022
1023 =cut
1024
1025 sub readonly {
1026     my $self = shift;
1027     my $old = $self->{readonly};
1028     $self->{readonly} = shift if @_;
1029     $old;
1030 }
1031
1032 =item $bool = $input->disabled
1033
1034 =item $input->disabled( $bool )
1035
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
1038 value.
1039
1040 =cut
1041
1042 sub disabled {
1043     my $self = shift;
1044     my $old = $self->{disabled};
1045     $self->{disabled} = shift if @_;
1046     $old;
1047 }
1048
1049 =item $input->form_name_value
1050
1051 Returns a (possible empty) list of key/value pairs that should be
1052 incorporated in the form value from this input.
1053
1054 =cut
1055
1056 sub form_name_value
1057 {
1058     my $self = shift;
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);
1065 }
1066
1067 sub dump
1068 {
1069     my $self = shift;
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";
1075
1076     my $type = $self->type;
1077
1078     $type .= " disabled" if $self->disabled;
1079     $type .= " readonly" if $self->readonly;
1080     return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
1081
1082     my @menu;
1083     my $i = 0;
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) = "*";
1093         }
1094         else {
1095             substr($opt,0,0) = ":" if $_->{seen};
1096         }
1097         push(@menu, $opt);
1098         $i++;
1099     }
1100
1101     return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
1102 }
1103
1104
1105 #---------------------------------------------------
1106 package HTML::Form::TextInput;
1107 @HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
1108
1109 #input/text
1110 #input/password
1111 #input/hidden
1112 #textarea
1113
1114 sub value
1115 {
1116     my $self = shift;
1117     my $old = $self->{value};
1118     $old = "" unless defined $old;
1119     if (@_) {
1120         Carp::croak("Input '$self->{name}' is readonly")
1121             if $self->{strict} && $self->{readonly};
1122         my $new = shift;
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;
1127     }
1128     $old;
1129 }
1130
1131 #---------------------------------------------------
1132 package HTML::Form::IgnoreInput;
1133 @HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
1134
1135 #input/button
1136 #input/reset
1137
1138 sub value { return }
1139
1140
1141 #---------------------------------------------------
1142 package HTML::Form::ListInput;
1143 @HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
1144
1145 #select/option   (val1, val2, ....)
1146 #input/radio     (undef, val1, val2,...)
1147 #input/checkbox  (undef, value)
1148 #select-multiple/option (undef, value)
1149
1150 sub new
1151 {
1152     my $class = shift;
1153     my $self = $class->SUPER::new(@_);
1154
1155     my $value = delete $self->{value};
1156     my $value_name = delete $self->{value_name};
1157     my $type = $self->{type};
1158
1159     if ($type eq "checkbox") {
1160         $value = "on" unless defined $value;
1161         $self->{menu} = [
1162             { value => undef, name => "off", },
1163             { value => $value, name => $value_name, },
1164         ];
1165         $self->{current} = (delete $self->{checked}) ? 1 : 0;
1166         ;
1167     }
1168     else {
1169         $self->{option_disabled}++
1170             if $type eq "radio" && delete $self->{disabled};
1171         $self->{menu} = [
1172             {value => $value, name => $value_name},
1173         ];
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;
1180         }
1181         else {
1182             $self->{current} = 0 if $checked;
1183         }
1184     }
1185     $self;
1186 }
1187
1188 sub add_to_form
1189 {
1190     my($self, $form) = @_;
1191     my $type = $self->type;
1192
1193     return $self->SUPER::add_to_form($form)
1194         if $type eq "checkbox";
1195
1196     if ($type eq "option" && exists $self->{multiple}) {
1197         $self->{disabled} ||= delete $self->{option_disabled};
1198         return $self->SUPER::add_to_form($form);
1199     }
1200
1201     die "Assert" if @{$self->{menu}} != 1;
1202     my $m = $self->{menu}[0];
1203     $m->{disabled}++ if delete $self->{option_disabled};
1204
1205     my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
1206     return $self->SUPER::add_to_form($form) unless $prev;
1207
1208     # merge menues
1209     $prev->{current} = @{$prev->{menu}} if exists $self->{current};
1210     push(@{$prev->{menu}}, $m);
1211 }
1212
1213 sub fixup
1214 {
1215     my $self = shift;
1216     if ($self->{type} eq "option" && !(exists $self->{current})) {
1217         $self->{current} = 0;
1218     }
1219     $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
1220 }
1221
1222 sub disabled
1223 {
1224     my $self = shift;
1225     my $type = $self->type;
1226
1227     my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
1228     if (@_) {
1229         my $v = shift;
1230         $self->{disabled} = $v;
1231         for (@{$self->{menu}}) {
1232             $_->{disabled} = $v;
1233         }
1234     }
1235     return $old;
1236 }
1237
1238 sub _menu_all_disabled {
1239     for (@_) {
1240         return 0 unless $_->{disabled};
1241     }
1242     return 1;
1243 }
1244
1245 sub value
1246 {
1247     my $self = shift;
1248     my $old;
1249     $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
1250     $old = $self->{value} if exists $self->{value};
1251     if (@_) {
1252         my $i = 0;
1253         my $val = shift;
1254         my $cur;
1255         my $disabled;
1256         for (@{$self->{menu}}) {
1257             if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
1258                 (!defined($val) && !defined($_->{value}))
1259                )
1260             {
1261                 $cur = $i;
1262                 $disabled = $_->{disabled};
1263                 last unless $disabled;
1264             }
1265             $i++;
1266         }
1267         if (!(defined $cur) || $disabled) {
1268             if (defined $val) {
1269                 # try to search among the alternative names as well
1270                 my $i = 0;
1271                 my $cur_ignorecase;
1272                 my $lc_val = lc($val);
1273                 for (@{$self->{menu}}) {
1274                     if (defined $_->{name}) {
1275                         if ($val eq $_->{name}) {
1276                             $disabled = $_->{disabled};
1277                             $cur = $i;
1278                             last unless $disabled;
1279                         }
1280                         if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
1281                             $cur_ignorecase = $i;
1282                         }
1283                     }
1284                     $i++;
1285                 }
1286                 unless (defined $cur) {
1287                     $cur = $cur_ignorecase;
1288                     if (defined $cur) {
1289                         $disabled = $self->{menu}[$cur]{disabled};
1290                     }
1291                     elsif ($self->{strict}) {
1292                         my $n = $self->name;
1293                         Carp::croak("Illegal value '$val' for field '$n'");
1294                     }
1295                 }
1296             }
1297             elsif ($self->{strict}) {
1298                 my $n = $self->name;
1299                 Carp::croak("The '$n' field can't be unchecked");
1300             }
1301         }
1302         if ($self->{strict} && $disabled) {
1303             my $n = $self->name;
1304             Carp::croak("The value '$val' has been disabled for field '$n'");
1305         }
1306         if (defined $cur) {
1307             $self->{current} = $cur;
1308             $self->{menu}[$cur]{seen}++;
1309             delete $self->{value};
1310         }
1311         else {
1312             $self->{value} = $val;
1313             delete $self->{current};
1314         }
1315     }
1316     $old;
1317 }
1318
1319 =item $input->check
1320
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.
1325
1326 This has the same effect as:
1327
1328     $input->value($input->possible_values[1]);
1329
1330 The input can be turned off with:
1331
1332     $input->value(undef);
1333
1334 =cut
1335
1336 sub check
1337 {
1338     my $self = shift;
1339     $self->{current} = 1;
1340     $self->{menu}[1]{seen}++;
1341 }
1342
1343 sub possible_values
1344 {
1345     my $self = shift;
1346     map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
1347 }
1348
1349 sub other_possible_values
1350 {
1351     my $self = shift;
1352     map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
1353 }
1354
1355 sub value_names {
1356     my $self = shift;
1357     my @names;
1358     for (@{$self->{menu}}) {
1359         my $n = $_->{name};
1360         $n = $_->{value} unless defined $n;
1361         push(@names, $n);
1362     }
1363     @names;
1364 }
1365
1366
1367 #---------------------------------------------------
1368 package HTML::Form::SubmitInput;
1369 @HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
1370
1371 #input/image
1372 #input/submit
1373
1374 =item $input->click($form, $x, $y)
1375
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.
1379
1380 =cut
1381
1382 sub click
1383 {
1384     my($self,$form,$x,$y) = @_;
1385     for ($x, $y) { $_ = 1 unless defined; }
1386     local($self->{clicked}) = [$x,$y];
1387     return $form->make_request;
1388 }
1389
1390 sub form_name_value
1391 {
1392     my $self = shift;
1393     return unless $self->{clicked};
1394     return $self->SUPER::form_name_value(@_);
1395 }
1396
1397
1398 #---------------------------------------------------
1399 package HTML::Form::ImageInput;
1400 @HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
1401
1402 sub form_name_value
1403 {
1404     my $self = shift;
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]
1412            );
1413 }
1414
1415 #---------------------------------------------------
1416 package HTML::Form::FileInput;
1417 @HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
1418
1419 =back
1420
1421 If the input is of type C<file>, then it has these additional methods:
1422
1423 =over 4
1424
1425 =item $input->file
1426
1427 This is just an alias for the value() method.  It sets the filename to
1428 read data from.
1429
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.
1433
1434 =cut
1435
1436 sub file {
1437     my $self = shift;
1438     $self->value(@_);
1439 }
1440
1441 =item $filename = $input->filename
1442
1443 =item $input->filename( $new_filename )
1444
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.
1447
1448 =cut
1449
1450 sub filename {
1451     my $self = shift;
1452     my $old = $self->{filename};
1453     $self->{filename} = shift if @_;
1454     $old = $self->file unless defined $old;
1455     $old;
1456 }
1457
1458 =item $content = $input->content
1459
1460 =item $input->content( $new_content )
1461
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.
1465
1466 =cut
1467
1468 sub content {
1469     my $self = shift;
1470     my $old = $self->{content};
1471     $self->{content} = shift if @_;
1472     $old;
1473 }
1474
1475 =item @headers = $input->headers
1476
1477 =item input->headers($key => $value, .... )
1478
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
1481 the file.
1482
1483 =cut
1484
1485 sub headers {
1486     my $self = shift;
1487     my $old = $self->{headers} || [];
1488     $self->{headers} = [@_] if @_;
1489     @$old;
1490 }
1491
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";
1497
1498     my $name = $self->name;
1499     return unless defined $name;
1500     return if $self->{disabled};
1501
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;
1508         $file = undef;
1509         unshift(@headers, "Content" => $content);
1510     }
1511     elsif (!defined($file) || length($file) == 0) {
1512         return;
1513     }
1514
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);
1520         $file = $f;
1521         $filename = $fn unless defined $filename;
1522     }
1523
1524     return ($name => [$file, $filename, @headers]);
1525 }
1526
1527 package HTML::Form::KeygenInput;
1528 @HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
1529
1530 sub challenge {
1531     my $self = shift;
1532     return $self->{challenge};
1533 }
1534
1535 sub keytype {
1536     my $self = shift;
1537     return lc($self->{keytype} || 'rsa');
1538 }
1539
1540 1;
1541
1542 __END__
1543
1544 =back
1545
1546 =head1 SEE ALSO
1547
1548 L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
1549
1550 =head1 COPYRIGHT
1551
1552 Copyright 1998-2008 Gisle Aas.
1553
1554 This library is free software; you can redistribute it and/or
1555 modify it under the same terms as Perl itself.
1556
1557 =cut