home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / site / lib / html / Form.pm < prev    next >
Encoding:
Perl POD Document  |  2001-08-01  |  16.2 KB  |  735 lines
  1. package HTML::Form;
  2.  
  3. use strict;
  4. use URI;
  5. use Carp ();
  6.  
  7. use vars qw($VERSION);
  8. $VERSION='0.03';
  9.  
  10. my %form_tags = map {$_ => 1} qw(input textarea button select option);
  11.  
  12. my %type2class = (
  13.  text     => "TextInput",
  14.  password => "TextInput",
  15.  file     => "TextInput",
  16.  hidden   => "TextInput",
  17.  textarea => "TextInput",
  18.  
  19.  button   => "IgnoreInput",
  20.  "reset"  => "IgnoreInput",
  21.  
  22.  radio    => "ListInput",
  23.  checkbox => "ListInput",
  24.  option   => "ListInput",
  25.  
  26.  submit   => "SubmitInput",
  27.  image    => "ImageInput",
  28. );
  29.  
  30. =head1 NAME
  31.  
  32. HTML::Form - Class that represents HTML forms
  33.  
  34. =head1 SYNOPSIS
  35.  
  36.  use HTML::Form;
  37.  $form = HTML::Form->parse($html, $base_uri);
  38.  $form->value(query => "Perl");
  39.  
  40.  use LWP;
  41.  LWP::UserAgent->new->request($form->click);
  42.  
  43. =head1 DESCRIPTION
  44.  
  45. Objects of the C<HTML::Form> class represents a single HTML <form>
  46. ... </form> instance.  A form consist of a sequence of inputs that
  47. usually have names, and which can take on various values.
  48.  
  49. The following methods are available:
  50.  
  51. =over 4
  52.  
  53. =item $form = HTML::Form->new($method, $action_uri, [[$enctype], $input,...])
  54.  
  55. The constructor takes a $method and a $uri as argument.  The $enctype
  56. and and initial inputs are optional.  You will normally use
  57. HTML::Form->parse() to create new HTML::Form objects.
  58.  
  59. =cut
  60.  
  61. sub new {
  62.     my $class = shift;
  63.     my $self = bless {}, $class;
  64.     $self->{method} = uc(shift  || "GET");
  65.     $self->{action} = shift  || Carp::croak("No action defined");
  66.     $self->{enctype} = shift || "application/x-www-form-urlencoded";
  67.     $self->{inputs} = [@_];
  68.     $self;
  69. }
  70.  
  71.  
  72. =item @forms = HTML::Form->parse($html_document, $base_uri)
  73.  
  74. The parse() class method will parse an HTML document and build up
  75. C<HTML::Form> objects for each <form> found.  If called in scalar
  76. context only returns the first <form>.  Returns an empty list if there
  77. are no forms to be found.
  78.  
  79. The $base_uri is (usually) the URI used to access the $html_document.
  80. It is needed to resolve relative action URIs.  For LWP this parameter
  81. is obtained from the $response->base() method.
  82.  
  83. =cut
  84.  
  85. sub parse
  86. {
  87.     my($class, $html, $base_uri) = @_;
  88.     require HTML::TokeParser;
  89.     my $p = HTML::TokeParser->new(\$html);
  90.     eval {
  91.     # optimization
  92.     $p->report_tags(qw(form input textarea select optgroup option));
  93.     };
  94.  
  95.     my @forms;
  96.     my $f;  # current form
  97.  
  98.     while (my $t = $p->get_tag) {
  99.     my($tag,$attr) = @$t;
  100.     if ($tag eq "form") {
  101.         my $action = delete $attr->{'action'};
  102.         $action = "" unless defined $action;
  103.         $action = URI->new_abs($action, $base_uri);
  104.         $f = $class->new(delete $attr->{'method'},
  105.                  $action,
  106.                  delete $attr->{'enctype'});
  107.         $f->{extra_attr} = $attr;
  108.         push(@forms, $f);
  109.         while (my $t = $p->get_tag) {
  110.         my($tag, $attr) = @$t;
  111.         last if $tag eq "/form";
  112.         if ($tag eq "input") {
  113.             my $type = delete $attr->{type} || "text";
  114.             $f->push_input($type, $attr);
  115.         } elsif ($tag eq "textarea") {
  116.             $attr->{textarea_value} = $attr->{value}
  117.                 if exists $attr->{value};
  118.             my $text = $p->get_text("/textarea");
  119.             $attr->{value} = $text;
  120.             $f->push_input("textarea", $attr);
  121.         } elsif ($tag eq "select") {
  122.             $attr->{select_value} = $attr->{value}
  123.                 if exists $attr->{value};
  124.             while ($t = $p->get_tag) {
  125.             my $tag = shift @$t;
  126.             last if $tag eq "/select";
  127.             next if $tag =~ m,/?optgroup,;
  128.             next if $tag eq "/option";
  129.             if ($tag eq "option") {
  130.                 my %a = (%$attr, %{$t->[0]});
  131.                 $a{value} = $p->get_trimmed_text
  132.                 unless defined $a{value};
  133.                 $f->push_input("option", \%a);
  134.             } else {
  135.                 Carp::carp("Bad <select> tag '$tag'") if $^W;
  136.             }
  137.             }
  138.         }
  139.         }
  140.     } elsif ($form_tags{$tag}) {
  141.         Carp::carp("<$tag> outside <form>") if $^W;
  142.     }
  143.     }
  144.     for (@forms) {
  145.     $_->fixup;
  146.     }
  147.  
  148.     wantarray ? @forms : $forms[0];
  149. }
  150.  
  151. =item $form->push_input($type, \%attr)
  152.  
  153. Adds a new input to the form.
  154.  
  155. =cut
  156.  
  157. sub push_input
  158. {
  159.     my($self, $type, $attr) = @_;
  160.     $type = lc $type;
  161.     my $class = $type2class{$type};
  162.     unless ($class) {
  163.     Carp::carp("Unknown input type '$type'") if $^W;
  164.     $class = "IgnoreInput";
  165.     }
  166.     $class = "IgnoreInput" if exists $attr->{disabled};
  167.     $class = "HTML::Form::$class";
  168.  
  169.     my $input = $class->new(type => $type, %$attr);
  170.     $input->add_to_form($self);
  171. }
  172.  
  173.  
  174. =item $form->method( [$new] )
  175.  
  176. =item $form->action( [$new] )
  177.  
  178. =item $form->enctype( [$new] )
  179.  
  180. These method can be used to get/set the corresponding attribute of the
  181. form.
  182.  
  183. =cut
  184.  
  185. BEGIN {
  186.     # Set up some accesor
  187.     for (qw(method action enctype)) {
  188.     my $m = $_;
  189.     no strict 'refs';
  190.     *{$m} = sub {
  191.         my $self = shift;
  192.         my $old = $self->{$m};
  193.         $self->{$m} = shift if @_;
  194.         $old;
  195.     };
  196.     }
  197.     *uri = \&action;  # alias
  198. }
  199.  
  200.  
  201. =item $form->inputs
  202.  
  203. This method returns the list of inputs in the form.
  204.  
  205. =cut
  206.  
  207. sub inputs
  208. {
  209.     my $self = shift;
  210.     @{$self->{'inputs'}};
  211. }
  212.  
  213.  
  214. =item $form->find_input($name, $type, $no)
  215.  
  216. This method is used to locate some specific input within the form.  At
  217. least one of the arguments must be defined.  If no matching input is
  218. found, C<undef> is returned.
  219.  
  220. If $name is specified, then the input must have the indicated name.
  221. If $type is specified then the input must have the specified type.  In
  222. addition to the types possible for <input> HTML tags, we also have
  223. "textarea" and "option".  The $no is the sequence number of the input
  224. with the indicated $name and/or $type (where 1 is the first).
  225.  
  226. =cut
  227.  
  228. sub find_input
  229. {
  230.     my($self, $name, $type, $no) = @_;
  231.     $no ||= 1;
  232.     for (@{$self->{'inputs'}}) {
  233.     if (defined $name) {
  234.         next unless exists $_->{name};
  235.         next if $name ne $_->{name};
  236.     }
  237.     next if $type && $type ne $_->{type};
  238.     next if --$no;
  239.     return $_;
  240.     }
  241.     return;
  242. }
  243.  
  244. sub fixup
  245. {
  246.     my $self = shift;
  247.     for (@{$self->{'inputs'}}) {
  248.     $_->fixup;
  249.     }
  250. }
  251.  
  252.  
  253. =item $form->value($name, [$value])
  254.  
  255. The value() method can be used to get/set the value of some input.  If
  256. no input have the indicated name, then this method will croak.
  257.  
  258. =cut
  259.  
  260. sub value
  261. {
  262.     my $self = shift;
  263.     my $key  = shift;
  264.     my $input = $self->find_input($key);
  265.     Carp::croak("No such field '$key'") unless $input;
  266.     local $Carp::CarpLevel = 1;
  267.     $input->value(@_);
  268. }
  269.  
  270.  
  271. =item $form->try_others(\&callback)
  272.  
  273. This method will iterate over all permutations of unvisited enumerated
  274. values (<select>, <radio>, <checkbox>) and invoke the callback for
  275. each.  The callback is passed the $form as argument.
  276.  
  277. =cut
  278.  
  279. sub try_others
  280. {
  281.     my($self, $cb) = @_;
  282.     my @try;
  283.     for (@{$self->{'inputs'}}) {
  284.     my @not_tried_yet = $_->other_possible_values;
  285.     next unless @not_tried_yet;
  286.     push(@try, [\@not_tried_yet, $_]);
  287.     }
  288.     return unless @try;
  289.     $self->_try($cb, \@try, 0);
  290. }
  291.  
  292. sub _try
  293. {
  294.     my($self, $cb, $try, $i) = @_;
  295.     for (@{$try->[$i][0]}) {
  296.     $try->[$i][1]->value($_);
  297.     &$cb($self);
  298.     $self->_try($cb, $try, $i+1) if $i+1 < @$try;
  299.     }
  300. }
  301.  
  302.  
  303. =item $form->make_request
  304.  
  305. Will return a HTTP::Request object that reflects the current setting
  306. of the form.  You might want to use the click method instead.
  307.  
  308. =cut
  309.  
  310. sub make_request
  311. {
  312.     my $self = shift;
  313.     my $method  = uc $self->{'method'};
  314.     my $uri     = $self->{'action'};
  315.     my $enctype = $self->{'enctype'};
  316.     my @form    = $self->form;
  317.  
  318.     if ($method eq "GET") {
  319.     require HTTP::Request;
  320.     $uri = URI->new($uri, "http");
  321.     $uri->query_form(@form);
  322.     return HTTP::Request->new(GET => $uri);
  323.     } elsif ($method eq "POST") {
  324.     require HTTP::Request::Common;
  325.     return HTTP::Request::Common::POST($uri, \@form,
  326.                        Content_Type => $enctype);
  327.     } else {
  328.     Carp::croak("Unknown method '$method'");
  329.     }
  330. }
  331.  
  332.  
  333. =item $form->click([$name], [$x, $y])
  334.  
  335. Will click on the first clickable input (C<input/submit> or
  336. C<input/image>), with the indicated $name, if specified.  You can
  337. optinally specify a coordinate clicked, which only makes a difference
  338. if you clicked on an image.  The default coordinate is (1,1).
  339.  
  340. =cut
  341.  
  342. sub click
  343. {
  344.     my $self = shift;
  345.     my $name;
  346.     $name = shift if (@_ % 2) == 1;  # odd number of arguments
  347.  
  348.     # try to find first submit button to activate
  349.     for (@{$self->{'inputs'}}) {
  350.         next unless $_->can("click");
  351.         next if $name && $_->name ne $name;
  352.     return $_->click($self, @_);
  353.     }
  354.     Carp::croak("No clickable input with name $name") if $name;
  355.     $self->make_request;
  356. }
  357.  
  358.  
  359. =item $form->form
  360.  
  361. Returns the current setting as a sequence of key/value pairs.
  362.  
  363. =cut
  364.  
  365. sub form
  366. {
  367.     my $self = shift;
  368.     map {$_->form_name_value} @{$self->{'inputs'}};
  369. }
  370.  
  371.  
  372. =item $form->dump
  373.  
  374. Returns a textual representation of the form.  Mainly useful for
  375. debugging.  If called in void context, then the dump is printed on
  376. STDERR.
  377.  
  378. =cut
  379.  
  380. sub dump
  381. {
  382.     my $self = shift;
  383.     my $method  = $self->{'method'};
  384.     my $uri     = $self->{'action'};
  385.     my $enctype = $self->{'enctype'};
  386.     my $dump = "$method $uri";
  387.     $dump .= " ($enctype)"
  388.     if $enctype eq "application/xxx-www-form-urlencoded";
  389.     $dump .= "\n";
  390.     for ($self->inputs) {
  391.     $dump .= "  " . $_->dump . "\n";
  392.     }
  393.     print STDERR $dump unless defined wantarray;
  394.     $dump;
  395. }
  396.  
  397.  
  398. #---------------------------------------------------
  399. package HTML::Form::Input;
  400.  
  401. =back
  402.  
  403. =head1 INPUTS
  404.  
  405. An C<HTML::Form> contains a sequence of inputs.  References to the
  406. inputs can be obtained with the $form->inputs or $form->find_input
  407. methods.  Once you have such a reference, then one of the following
  408. methods can be used on it:
  409.  
  410. =over 4
  411.  
  412. =cut
  413.  
  414. sub new
  415. {
  416.     my $class = shift;
  417.     my $self = bless {@_}, $class;
  418.     $self;
  419. }
  420.  
  421. sub add_to_form
  422. {
  423.     my($self, $form) = @_;
  424.     push(@{$form->{'inputs'}}, $self);
  425.     $self;
  426. }
  427.  
  428. sub fixup {}
  429.  
  430.  
  431. =item $input->type
  432.  
  433. Returns the type of this input.  Types are stuff like "text",
  434. "password", "hidden", "textarea", "image", "submit", "radio",
  435. "checkbox", "option"...
  436.  
  437. =cut
  438.  
  439. sub type
  440. {
  441.     shift->{type};
  442. }
  443.  
  444. =item $input->name([$new])
  445.  
  446. =item $input->value([$new])
  447.  
  448. These methods can be used to set/get the current name or value of an
  449. input.  If the input only can take an enumerated list of values, then
  450. it is an error to try to set it to something else and the method will
  451. croak if you try.
  452.  
  453. =cut
  454.  
  455. sub name
  456. {
  457.     my $self = shift;
  458.     my $old = $self->{name};
  459.     $self->{name} = shift if @_;
  460.     $old;
  461. }
  462.  
  463. sub value
  464. {
  465.     my $self = shift;
  466.     my $old = $self->{value};
  467.     $self->{value} = shift if @_;
  468.     $old;
  469. }
  470.  
  471. =item $input->possible_values
  472.  
  473. Returns a list of all values that and input can take.  For inputs that
  474. does not have discrete values this returns an empty list.
  475.  
  476. =cut
  477.  
  478. sub possible_values
  479. {
  480.     return;
  481. }
  482.  
  483. =item $input->other_possible_values
  484.  
  485. Returns a list of all values not tried yet.
  486.  
  487. =cut
  488.  
  489. sub other_possible_values
  490. {
  491.     return;
  492. }
  493.  
  494. =item $input->form_name_value
  495.  
  496. Returns a (possible empty) list of key/value pairs that should be
  497. incorporated in the form value from this input.
  498.  
  499. =cut
  500.  
  501. sub form_name_value
  502. {
  503.     my $self = shift;
  504.     my $name = $self->{'name'};
  505.     return unless defined $name;
  506.     my $value = $self->value;
  507.     return unless defined $value;
  508.     return ($name => $value);
  509. }
  510.  
  511. sub dump
  512. {
  513.     my $self = shift;
  514.     my $name = $self->name;
  515.     $name = "<NONAME>" unless defined $name;
  516.     my $value = $self->value;
  517.     $value = "<UNDEF>" unless defined $value;
  518.     my $dump = "$name=$value";
  519.  
  520.     my $type = $self->type;
  521.     return $dump if $type eq "text";
  522.  
  523.     $type = ($type eq "text") ? "" : " ($type)";
  524.     my $menu = $self->{menu} || "";
  525.     if ($menu) {
  526.     my @menu;
  527.     for (0 .. @$menu-1) {
  528.         my $opt = $menu->[$_];
  529.         $opt = "<UNDEF>" unless defined $opt;
  530.         substr($opt,0,0) = "*" if $self->{seen}[$_];
  531.         push(@menu, $opt);
  532.     }
  533.     $menu = "[" . join("|", @menu) . "]";
  534.     }
  535.     sprintf "%-30s %-10s %s", $dump, $type, $menu;
  536. }
  537.  
  538.  
  539. #---------------------------------------------------
  540. package HTML::Form::TextInput;
  541. @HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
  542.  
  543. #input/text
  544. #input/password
  545. #input/file
  546. #input/hidden
  547. #textarea
  548.  
  549. sub value
  550. {
  551.     my $self = shift;
  552.     if (@_) {
  553.     if (exists($self->{readonly}) || $self->{type} eq "hidden") {
  554.         Carp::carp("Input '$self->{name}' is readonly") if $^W;
  555.     }
  556.     }
  557.     $self->SUPER::value(@_);
  558. }
  559.  
  560. #---------------------------------------------------
  561. package HTML::Form::IgnoreInput;
  562. @HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
  563.  
  564. #input/button
  565. #input/reset
  566.  
  567. sub value { return }
  568.  
  569.  
  570. #---------------------------------------------------
  571. package HTML::Form::ListInput;
  572. @HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
  573.  
  574. #select/option   (val1, val2, ....)
  575. #input/radio     (undef, val1, val2,...)
  576. #input/checkbox  (undef, value)
  577.  
  578. sub new
  579. {
  580.     my $class = shift;
  581.     my $self = $class->SUPER::new(@_);
  582.     if ($self->type eq "checkbox") {
  583.     my $value = delete $self->{value};
  584.     $value = "on" unless defined $value;
  585.     $self->{menu} = [undef, $value];
  586.     $self->{current} = (exists $self->{checked}) ? 1 : 0;
  587.     delete $self->{checked};
  588.     } else {
  589.     $self->{menu} = [delete $self->{value}];
  590.     my $checked = exists $self->{checked} || exists $self->{selected};
  591.     delete $self->{checked};
  592.     delete $self->{selected};
  593.     if (exists $self->{multiple}) {
  594.         unshift(@{$self->{menu}}, undef);
  595.         $self->{current} = $checked ? 1 : 0;
  596.     } else {
  597.         $self->{current} = 0 if $checked;
  598.     }
  599.     }
  600.     $self;
  601. }
  602.  
  603. sub add_to_form
  604. {
  605.     my($self, $form) = @_;
  606.     my $type = $self->type;
  607.     return $self->SUPER::add_to_form($form)
  608.     if $type eq "checkbox" ||
  609.        ($type eq "option" && exists $self->{multiple});
  610.  
  611.     my $prev = $form->find_input($self->{name}, $self->{type});
  612.     return $self->SUPER::add_to_form($form) unless $prev;
  613.  
  614.     # merge menues
  615.     push(@{$prev->{menu}}, @{$self->{menu}});
  616.     $prev->{current} = @{$prev->{menu}} - 1 if exists $self->{current};
  617. }
  618.  
  619. sub fixup
  620. {
  621.     my $self = shift;
  622.     if ($self->{type} eq "option" && !(exists $self->{current})) {
  623.     $self->{current} = 0;
  624.     }
  625.     $self->{seen} = [(0) x @{$self->{menu}}];
  626.     $self->{seen}[$self->{current}] = 1 if exists $self->{current};
  627. }
  628.  
  629. sub value
  630. {
  631.     my $self = shift;
  632.     my $old;
  633.     $old = $self->{menu}[$self->{current}] if exists $self->{current};
  634.     if (@_) {
  635.     my $i = 0;
  636.     my $val = shift;
  637.     my $cur;
  638.     for (@{$self->{menu}}) {
  639.         if ((defined($val) && defined($_) && $val eq $_) ||
  640.         (!defined($val) && !defined($_))
  641.            )
  642.         {
  643.         $cur = $i;
  644.         last;
  645.         }
  646.         $i++;
  647.     }
  648.     Carp::croak("Illegal value '$val'") unless defined $cur;
  649.     $self->{current} = $cur;
  650.     $self->{seen}[$cur] = 1;
  651.     }
  652.     $old;
  653. }
  654.  
  655. sub possible_values
  656. {
  657.     my $self = shift;
  658.     @{$self->{menu}};
  659. }
  660.  
  661. sub other_possible_values
  662. {
  663.     my $self = shift;
  664.     map { $self->{menu}[$_] }
  665.         grep {!$self->{seen}[$_]}
  666.              0 .. (@{$self->{seen}} - 1);
  667. }
  668.  
  669.  
  670. #---------------------------------------------------
  671. package HTML::Form::SubmitInput;
  672. @HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
  673.  
  674. #input/image
  675. #input/submit
  676.  
  677. =item $input->click($form, $x, $y)
  678.  
  679. Some input types (currently "sumbit" buttons and "images") can be
  680. clicked to submit the form.  The click() method returns the
  681. corrsponding C<HTTP::Request> object.
  682.  
  683. =cut
  684.  
  685. sub click
  686. {
  687.     my($self,$form,$x,$y) = @_;
  688.     for ($x, $y) { $_ = 1 unless defined; }
  689.     local($self->{clicked}) = [$x,$y];
  690.     return $form->make_request;
  691. }
  692.  
  693. sub form_name_value
  694. {
  695.     my $self = shift;
  696.     return unless $self->{clicked};
  697.     return $self->SUPER::form_name_value(@_);
  698. }
  699.  
  700.  
  701. #---------------------------------------------------
  702. package HTML::Form::ImageInput;
  703. @HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
  704.  
  705. sub form_name_value
  706. {
  707.     my $self = shift;
  708.     my $clicked = $self->{clicked};
  709.     return unless $clicked;
  710.     my $name = $self->{name};
  711.     return unless defined $name;
  712.     return ("$name.x" => $clicked->[0],
  713.         "$name.y" => $clicked->[1]
  714.        );
  715. }
  716.  
  717. 1;
  718.  
  719. __END__
  720.  
  721. =back
  722.  
  723. =head1 SEE ALSO
  724.  
  725. L<LWP>, L<HTML::Parser>, L<webchatpp>
  726.  
  727. =head1 COPYRIGHT
  728.  
  729. Copyright 1998-2000 Gisle Aas.
  730.  
  731. This library is free software; you can redistribute it and/or
  732. modify it under the same terms as Perl itself.
  733.  
  734. =cut
  735.