vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/HTML/Form.pm

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