form.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package HTML::Form;

# $Id: Form.pm,v 1.54 2005/12/07 14:32:27 gisle Exp $

use strict;
use URI;
use Carp ();

use vars qw($VERSION);
$VERSION = sprintf("%d.%03d", q$Revision: 1.54 $ =~ /(\d+)\.(\d+)/);

my %form_tags = map {$_ => 1} qw(input textarea button select option);

my %type2class = (
 text     => "TextInput",
 password => "TextInput",
 hidden   => "TextInput",
 textarea => "TextInput",

 button   => "IgnoreInput",
 "reset"  => "IgnoreInput",

 radio    => "ListInput",
 checkbox => "ListInput",
 option   => "ListInput",

 submit   => "SubmitInput",
 image    => "ImageInput",
 file     => "FileInput",

 keygen   => "KeygenInput",
);

=head1 NAME

HTML::Form - Class that represents an HTML form element

=head1 SYNOPSIS

 use HTML::Form;
 $form = HTML::Form->parse($html, $base_uri);
 $form->value(query => "Perl");

 use LWP::UserAgent;
 $ua = LWP::UserAgent->new;
 $response = $ua->request($form->click);

=head1 DESCRIPTION

Objects of the C<HTML::Form> class represents a single HTML
C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance.  A form consists of a
sequence of inputs that usually have names, and which can take on
various values.  The state of a form can be tweaked and it can then be
asked to provide C<HTTP::Request> objects that can be passed to the
request() method of C<LWP::UserAgent>.

The following methods are available:

=over 4

=item @forms = HTML::Form->parse( $response )

=item @forms = HTML::Form->parse( $html_document, $base )

=item @forms = HTML::Form->parse( $html_document, %opt )

The parse() class method will parse an HTML document and build up
C<HTML::Form> objects for each <form> element found.  If called in scalar
context only returns the first <form>.  Returns an empty list if there
are no forms to be found.

The $base is the URI used to retrieve the $html_document.  It is
needed to resolve relative action URIs.  If the document was retrieved
with LWP then this this parameter is obtained from the
$response->base() method, as shown by the following example:

    my $ua = LWP::UserAgent->new;
    my $response = $ua->get("http://www.example.com/form.html");
    my @forms = HTML::Form->parse($response->decoded_content,
				  $response->base);

The parse() method can parse from an C<HTTP::Response> object
directly, so the example above can be more conveniently written as:

    my $ua = LWP::UserAgent->new;
    my $response = $ua->get("http://www.example.com/form.html");
    my @forms = HTML::Form->parse($response);

Note that any object that implements a decoded_content() and base() method
with similar behaviour as C<HTTP::Response> will do.

Finally options might be passed in to control how the parse method
behaves.  The following options are currently recognized:

=over

=item C<base>

Another way to provide the base URI.

=item C<verbose>

Print messages to STDERR about any bad HTML form constructs found.

=back

=cut

