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.11'; 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 here, so we # try to do the same. Actually the MSIE behaviour # appears really strange: and