Warn (print messages to STDERR) about any bad HTML form constructs found.
You can trap these with $SIG{__WARN__}.
=item C<< strict => $bool >>
Initialize any form objects with the given strict attribute.
=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);
die "Failed to create HTML::TokeParser object" unless $p;
my $base_uri = delete $opt{base};
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");
}
}
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->{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 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);
=2= |