sub parse
{
    my $class = shift;
    my $html = shift;
    unshift(@_, "base") if @_ == 1;
    my %opt = @_;

    require HTML::TokeParser;
    my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
    eval {
	# optimization
	$p->report_tags(qw(form input textarea select optgroup option keygen label));
    };

    my $base_uri = delete $opt{base};
    my $verbose = delete $opt{verbose};

    if ($^W) {
	Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
    }

    unless (defined $base_uri) {
	if (ref($html)) {
	    $base_uri = $html->base;
	}
	else {
	    Carp::croak("HTML::Form::parse: No \$base_uri provided");
	}
    }

    my @forms;
    my $f;  # current form

    while (my $t = $p->get_tag) {
	my($tag,$attr) = @$t;
	if ($tag eq "form") {
	    my $action = delete $attr->{'action'};
	    $action = "" unless defined $action;
	    $action = URI->new_abs($action, $base_uri);
	    $f = $class->new($attr->{'method'},
			     $action,
			     $attr->{'enctype'});
	    $f->{attr} = $attr;
	    push(@forms, $f);
	    my(%labels, $current_label);
	    while (my $t = $p->get_tag) {
		my($tag, $attr) = @$t;
		last if $tag eq "/form";

		# if we are inside a label tag, then keep
		# appending any text to the current label
		if(defined $current_label) {
		    $current_label = join " ",
		        grep { defined and length }
		        $current_label,
		        $p->get_phrase;
		}

		if ($tag eq "input") {
		    $attr->{value_name} =
		        exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
			defined $current_label                            ?  $current_label      :
		        $p->get_phrase;
		}

		if ($tag eq "label") {
		    $current_label = $p->get_phrase;
		    $labels{ $attr->{for} } = $current_label
		        if exists $attr->{for};
		}
		elsif ($tag eq "/label") {
		    $current_label = undef;
		}
		elsif ($tag eq "input") {
		    my $type = delete $attr->{type} || "text";
		    $f->push_input($type, $attr);
		}
		elsif ($tag eq "textarea") {
		    $attr->{textarea_value} = $attr->{value}
		        if exists $attr->{value};
		    my $text = $p->get_text("/textarea");
		    $attr->{value} = $text;
		    $f->push_input("textarea", $attr);
		}
		elsif ($tag eq "select") {
		    # rename attributes reserved to come for the option tag
		    for ("value", "value_name") {
			$attr->{"select_$_"} = delete $attr->{$_}
			    if exists $attr->{$_};
		    }
		    while ($t = $p->get_tag) {
			my $tag = shift @$t;
			last if $tag eq "/select";
			next if $tag =~ m,/?optgroup,;
			next if $tag eq "/option";
			if ($tag eq "option") {
			    my %a = %{$t->[0]};
			    # rename keys so they don't clash with %attr
			    for (keys %a) {
				next if $_ eq "value";
				$a{"option_$_"} = delete $a{$_};
			    }
			    while (my($k,$v) = each %$attr) {
				$a{$k} = $v;
			    }
			    $a{value_name} = $p->get_trimmed_text;
			    $a{value} = delete $a{value_name}
				unless defined $a{value};
			    $f->push_input("option", \%a);
			}
			else {
			    warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
			    if ($tag eq "/form" ||
				$tag eq "input" ||
				$tag eq "textarea" ||
				$tag eq "select" ||
				$tag eq "keygen")
			    {
				# MSIE implictly terminate the <select> here, so we
				# try to do the same.  Actually the MSIE behaviour
				# appears really strange:  <input> and <textarea>
				# do implictly close, but not <select>, <keygen> or
				# </form>.
				my $type = ($tag =~ s,^/,,) ? "E" : "S";
				$p->unget_token([$type, $tag, @$t]);
				last;
			    }
			}
		    }
		}
		elsif ($tag eq "keygen") {
		    $f->push_input("keygen", $attr);
		}
	    }
	}
	elsif ($form_tags{$tag}) {
	    warn("<$tag> outside <form> in $base_uri\n") if $verbose;
	}
    }
    for (@forms) {
	$_->fixup;
    }

    wantarray ? @forms : $forms[0];
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{method} = uc(shift  || "GET");
    $self->{action} = shift  || Carp::croak("No action defined");
    $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
    $self->{inputs} = [@_];
    $self;
}


sub push_input
{
    my($self, $type, $attr) = @_;
    $type = lc $type;
    my $class = $type2class{$type};
    unless ($class) {
	Carp::carp("Unknown input type '$type'") if $^W;
	$class = "TextInput";
    }
    $class = "HTML::Form::$class";
    my @extra;
    push(@extra, readonly => 1) if $type eq "hidden";

    delete $attr->{type}; # don't confuse the type argument
    my $input = $class->new(type => $type, %$attr, @extra);
    $input->add_to_form($self);
}


