form.pm

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

    my @menu;
    my $i = 0;
    for (@{$self->{menu}}) {
	my $opt = $_->{value};
	$opt = "<UNDEF>" unless defined $opt;
	$opt .= "/$_->{name}"
	    if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
	substr($opt,0,0) = "-" if $_->{disabled};
	if (exists $self->{current} && $self->{current} == $i) {
	    substr($opt,0,0) = "!" unless $_->{seen};
	    substr($opt,0,0) = "*";
	}
	else {
	    substr($opt,0,0) = ":" if $_->{seen};
	}
	push(@menu, $opt);
	$i++;
    }

    return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
}


#---------------------------------------------------
package HTML::Form::TextInput;
@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);

#input/text
#input/password
#input/hidden
#textarea

sub value
{
    my $self = shift;
    my $old = $self->{value};
    $old = "" unless defined $old;
    if (@_) {
        Carp::carp("Input '$self->{name}' is readonly")
	    if $^W && $self->{readonly};
	$self->{value} = shift;
    }
    $old;
}

#---------------------------------------------------
package HTML::Form::IgnoreInput;
@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);

#input/button
#input/reset

sub value { return }


#---------------------------------------------------
package HTML::Form::ListInput;
@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);

#select/option   (val1, val2, ....)
#input/radio     (undef, val1, val2,...)
#input/checkbox  (undef, value)
#select-multiple/option (undef, value)

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new(@_);

    my $value = delete $self->{value};
    my $value_name = delete $self->{value_name};
    my $type = $self->{type};

    if ($type eq "checkbox") {
	$value = "on" unless defined $value;
	$self->{menu} = [
	    { value => undef, name => "off", },
            { value => $value, name => $value_name, },
        ];
	$self->{current} = (delete $self->{checked}) ? 1 : 0;
	;
    }
    else {
	$self->{option_disabled}++
	    if $type eq "radio" && delete $self->{disabled};
	$self->{menu} = [
            {value => $value, name => $value_name},
        ];
	my $checked = $self->{checked} || $self->{option_selected};
	delete $self->{checked};
	delete $self->{option_selected};
	if (exists $self->{multiple}) {
	    unshift(@{$self->{menu}}, { value => undef, name => "off"});
	    $self->{current} = $checked ? 1 : 0;
	}
	else {
	    $self->{current} = 0 if $checked;
	}
    }
    $self;
}

sub add_to_form
{
    my($self, $form) = @_;
    my $type = $self->type;

    return $self->SUPER::add_to_form($form)
	if $type eq "checkbox";

    if ($type eq "option" && exists $self->{multiple}) {
	$self->{disabled} ||= delete $self->{option_disabled};
	return $self->SUPER::add_to_form($form);
    }

    die "Assert" if @{$self->{menu}} != 1;
    my $m = $self->{menu}[0];
    $m->{disabled}++ if delete $self->{option_disabled};

    my $prev = $form->find_input($self->{name}, $self->{type});
    return $self->SUPER::add_to_form($form) unless $prev;

    # merge menues
    $prev->{current} = @{$prev->{menu}} if exists $self->{current};
    push(@{$prev->{menu}}, $m);
}

sub fixup
{
    my $self = shift;
    if ($self->{type} eq "option" && !(exists $self->{current})) {
	$self->{current} = 0;
    }
    $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
}

sub disabled
{
    my $self = shift;
    my $type = $self->type;

    my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
    if (@_) {
	my $v = shift;
	$self->{disabled} = $v;
        for (@{$self->{menu}}) {
            $_->{disabled} = $v;
        }
    }
    return $old;
}

sub _menu_all_disabled {
    for (@_) {
	return 0 unless $_->{disabled};
    }
    return 1;
}

sub value
{
    my $self = shift;
    my $old;
    $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
    if (@_) {
	my $i = 0;
	my $val = shift;
	my $cur;
	my $disabled;
	for (@{$self->{menu}}) {
	    if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
		(!defined($val) && !defined($_->{value}))
	       )
	    {
		$cur = $i;
		$disabled = $_->{disabled};
		last unless $disabled;
	    }
	    $i++;
	}
	if (!(defined $cur) || $disabled) {
	    if (defined $val) {
		# try to search among the alternative names as well
		my $i = 0;
		my $cur_ignorecase;
		my $lc_val = lc($val);
		for (@{$self->{menu}}) {
		    if (defined $_->{name}) {
			if ($val eq $_->{name}) {
			    $disabled = $_->{disabled};
			    $cur = $i;
			    last unless $disabled;
			}
			if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
			    $cur_ignorecase = $i;
			}
		    }
		    $i++;
		}
		unless (defined $cur) {
		    $cur = $cur_ignorecase;
		    if (defined $cur) {
			$disabled = $self->{menu}[$cur]{disabled};
		    }
		    else {
			my $n = $self->name;
		        Carp::croak("Illegal value '$val' for field '$n'");
		    }
		}
	    }
	    else {
		my $n = $self->name;
	        Carp::croak("The '$n' field can't be unchecked");
	    }
	}
	if ($disabled) {
	    my $n = $self->name;
	    Carp::croak("The value '$val' has been disabled for field '$n'");
	}
	$self->{current} = $cur;
	$self->{menu}[$cur]{seen}++;
    }
    $old;
}

