package HTML::Form;
use strict;
use URI;
use Carp ();
use Encode ();
use HTML::Form::TextInput ();
use HTML::Form::IgnoreInput ();
use HTML::Form::ListInput ();
use HTML::Form::SubmitInput ();
use HTML::Form::ImageInput ();
use HTML::Form::FileInput ();
use HTML::Form::KeygenInput ();
our $VERSION = '6.12';
my %form_tags = map { $_ => 1 } qw(input textarea button select option);
my %type2class = (
text => "TextInput",
password => "TextInput",
hidden => "TextInput",
textarea => "TextInput",
"reset" => "IgnoreInput",
radio => "ListInput",
checkbox => "ListInput",
option => "ListInput",
button => "SubmitInput",
submit => "SubmitInput",
image => "ImageInput",
file => "FileInput",
keygen => "KeygenInput",
);
# The new HTML5 input types
%type2class = (
%type2class,
map { $_ => 'TextInput' } qw(
tel search url email
datetime date month week time datetime-local
number range color
)
);
# ABSTRACT: Class that represents an HTML form element
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 );
Carp::croak "Failed to create HTML::TokeParser object" unless $p;
my $base_uri = delete $opt{base};
my $charset = delete $opt{charset};
my $strict = delete $opt{strict};
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");
}
}
unless ( defined $charset ) {
if ( ref($html) and $html->can("content_charset") ) {
$charset = $html->content_charset;
}
unless ($charset) {
$charset = "UTF-8";
}
}
my @forms;
my $f; # current form
my %openselect; # index to the open instance of a select
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->accept_charset( $attr->{'accept-charset'} )
if $attr->{'accept-charset'};
$f->{default_charset} = $charset;
$f->{attr} = $attr;
$f->strict(1) if $strict;
%openselect = ();
push( @forms, $f );
my ( %labels, $current_label );
while ( my $t = $p->get_tag ) {
my ( $tag, $attr ) = @$t;
last if $tag eq "/form";
if ( $tag ne 'textarea' ) {
# 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, $verbose );
}
elsif ( $tag eq "button" ) {
my $type = delete $attr->{type} || "submit";
$f->push_input( $type, $attr, $verbose );
}
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, $verbose );
}
elsif ( $tag eq "select" ) {
# rename attributes reserved to come for the option tag
for ( "value", "value_name" ) {
$attr->{"select_$_"} = delete $attr->{$_}
if exists $attr->{$_};
}
# count this new select option separately
my $name = $attr->{name};
$name = "" unless defined $name;
$openselect{$name}++;
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};
$a{idx} = $openselect{$name};
$f->push_input( "option", \%a, $verbose );
}
else {
warn("Bad