=item $method = $form->method

=item $form->method( $new_method )

This method is gets/sets the I<method> name used for the
C<HTTP::Request> generated.  It is a string like "GET" or "POST".

=item $action = $form->action

=item $form->action( $new_action )

This method gets/sets the URI which we want to apply the request
I<method> to.

=item $enctype = $form->enctype

=item $form->enctype( $new_enctype )

This method gets/sets the encoding type for the form data.  It is a
string like "application/x-www-form-urlencoded" or "multipart/form-data".

=cut

BEGIN {
    # Set up some accesor
    for (qw(method action enctype)) {
	my $m = $_;
	no strict 'refs';
	*{$m} = sub {
	    my $self = shift;
	    my $old = $self->{$m};
	    $self->{$m} = shift if @_;
	    $old;
	};
    }
    *uri = \&action;  # alias
}

=item $value = $form->attr( $name )

=item $form->attr( $name, $new_value )

This method give access to the original HTML attributes of the <form> tag.
The $name should always be passed in lower case.

Example:

   @f = HTML::Form->parse( $html, $foo );
   @f = grep $_->attr("id") eq "foo", @f;
   die "No form named 'foo' found" unless @f;
   $foo = shift @f;

=cut

sub attr {
    my $self = shift;
    my $name = shift;
    return undef unless defined $name;

    my $old = $self->{attr}{$name};
    $self->{attr}{$name} = shift if @_;
    return $old;
}

=item @inputs = $form->inputs

This method returns the list of inputs in the form.  If called in
scalar context it returns the number of inputs contained in the form.
See L</INPUTS> for what methods are available for the input objects
returned.

=cut

sub inputs
{
    my $self = shift;
    @{$self->{'inputs'}};
}


=item $input = $form->find_input( $name )

=item $input = $form->find_input( $name, $type )

=item $input = $form->find_input( $name, $type, $index )

This method is used to locate specific inputs within the form.  All
inputs that match the arguments given are returned.  In scalar context
only the first is returned, or C<undef> if none match.

If $name is specified, then the input must have the indicated name.

If $type is specified, then the input must have the specified type.
The following type names are used: "text", "password", "hidden",
"textarea", "file", "image", "submit", "radio", "checkbox" and "option".

The $index is the sequence number of the input matched where 1 is the
first.  If combined with $name and/or $type then it select the I<n>th
input with the given name and/or type.

=cut

sub find_input
{
    my($self, $name, $type, $no) = @_;
    if (wantarray) {
	my @res;
	my $c;
	for (@{$self->{'inputs'}}) {
	    if (defined $name) {
		next unless exists $_->{name};
		next if $name ne $_->{name};
	    }
	    next if $type && $type ne $_->{type};
	    $c++;
	    next if $no && $no != $c;
	    push(@res, $_);
	}
	return @res;
	
    }
    else {
	$no ||= 1;
	for (@{$self->{'inputs'}}) {
	    if (defined $name) {
		next unless exists $_->{name};
		next if $name ne $_->{name};
	    }
	    next if $type && $type ne $_->{type};
	    next if --$no;
	    return $_;
	}
	return undef;
    }
}

sub fixup
{
    my $self = shift;
    for (@{$self->{'inputs'}}) {
	$_->fixup;
    }
}


=item $value = $form->value( $name )

=item $form->value( $name, $new_value )

The value() method can be used to get/set the value of some input.  If
no input has the indicated name, then this method will croak.

If multiple inputs have the same name, only the first one will be
affected.

The call:

    $form->value('foo')

is a short-hand for:

    $form->find_input('foo')->value;

=cut

sub value
{
    my $self = shift;
    my $key  = shift;
    my $input = $self->find_input($key);
    Carp::croak("No such field '$key'") unless $input;
    local $Carp::CarpLevel = 1;
    $input->value(@_);
}

=item @names = $form->param

=item @values = $form->param( $name )