=item $input->check

Some input types represent toggles that can be turned on/off.  This
includes "checkbox" and "option" inputs.  Calling this method turns
this input on without having to know the value name.  If the input is
already on, then nothing happens.

This has the same effect as:

    $input->value($input->possible_values[1]);

The input can be turned off with:

    $input->value(undef);

=cut

sub check
{
    my $self = shift;
    $self->{current} = 1;
    $self->{menu}[1]{seen}++;
}

sub possible_values
{
    my $self = shift;
    map $_->{value}, @{$self->{menu}};
}

sub other_possible_values
{
    my $self = shift;
    map $_->{value}, grep !$_->{seen}, @{$self->{menu}};
}

sub value_names {
    my $self = shift;
    my @names;
    for (@{$self->{menu}}) {
	my $n = $_->{name};
	$n = $_->{value} unless defined $n;
	push(@names, $n);
    }
    @names;
}


#---------------------------------------------------
package HTML::Form::SubmitInput;
@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);

#input/image
#input/submit

=item $input->click($form, $x, $y)

Some input types (currently "submit" buttons and "images") can be
clicked to submit the form.  The click() method returns the
corresponding C<HTTP::Request> object.

=cut

sub click
{
    my($self,$form,$x,$y) = @_;
    for ($x, $y) { $_ = 1 unless defined; }
    local($self->{clicked}) = [$x,$y];
    return $form->make_request;
}

sub form_name_value
{
    my $self = shift;
    return unless $self->{clicked};
    return $self->SUPER::form_name_value(@_);
}


#---------------------------------------------------
package HTML::Form::ImageInput;
@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);

sub form_name_value
{
    my $self = shift;
    my $clicked = $self->{clicked};
    return unless $clicked;
    return if $self->{disabled};
    my $name = $self->{name};
    $name = (defined($name) && length($name)) ? "$name." : "";
    return ("${name}x" => $clicked->[0],
	    "${name}y" => $clicked->[1]
	   );
}

#---------------------------------------------------
package HTML::Form::FileInput;
@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);

=back

If the input is of type C<file>, then it has these additional methods:

=over 4

=item $input->file

This is just an alias for the value() method.  It sets the filename to
read data from.

=cut

sub file {
    my $self = shift;
    $self->value(@_);
}

=item $filename = $input->filename

=item $input->filename( $new_filename )

This get/sets the filename reported to the server during file upload.
This attribute defaults to the value reported by the file() method.

=cut

sub filename {
    my $self = shift;
    my $old = $self->{filename};
    $self->{filename} = shift if @_;
    $old = $self->file unless defined $old;
    $old;
}

=item $content = $input->content

=item $input->content( $new_content )

This get/sets the file content provided to the server during file
upload.  This method can be used if you do not want the content to be
read from an actual file.

=cut

sub content {
    my $self = shift;
    my $old = $self->{content};
    $self->{content} = shift if @_;
    $old;
}

=item @headers = $input->headers

=item input->headers($key => $value, .... )

This get/set additional header fields describing the file uploaded.
This can for instance be used to set the C<Content-Type> reported for
the file.

=cut

sub headers {
    my $self = shift;
    my $old = $self->{headers} || [];
    $self->{headers} = [@_] if @_;
    @$old;
}

sub form_name_value {
    my($self, $form) = @_;
    return $self->SUPER::form_name_value($form)
	if $form->method ne "POST" ||
	   $form->enctype ne "multipart/form-data";

    my $name = $self->name;
    return unless defined $name;
    return if $self->{disabled};

    my $file = $self->file;
    my $filename = $self->filename;
    my @headers = $self->headers;
    my $content = $self->content;
    if (defined $content) {
	$filename = $file unless defined $filename;
	$file = undef;
	unshift(@headers, "Content" => $content);
    }
    elsif (!defined($file) || length($file) == 0) {
	return;
    }

    # legacy (this used to be the way to do it)
    if (ref($file) eq "ARRAY") {
	my $f = shift @$file;
	my $fn = shift @$file;
	push(@headers, @$file);
	$file = $f;
	$filename = $fn unless defined $filename;
    }

    return ($name => [$file, $filename, @headers]);
}

package HTML::Form::KeygenInput;
@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);

sub challenge {
    my $self = shift;
    return $self->{challenge};
}

sub keytype {
    my $self = shift;
    return lc($self->{keytype} || 'rsa');
}

1;

__END__

=back

=head1 SEE ALSO

L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>

=head1 COPYRIGHT

Copyright 1998-2005 Gisle Aas.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut