~ubuntu-branches/ubuntu/utopic/libhtml-form-perl/utopic
» Revision
4
: .pc/fix-typos.patch/lib/HTML/Form.pm
« back to all changes in this revision
Viewing changes to .pc/fix-typos.patch/lib/HTML/Form.pm
- browse files at revision 4
- compare with another revision
- download diff
- download tarball
- view history from revision 4
- Committer: Package Import Robot
- Author(s): Angel Abad
- Date: 2012-02-21 17:57:59 UTC
- mfrom: (1.1.2)
- Revision ID: package-import@ubuntu.com-20120221175759-fhw2ervb39e2arkb
Tags: 6.02-1
* Imported Upstream version 6.02
* debian/copyright: Update debian/* section
* Add myself to Uploaders
* debian/patches/fix-typos.patch: Removed, applied upstream
* debian/copyright: Update debian/* section
* Add myself to Uploaders
* debian/patches/fix-typos.patch: Removed, applied upstream
- files removed:
- .pc
- .pc/fix-typos.patch
- .pc/fix-typos.patch/lib
- .pc/fix-typos.patch/lib/HTML
- debian/patches
- files modified:
- Changes
added
removed
.pc/fix-typos.patch/lib/HTML/Form.pm
1
package HTML::Form;
2
3
use strict;
4
use URI;
5
use Carp ();
6
use Encode ();
7
8
use vars qw($VERSION);
9
$VERSION = "6.01";
10
11
my %form_tags = map {$_ => 1} qw(input textarea button select option);
12
13
my %type2class = (
14
text => "TextInput",
15
password => "TextInput",
16
hidden => "TextInput",
17
textarea => "TextInput",
18
19
"reset" => "IgnoreInput",
20
21
radio => "ListInput",
22
checkbox => "ListInput",
23
option => "ListInput",
24
25
button => "SubmitInput",
26
submit => "SubmitInput",
27
image => "ImageInput",
28
file => "FileInput",
29
30
keygen => "KeygenInput",
31
);
32
33
=head1 NAME
34
35
HTML::Form - Class that represents an HTML form element
36
37
=head1 SYNOPSIS
38
39
use HTML::Form;
40
$form = HTML::Form->parse($html, $base_uri);
41
$form->value(query => "Perl");
42
43
use LWP::UserAgent;
44
$ua = LWP::UserAgent->new;
45
$response = $ua->request($form->click);
46
47
=head1 DESCRIPTION
48
49
Objects of the C<HTML::Form> class represents a single HTML
50
C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
51
sequence of inputs that usually have names, and which can take on
52
various values. The state of a form can be tweaked and it can then be
53
asked to provide C<HTTP::Request> objects that can be passed to the
54
request() method of C<LWP::UserAgent>.
55
56
The following methods are available:
57
58
=over 4
59
60
=item @forms = HTML::Form->parse( $html_document, $base_uri )
61
62
=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
63
64
=item @forms = HTML::Form->parse( $response, %opt )
65
66
The parse() class method will parse an HTML document and build up
67
C<HTML::Form> objects for each <form> element found. If called in scalar
68
context only returns the first <form>. Returns an empty list if there
69
are no forms to be found.
70
71
The required arguments is the HTML document to parse ($html_document) and the
72
URI used to retrieve the document ($base_uri). The base URI is needed to resolve
73
relative action URIs. The provided HTML document should be a Unicode string
74
(or US-ASCII).
75
76
By default HTML::Form assumes that the original document was UTF-8 encoded and
77
thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
78
The charset assumed can be overridden by providing the C<charset> option to
79
parse(). It's a good idea to be explict about this parameter as well, thus
80
the recommended simplest invocation becomes:
81
82
my @forms = HTML::Form->parse(
83
Encode::decode($encoding, $html_document_bytes),
84
base => $base_uri,
85
charset => $encoding,
86
);
87
88
If the document was retrieved with LWP then the response object provide methods
89
to obtain a proper value for C<base> and C<charset>:
90
91
my $ua = LWP::UserAgent->new;
92
my $response = $ua->get("http://www.example.com/form.html");
93
my @forms = HTML::Form->parse($response->decoded_content,
94
base => $response->base,
95
charset => $response->content_charset,
96
);
97
98
In fact, the parse() method can parse from an C<HTTP::Response> object
99
directly, so the example above can be more conveniently written as:
100
101
my $ua = LWP::UserAgent->new;
102
my $response = $ua->get("http://www.example.com/form.html");
103
my @forms = HTML::Form->parse($response);
104
105
Note that any object that implements a decoded_content(), base() and
106
content_charset() method with similar behaviour as C<HTTP::Response> will do.
107
108
Additional options might be passed in to control how the parse method
109
behaves. The following are all the options currently recognized:
110
111
=over
112
113
=item C<< base => $uri >>
114
115
This is the URI used to retrive the original document. This option is not optional ;-)
116
117
=item C<< charset => $str >>
118
119
Specify what charset the original document was encoded in. This is used as
120
the default for accept_charset. If not provided this defaults to "UTF-8".
121
122
=item C<< verbose => $bool >>
123
124
Warn (print messages to STDERR) about any bad HTML form constructs found.
125
You can trap these with $SIG{__WARN__}.
126
127
=item C<< strict => $bool >>
128
129
Initialize any form objects with the given strict attribute.
130
131
=back
132
133
=cut
134
135
sub parse
136
{
137
my $class = shift;
138
my $html = shift;
139
unshift(@_, "base") if @_ == 1;
140
my %opt = @_;
141
142
require HTML::TokeParser;
143
my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
144
die "Failed to create HTML::TokeParser object" unless $p;
145
146
my $base_uri = delete $opt{base};
147
my $charset = delete $opt{charset};
148
my $strict = delete $opt{strict};
149
my $verbose = delete $opt{verbose};
150
151
if ($^W) {
152
Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
153
}
154
155
unless (defined $base_uri) {
156
if (ref($html)) {
157
$base_uri = $html->base;
158
}
159
else {
160
Carp::croak("HTML::Form::parse: No \$base_uri provided");
161
}
162
}
163
unless (defined $charset) {
164
if (ref($html) and $html->can("content_charset")) {
165
$charset = $html->content_charset;
166
}
167
unless ($charset) {
168
$charset = "UTF-8";
169
}
170
}
171
172
my @forms;
173
my $f; # current form
174
175
my %openselect; # index to the open instance of a select
176
177
while (my $t = $p->get_tag) {
178
my($tag,$attr) = @$t;
179
if ($tag eq "form") {
180
my $action = delete $attr->{'action'};
181
$action = "" unless defined $action;
182
$action = URI->new_abs($action, $base_uri);
183
$f = $class->new($attr->{'method'},
184
$action,
185
$attr->{'enctype'});
186
$f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
187
$f->{default_charset} = $charset;
188
$f->{attr} = $attr;
189
$f->strict(1) if $strict;
190
%openselect = ();
191
push(@forms, $f);
192
my(%labels, $current_label);
193
while (my $t = $p->get_tag) {
194
my($tag, $attr) = @$t;
195
last if $tag eq "/form";
196
197
if ($tag ne 'textarea') {
198
# if we are inside a label tag, then keep
199
# appending any text to the current label
200
if(defined $current_label) {
201
$current_label = join " ",
202
grep { defined and length }
203
$current_label,
204
$p->get_phrase;
205
}
206
}
207
208
if ($tag eq "input") {
209
$attr->{value_name} =
210
exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
211
defined $current_label ? $current_label :
212
$p->get_phrase;
213
}
214
215
if ($tag eq "label") {
216
$current_label = $p->get_phrase;
217
$labels{ $attr->{for} } = $current_label
218
if exists $attr->{for};
219
}
220
elsif ($tag eq "/label") {
221
$current_label = undef;
222
}
223
elsif ($tag eq "input") {
224
my $type = delete $attr->{type} || "text";
225
$f->push_input($type, $attr, $verbose);
226
}
227
elsif ($tag eq "button") {
228
my $type = delete $attr->{type} || "submit";
229
$f->push_input($type, $attr, $verbose);
230
}
231
elsif ($tag eq "textarea") {
232
$attr->{textarea_value} = $attr->{value}
233
if exists $attr->{value};
234
my $text = $p->get_text("/textarea");
235
$attr->{value} = $text;
236
$f->push_input("textarea", $attr, $verbose);
237
}
238
elsif ($tag eq "select") {
239
# rename attributes reserved to come for the option tag
240
for ("value", "value_name") {
241
$attr->{"select_$_"} = delete $attr->{$_}
242
if exists $attr->{$_};
243
}
244
# count this new select option separately
245
my $name = $attr->{name};
246
$name = "" unless defined $name;
247
$openselect{$name}++;
248
249
while ($t = $p->get_tag) {
250
my $tag = shift @$t;
251
last if $tag eq "/select";
252
next if $tag =~ m,/?optgroup,;
253
next if $tag eq "/option";
254
if ($tag eq "option") {
255
my %a = %{$t->[0]};
256
# rename keys so they don't clash with %attr
257
for (keys %a) {
258
next if $_ eq "value";
259
$a{"option_$_"} = delete $a{$_};
260
}
261
while (my($k,$v) = each %$attr) {
262
$a{$k} = $v;
263
}
264
$a{value_name} = $p->get_trimmed_text;
265
$a{value} = delete $a{value_name}
266
unless defined $a{value};
267
$a{idx} = $openselect{$name};
268
$f->push_input("option", \%a, $verbose);
269
}
270
else {
271
warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
272
if ($tag eq "/form" ||
273
$tag eq "input" ||
274
$tag eq "textarea" ||
275
$tag eq "select" ||
276
$tag eq "keygen")
277
{
278
# MSIE implictly terminate the <select> here, so we
279
# try to do the same. Actually the MSIE behaviour
280
# appears really strange: <input> and <textarea>
281
# do implictly close, but not <select>, <keygen> or
282
# </form>.
283
my $type = ($tag =~ s,^/,,) ? "E" : "S";
284
$p->unget_token([$type, $tag, @$t]);
285
last;
286
}
287
}
288
}
289
}
290
elsif ($tag eq "keygen") {
291
$f->push_input("keygen", $attr, $verbose);
292
}
293
}
294
}
295
elsif ($form_tags{$tag}) {
296
warn("<$tag> outside <form> in $base_uri\n") if $verbose;
297
}
298
}
299
for (@forms) {
300
$_->fixup;
301
}
302
303
wantarray ? @forms : $forms[0];
304
}
305
306
sub new {
307
my $class = shift;
308
my $self = bless {}, $class;
309
$self->{method} = uc(shift || "GET");
310
$self->{action} = shift || Carp::croak("No action defined");
311
$self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
312
$self->{accept_charset} = "UNKNOWN";
313
$self->{default_charset} = "UTF-8";
314
$self->{inputs} = [@_];
315
$self;
316
}
317
318
319
sub push_input
320
{
321
my($self, $type, $attr, $verbose) = @_;
322
$type = lc $type;
323
my $class = $type2class{$type};
324
unless ($class) {
325
Carp::carp("Unknown input type '$type'") if $verbose;
326
$class = "TextInput";
327
}
328
$class = "HTML::Form::$class";
329
my @extra;
330
push(@extra, readonly => 1) if $type eq "hidden";
331
push(@extra, strict => 1) if $self->{strict};
332
if ($type eq "file" && exists $attr->{value}) {
333
# it's not safe to trust the value set by the server
334
# the user always need to explictly set the names of files to upload
335
$attr->{orig_value} = delete $attr->{value};
336
}
337
delete $attr->{type}; # don't confuse the type argument
338
my $input = $class->new(type => $type, %$attr, @extra);
339
$input->add_to_form($self);
340
}
341
342
343
=item $method = $form->method
344
345
=item $form->method( $new_method )
346
347
This method is gets/sets the I<method> name used for the
348
C<HTTP::Request> generated. It is a string like "GET" or "POST".
349
350
=item $action = $form->action
351
352
=item $form->action( $new_action )
353
354
This method gets/sets the URI which we want to apply the request
355
I<method> to.
356
357
=item $enctype = $form->enctype
358
359
=item $form->enctype( $new_enctype )
360
361
This method gets/sets the encoding type for the form data. It is a
362
string like "application/x-www-form-urlencoded" or "multipart/form-data".
363
364
=item $accept = $form->accept_charset
365
366
=item $form->accept_charset( $new_accept )
367
368
This method gets/sets the list of charset encodings that the server processing
369
the form accepts. Current implementation supports only one-element lists.
370
Default value is "UNKNOWN" which we interpret as a request to use document
371
charset as specified by the 'charset' parameter of the parse() method.
372
373
=cut
374
375
BEGIN {
376
# Set up some accesor
377
for (qw(method action enctype accept_charset)) {
378
my $m = $_;
379
no strict 'refs';
380
*{$m} = sub {
381
my $self = shift;
382
my $old = $self->{$m};
383
$self->{$m} = shift if @_;
384
$old;
385
};
386
}
387
*uri = \&action; # alias
388
}
389
390
=item $value = $form->attr( $name )
391
392
=item $form->attr( $name, $new_value )
393
394
This method give access to the original HTML attributes of the <form> tag.
395
The $name should always be passed in lower case.
396
397
Example:
398
399
@f = HTML::Form->parse( $html, $foo );
400
@f = grep $_->attr("id") eq "foo", @f;
401
die "No form named 'foo' found" unless @f;
402
$foo = shift @f;
403
404
=cut
405
406
sub attr {
407
my $self = shift;
408
my $name = shift;
409
return undef unless defined $name;
410
411
my $old = $self->{attr}{$name};
412
$self->{attr}{$name} = shift if @_;
413
return $old;
414
}
415
416
=item $bool = $form->strict
417
418
=item $form->strict( $bool )
419
420
Gets/sets the strict attribute of a form. If the strict is turned on
421
the methods that change values of the form will croak if you try to
422
set illegal values or modify readonly fields. The default is not to be strict.
423
424
=cut
425
426
sub strict {
427
my $self = shift;
428
my $old = $self->{strict};
429
if (@_) {
430
$self->{strict} = shift;
431
for my $input (@{$self->{inputs}}) {
432
$input->strict($self->{strict});
433
}
434
}
435
return $old;
436
}
437
438
439
=item @inputs = $form->inputs
440
441
This method returns the list of inputs in the form. If called in
442
scalar context it returns the number of inputs contained in the form.
443
See L</INPUTS> for what methods are available for the input objects
444
returned.
445
446
=cut
447
448
sub inputs
449
{
450
my $self = shift;
451
@{$self->{'inputs'}};
452
}
453
454
455
=item $input = $form->find_input( $selector )
456
457
=item $input = $form->find_input( $selector, $type )
458
459
=item $input = $form->find_input( $selector, $type, $index )
460
461
This method is used to locate specific inputs within the form. All
462
inputs that match the arguments given are returned. In scalar context
463
only the first is returned, or C<undef> if none match.
464
465
If $selector is specified, then the input's name, id, class attribute must
466
match. A selector prefixed with '#' must match the id attribute of the input.
467
A selector prefixed with '.' matches the class attribute. A selector prefixed
468
with '^' or with no prefix matches the name attribute.
469
470
If $type is specified, then the input must have the specified type.
471
The following type names are used: "text", "password", "hidden",
472
"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
473
474
The $index is the sequence number of the input matched where 1 is the
475
first. If combined with $name and/or $type then it select the I<n>th
476
input with the given name and/or type.
477
478
=cut
479
480
sub find_input
481
{
482
my($self, $name, $type, $no) = @_;
483
if (wantarray) {
484
my @res;
485
my $c;
486
for (@{$self->{'inputs'}}) {
487
next if defined($name) && !$_->selected($name);
488
next if $type && $type ne $_->{type};
489
$c++;
490
next if $no && $no != $c;
491
push(@res, $_);
492
}
493
return @res;
494
495
}
496
else {
497
$no ||= 1;
498
for (@{$self->{'inputs'}}) {
499
next if defined($name) && !$_->selected($name);
500
next if $type && $type ne $_->{type};
501
next if --$no;
502
return $_;
503
}
504
return undef;
505
}
506
}
507
508
sub fixup
509
{
510
my $self = shift;
511
for (@{$self->{'inputs'}}) {
512
$_->fixup;
513
}
514
}
515
516
517
=item $value = $form->value( $selector )
518
519
=item $form->value( $selector, $new_value )
520
521
The value() method can be used to get/set the value of some input. If
522
strict is enabled and no input has the indicated name, then this method will croak.
523
524
If multiple inputs have the same name, only the first one will be
525
affected.
526
527
The call:
528
529
$form->value('foo')
530
531
is basically a short-hand for:
532
533
$form->find_input('foo')->value;
534
535
=cut
536
537
sub value
538
{
539
my $self = shift;
540
my $key = shift;
541
my $input = $self->find_input($key);
542
unless ($input) {
543
Carp::croak("No such field '$key'") if $self->{strict};
544
return undef unless @_;
545
$input = $self->push_input("text", { name => $key, value => "" });
546
}
547
local $Carp::CarpLevel = 1;
548
$input->value(@_);
549
}
550
551
=item @names = $form->param
552
553
=item @values = $form->param( $name )
554
555
=item $form->param( $name, $value, ... )
556
557
=item $form->param( $name, \@values )
558
559
Alternative interface to examining and setting the values of the form.
560
561
If called without arguments then it returns the names of all the
562
inputs in the form. The names will not repeat even if multiple inputs
563
have the same name. In scalar context the number of different names
564
is returned.
565
566
If called with a single argument then it returns the value or values
567
of inputs with the given name. If called in scalar context only the
568
first value is returned. If no input exists with the given name, then
569
C<undef> is returned.
570
571
If called with 2 or more arguments then it will set values of the
572
named inputs. This form will croak if no inputs have the given name
573
or if any of the values provided does not fit. Values can also be
574
provided as a reference to an array. This form will allow unsetting
575
all values with the given name as well.
576
577
This interface resembles that of the param() function of the CGI
578
module.
579
580
=cut
581
582
sub param {
583
my $self = shift;
584
if (@_) {
585
my $name = shift;
586
my @inputs;
587
for ($self->inputs) {
588
my $n = $_->name;
589
next if !defined($n) || $n ne $name;
590
push(@inputs, $_);
591
}
592
593
if (@_) {
594
# set
595
die "No '$name' parameter exists" unless @inputs;
596
my @v = @_;
597
@v = @{$v[0]} if @v == 1 && ref($v[0]);
598
while (@v) {
599
my $v = shift @v;
600
my $err;
601
for my $i (0 .. @inputs-1) {
602
eval {
603
$inputs[$i]->value($v);
604
};
605
unless ($@) {
606
undef($err);
607
splice(@inputs, $i, 1);
608
last;
609
}
610
$err ||= $@;
611
}
612
die $err if $err;
613
}
614
615
# the rest of the input should be cleared
616
for (@inputs) {
617
$_->value(undef);
618
}
619
}
620
else {
621
# get
622
my @v;
623
for (@inputs) {
624
if (defined(my $v = $_->value)) {
625
push(@v, $v);
626
}
627
}
628
return wantarray ? @v : $v[0];
629
}
630
}
631
else {
632
# list parameter names
633
my @n;
634
my %seen;
635
for ($self->inputs) {
636
my $n = $_->name;
637
next if !defined($n) || $seen{$n}++;
638
push(@n, $n);
639
}
640
return @n;
641
}
642
}
643
644
645
=item $form->try_others( \&callback )
646
647
This method will iterate over all permutations of unvisited enumerated
648
values (<select>, <radio>, <checkbox>) and invoke the callback for
649
each. The callback is passed the $form as argument. The return value
650
from the callback is ignored and the try_others() method itself does
651
not return anything.
652
653
=cut
654
655
sub try_others
656
{
657
my($self, $cb) = @_;
658
my @try;
659
for (@{$self->{'inputs'}}) {
660
my @not_tried_yet = $_->other_possible_values;
661
next unless @not_tried_yet;
662
push(@try, [\@not_tried_yet, $_]);
663
}
664
return unless @try;
665
$self->_try($cb, \@try, 0);
666
}
667
668
sub _try
669
{
670
my($self, $cb, $try, $i) = @_;
671
for (@{$try->[$i][0]}) {
672
$try->[$i][1]->value($_);
673
&$cb($self);
674
$self->_try($cb, $try, $i+1) if $i+1 < @$try;
675
}
676
}
677
678
679
=item $request = $form->make_request
680
681
Will return an C<HTTP::Request> object that reflects the current setting
682
of the form. You might want to use the click() method instead.
683
684
=cut
685
686
sub make_request
687
{
688
my $self = shift;
689
my $method = uc $self->{'method'};
690
my $uri = $self->{'action'};
691
my $enctype = $self->{'enctype'};
692
my @form = $self->form;
693
694
my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
695
foreach my $fi (@form) {
696
$fi = Encode::encode($charset, $fi) unless ref($fi);
697
}
698
699
if ($method eq "GET") {
700
require HTTP::Request;
701
$uri = URI->new($uri, "http");
702
$uri->query_form(@form);
703
return HTTP::Request->new(GET => $uri);
704
}
705
elsif ($method eq "POST") {
706
require HTTP::Request::Common;
707
return HTTP::Request::Common::POST($uri, \@form,
708
Content_Type => $enctype);
709
}
710
else {
711
Carp::croak("Unknown method '$method'");
712
}
713
}
714
715
716
=item $request = $form->click
717
718
=item $request = $form->click( $selector )
719
720
=item $request = $form->click( $x, $y )
721
722
=item $request = $form->click( $selector, $x, $y )
723
724
Will "click" on the first clickable input (which will be of type
725
C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
726
object that can then be passed to C<LWP::UserAgent> if you want to
727
obtain the server response.
728
729
If a $selector is specified, we will click on the first clickable input
730
matching the selector, and the method will croak if no matching clickable
731
input is found. If $selector is I<not> specified, then it
732
is ok if the form contains no clickable inputs. In this case the
733
click() method returns the same request as the make_request() method
734
would do. See description of the find_input() method above for how
735
the $selector is specified.
736
737
If there are multiple clickable inputs with the same name, then there
738
is no way to get the click() method of the C<HTML::Form> to click on
739
any but the first. If you need this you would have to locate the
740
input with find_input() and invoke the click() method on the given
741
input yourself.
742
743
A click coordinate pair can also be provided, but this only makes a
744
difference if you clicked on an image. The default coordinate is
745
(1,1). The upper-left corner of the image is (0,0), but some badly
746
coded CGI scripts are known to not recognize this. Therefore (1,1) was
747
selected as a safer default.
748
749
=cut
750
751
sub click
752
{
753
my $self = shift;
754
my $name;
755
$name = shift if (@_ % 2) == 1; # odd number of arguments
756
757
# try to find first submit button to activate
758
for (@{$self->{'inputs'}}) {
759
next unless $_->can("click");
760
next if $name && !$_->selected($name);
761
next if $_->disabled;
762
return $_->click($self, @_);
763
}
764
Carp::croak("No clickable input with name $name") if $name;
765
$self->make_request;
766
}
767
768
769
=item @kw = $form->form
770
771
Returns the current setting as a sequence of key/value pairs. Note
772
that keys might be repeated, which means that some values might be
773
lost if the return values are assigned to a hash.
774
775
In scalar context this method returns the number of key/value pairs
776
generated.
777
778
=cut
779
780
sub form
781
{
782
my $self = shift;
783
map { $_->form_name_value($self) } @{$self->{'inputs'}};
784
}
785
786
787
=item $form->dump
788
789
Returns a textual representation of current state of the form. Mainly
790
useful for debugging. If called in void context, then the dump is
791
printed on STDERR.
792
793
=cut
794
795
sub dump
796
{
797
my $self = shift;
798
my $method = $self->{'method'};
799
my $uri = $self->{'action'};
800
my $enctype = $self->{'enctype'};
801
my $dump = "$method $uri";
802
$dump .= " ($enctype)"
803
if $enctype ne "application/x-www-form-urlencoded";
804
$dump .= " [$self->{attr}{name}]"
805
if exists $self->{attr}{name};
806
$dump .= "\n";
807
for ($self->inputs) {
808
$dump .= " " . $_->dump . "\n";
809
}
810
print STDERR $dump unless defined wantarray;
811
$dump;
812
}
813
814
815
#---------------------------------------------------
816
package HTML::Form::Input;
817
818
=back
819
820
=head1 INPUTS
821
822
An C<HTML::Form> objects contains a sequence of I<inputs>. References to
823
the inputs can be obtained with the $form->inputs or $form->find_input
824
methods.
825
826
Note that there is I<not> a one-to-one correspondence between input
827
I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
828
input object basically represents a name/value pair, so when multiple
829
HTML elements contribute to the same name/value pair in the submitted
830
form they are combined.
831
832
The input elements that are mapped one-to-one are "text", "textarea",
833
"password", "hidden", "file", "image", "submit" and "checkbox". For
834
the "radio" and "option" inputs the story is not as simple: All
835
E<lt>input type="radio"E<gt> elements with the same name will
836
contribute to the same input radio object. The number of radio input
837
objects will be the same as the number of distinct names used for the
838
E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
839
without the C<multiple> attribute there will be one input object of
840
type of "option". For a E<lt>select multipleE<gt> element there will
841
be one input object for each contained E<lt>optionE<gt> element. Each
842
one of these option objects will have the same name.
843
844
The following methods are available for the I<input> objects:
845
846
=over 4
847
848
=cut
849
850
sub new
851
{
852
my $class = shift;
853
my $self = bless {@_}, $class;
854
$self;
855
}
856
857
sub add_to_form
858
{
859
my($self, $form) = @_;
860
push(@{$form->{'inputs'}}, $self);
861
$self;
862
}
863
864
sub strict {
865
my $self = shift;
866
my $old = $self->{strict};
867
if (@_) {
868
$self->{strict} = shift;
869
}
870
$old;
871
}
872
873
sub fixup {}
874
875
876
=item $input->type
877
878
Returns the type of this input. The type is one of the following
879
strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
880
"radio", "checkbox" or "option".
881
882
=cut
883
884
sub type
885
{
886
shift->{type};
887
}
888
889
=item $name = $input->name
890
891
=item $input->name( $new_name )
892
893
This method can be used to get/set the current name of the input.
894
895
=item $input->id
896
897
=item $input->class
898
899
These methods can be used to get/set the current id or class attribute for the input.
900
901
=item $input->selected( $selector )
902
903
Returns TRUE if the given selector matched the input. See the description of
904
the find_input() method above for a description of the selector syntax.
905
906
=item $value = $input->value
907
908
=item $input->value( $new_value )
909
910
This method can be used to get/set the current value of an
911
input.
912
913
If strict is enabled and the input only can take an enumerated list of values,
914
then it is an error to try to set it to something else and the method will
915
croak if you try.
916
917
You will also be able to set the value of read-only inputs, but a
918
warning will be generated if running under C<perl -w>.
919
920
=cut
921
922
sub name
923
{
924
my $self = shift;
925
my $old = $self->{name};
926
$self->{name} = shift if @_;
927
$old;
928
}
929
930
sub id
931
{
932
my $self = shift;
933
my $old = $self->{id};
934
$self->{id} = shift if @_;
935
$old;
936
}
937
938
sub class
939
{
940
my $self = shift;
941
my $old = $self->{class};
942
$self->{class} = shift if @_;
943
$old;
944
}
945
946
sub selected {
947
my($self, $sel) = @_;
948
return undef unless defined $sel;
949
my $attr =
950
$sel =~ s/^\^// ? "name" :
951
$sel =~ s/^#// ? "id" :
952
$sel =~ s/^\.// ? "class" :
953
"name";
954
return 0 unless defined $self->{$attr};
955
return $self->{$attr} eq $sel;
956
}
957
958
sub value
959
{
960
my $self = shift;
961
my $old = $self->{value};
962
$self->{value} = shift if @_;
963
$old;
964
}
965
966
=item $input->possible_values
967
968
Returns a list of all values that an input can take. For inputs that
969
do not have discrete values, this returns an empty list.
970
971
=cut
972
973
sub possible_values
974
{
975
return;
976
}
977
978
=item $input->other_possible_values
979
980
Returns a list of all values not tried yet.
981
982
=cut
983
984
sub other_possible_values
985
{
986
return;
987
}
988
989
=item $input->value_names
990
991
For some inputs the values can have names that are different from the
992
values themselves. The number of names returned by this method will
993
match the number of values reported by $input->possible_values.
994
995
When setting values using the value() method it is also possible to
996
use the value names in place of the value itself.
997
998
=cut
999
1000
sub value_names {
1001
return
1002
}
1003
1004
=item $bool = $input->readonly
1005
1006
=item $input->readonly( $bool )
1007
1008
This method is used to get/set the value of the readonly attribute.
1009
You are allowed to modify the value of readonly inputs, but setting
1010
the value will generate some noise when warnings are enabled. Hidden
1011
fields always start out readonly.
1012
1013
=cut
1014
1015
sub readonly {
1016
my $self = shift;
1017
my $old = $self->{readonly};
1018
$self->{readonly} = shift if @_;
1019
$old;
1020
}
1021
1022
=item $bool = $input->disabled
1023
1024
=item $input->disabled( $bool )
1025
1026
This method is used to get/set the value of the disabled attribute.
1027
Disabled inputs do not contribute any key/value pairs for the form
1028
value.
1029
1030
=cut
1031
1032
sub disabled {
1033
my $self = shift;
1034
my $old = $self->{disabled};
1035
$self->{disabled} = shift if @_;
1036
$old;
1037
}
1038
1039
=item $input->form_name_value
1040
1041
Returns a (possible empty) list of key/value pairs that should be
1042
incorporated in the form value from this input.
1043
1044
=cut
1045
1046
sub form_name_value
1047
{
1048
my $self = shift;
1049
my $name = $self->{'name'};
1050
return unless defined $name;
1051
return if $self->disabled;
1052
my $value = $self->value;
1053
return unless defined $value;
1054
return ($name => $value);
1055
}
1056
1057
sub dump
1058
{
1059
my $self = shift;
1060
my $name = $self->name;
1061
$name = "<NONAME>" unless defined $name;
1062
my $value = $self->value;
1063
$value = "<UNDEF>" unless defined $value;
1064
my $dump = "$name=$value";
1065
1066
my $type = $self->type;
1067
1068
$type .= " disabled" if $self->disabled;
1069
$type .= " readonly" if $self->readonly;
1070
return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
1071
1072
my @menu;
1073
my $i = 0;
1074
for (@{$self->{menu}}) {
1075
my $opt = $_->{value};
1076
$opt = "<UNDEF>" unless defined $opt;
1077
$opt .= "/$_->{name}"
1078
if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
1079
substr($opt,0,0) = "-" if $_->{disabled};
1080
if (exists $self->{current} && $self->{current} == $i) {
1081
substr($opt,0,0) = "!" unless $_->{seen};
1082
substr($opt,0,0) = "*";
1083
}
1084
else {
1085
substr($opt,0,0) = ":" if $_->{seen};
1086
}
1087
push(@menu, $opt);
1088
$i++;
1089
}
1090
1091
return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
1092
}
1093
1094
1095
#---------------------------------------------------
1096
package HTML::Form::TextInput;
1097
@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
1098
1099
#input/text
1100
#input/password
1101
#input/hidden
1102
#textarea
1103
1104
sub value
1105
{
1106
my $self = shift;
1107
my $old = $self->{value};
1108
$old = "" unless defined $old;
1109
if (@_) {
1110
Carp::croak("Input '$self->{name}' is readonly")
1111
if $self->{strict} && $self->{readonly};
1112
my $new = shift;
1113
my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
1114
Carp::croak("Input '$self->{name}' has maxlength '$n'")
1115
if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
1116
$self->{value} = $new;
1117
}
1118
$old;
1119
}
1120
1121
#---------------------------------------------------
1122
package HTML::Form::IgnoreInput;
1123
@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
1124
1125
#input/button
1126
#input/reset
1127
1128
sub value { return }
1129
1130
1131
#---------------------------------------------------
1132
package HTML::Form::ListInput;
1133
@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
1134
1135
#select/option (val1, val2, ....)
1136
#input/radio (undef, val1, val2,...)
1137
#input/checkbox (undef, value)
1138
#select-multiple/option (undef, value)
1139
1140
sub new
1141
{
1142
my $class = shift;
1143
my $self = $class->SUPER::new(@_);
1144
1145
my $value = delete $self->{value};
1146
my $value_name = delete $self->{value_name};
1147
my $type = $self->{type};
1148
1149
if ($type eq "checkbox") {
1150
$value = "on" unless defined $value;
1151
$self->{menu} = [
1152
{ value => undef, name => "off", },
1153
{ value => $value, name => $value_name, },
1154
];
1155
$self->{current} = (delete $self->{checked}) ? 1 : 0;
1156
;
1157
}
1158
else {
1159
$self->{option_disabled}++
1160
if $type eq "radio" && delete $self->{disabled};
1161
$self->{menu} = [
1162
{value => $value, name => $value_name},
1163
];
1164
my $checked = $self->{checked} || $self->{option_selected};
1165
delete $self->{checked};
1166
delete $self->{option_selected};
1167
if (exists $self->{multiple}) {
1168
unshift(@{$self->{menu}}, { value => undef, name => "off"});
1169
$self->{current} = $checked ? 1 : 0;
1170
}
1171
else {
1172
$self->{current} = 0 if $checked;
1173
}
1174
}
1175
$self;
1176
}
1177
1178
sub add_to_form
1179
{
1180
my($self, $form) = @_;
1181
my $type = $self->type;
1182
1183
return $self->SUPER::add_to_form($form)
1184
if $type eq "checkbox";
1185
1186
if ($type eq "option" && exists $self->{multiple}) {
1187
$self->{disabled} ||= delete $self->{option_disabled};
1188
return $self->SUPER::add_to_form($form);
1189
}
1190
1191
die "Assert" if @{$self->{menu}} != 1;
1192
my $m = $self->{menu}[0];
1193
$m->{disabled}++ if delete $self->{option_disabled};
1194
1195
my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
1196
return $self->SUPER::add_to_form($form) unless $prev;
1197
1198
# merge menues
1199
$prev->{current} = @{$prev->{menu}} if exists $self->{current};
1200
push(@{$prev->{menu}}, $m);
1201
}
1202
1203
sub fixup
1204
{
1205
my $self = shift;
1206
if ($self->{type} eq "option" && !(exists $self->{current})) {
1207
$self->{current} = 0;
1208
}
1209
$self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
1210
}
1211
1212
sub disabled
1213
{
1214
my $self = shift;
1215
my $type = $self->type;
1216
1217
my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
1218
if (@_) {
1219
my $v = shift;
1220
$self->{disabled} = $v;
1221
for (@{$self->{menu}}) {
1222
$_->{disabled} = $v;
1223
}
1224
}
1225
return $old;
1226
}
1227
1228
sub _menu_all_disabled {
1229
for (@_) {
1230
return 0 unless $_->{disabled};
1231
}
1232
return 1;
1233
}
1234
1235
sub value
1236
{
1237
my $self = shift;
1238
my $old;
1239
$old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
1240
$old = $self->{value} if exists $self->{value};
1241
if (@_) {
1242
my $i = 0;
1243
my $val = shift;
1244
my $cur;
1245
my $disabled;
1246
for (@{$self->{menu}}) {
1247
if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
1248
(!defined($val) && !defined($_->{value}))
1249
)
1250
{
1251
$cur = $i;
1252
$disabled = $_->{disabled};
1253
last unless $disabled;
1254
}
1255
$i++;
1256
}
1257
if (!(defined $cur) || $disabled) {
1258
if (defined $val) {
1259
# try to search among the alternative names as well
1260
my $i = 0;
1261
my $cur_ignorecase;
1262
my $lc_val = lc($val);
1263
for (@{$self->{menu}}) {
1264
if (defined $_->{name}) {
1265
if ($val eq $_->{name}) {
1266
$disabled = $_->{disabled};
1267
$cur = $i;
1268
last unless $disabled;
1269
}
1270
if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
1271
$cur_ignorecase = $i;
1272
}
1273
}
1274
$i++;
1275
}
1276
unless (defined $cur) {
1277
$cur = $cur_ignorecase;
1278
if (defined $cur) {
1279
$disabled = $self->{menu}[$cur]{disabled};
1280
}
1281
elsif ($self->{strict}) {
1282
my $n = $self->name;
1283
Carp::croak("Illegal value '$val' for field '$n'");
1284
}
1285
}
1286
}
1287
elsif ($self->{strict}) {
1288
my $n = $self->name;
1289
Carp::croak("The '$n' field can't be unchecked");
1290
}
1291
}
1292
if ($self->{strict} && $disabled) {
1293
my $n = $self->name;
1294
Carp::croak("The value '$val' has been disabled for field '$n'");
1295
}
1296
if (defined $cur) {
1297
$self->{current} = $cur;
1298
$self->{menu}[$cur]{seen}++;
1299
delete $self->{value};
1300
}
1301
else {
1302
$self->{value} = $val;
1303
delete $self->{current};
1304
}
1305
}
1306
$old;
1307
}
1308
1309
=item $input->check
1310
1311
Some input types represent toggles that can be turned on/off. This
1312
includes "checkbox" and "option" inputs. Calling this method turns
1313
this input on without having to know the value name. If the input is
1314
already on, then nothing happens.
1315
1316
This has the same effect as:
1317
1318
$input->value($input->possible_values[1]);
1319
1320
The input can be turned off with:
1321
1322
$input->value(undef);
1323
1324
=cut
1325
1326
sub check
1327
{
1328
my $self = shift;
1329
$self->{current} = 1;
1330
$self->{menu}[1]{seen}++;
1331
}
1332
1333
sub possible_values
1334
{
1335
my $self = shift;
1336
map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
1337
}
1338
1339
sub other_possible_values
1340
{
1341
my $self = shift;
1342
map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
1343
}
1344
1345
sub value_names {
1346
my $self = shift;
1347
my @names;
1348
for (@{$self->{menu}}) {
1349
my $n = $_->{name};
1350
$n = $_->{value} unless defined $n;
1351
push(@names, $n);
1352
}
1353
@names;
1354
}
1355
1356
1357
#---------------------------------------------------
1358
package HTML::Form::SubmitInput;
1359
@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
1360
1361
#input/image
1362
#input/submit
1363
1364
=item $input->click($form, $x, $y)
1365
1366
Some input types (currently "submit" buttons and "images") can be
1367
clicked to submit the form. The click() method returns the
1368
corresponding C<HTTP::Request> object.
1369
1370
=cut
1371
1372
sub click
1373
{
1374
my($self,$form,$x,$y) = @_;
1375
for ($x, $y) { $_ = 1 unless defined; }
1376
local($self->{clicked}) = [$x,$y];
1377
return $form->make_request;
1378
}
1379
1380
sub form_name_value
1381
{
1382
my $self = shift;
1383
return unless $self->{clicked};
1384
return $self->SUPER::form_name_value(@_);
1385
}
1386
1387
1388
#---------------------------------------------------
1389
package HTML::Form::ImageInput;
1390
@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
1391
1392
sub form_name_value
1393
{
1394
my $self = shift;
1395
my $clicked = $self->{clicked};
1396
return unless $clicked;
1397
return if $self->{disabled};
1398
my $name = $self->{name};
1399
$name = (defined($name) && length($name)) ? "$name." : "";
1400
return ("${name}x" => $clicked->[0],
1401
"${name}y" => $clicked->[1]
1402
);
1403
}
1404
1405
#---------------------------------------------------
1406
package HTML::Form::FileInput;
1407
@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
1408
1409
=back
1410
1411
If the input is of type C<file>, then it has these additional methods:
1412
1413
=over 4
1414
1415
=item $input->file
1416
1417
This is just an alias for the value() method. It sets the filename to
1418
read data from.
1419
1420
For security reasons this field will never be initialized from the parsing
1421
of a form. This prevents the server from triggering stealth uploads of
1422
arbitrary files from the client machine.
1423
1424
=cut
1425
1426
sub file {
1427
my $self = shift;
1428
$self->value(@_);
1429
}
1430
1431
=item $filename = $input->filename
1432
1433
=item $input->filename( $new_filename )
1434
1435
This get/sets the filename reported to the server during file upload.
1436
This attribute defaults to the value reported by the file() method.
1437
1438
=cut
1439
1440
sub filename {
1441
my $self = shift;
1442
my $old = $self->{filename};
1443
$self->{filename} = shift if @_;
1444
$old = $self->file unless defined $old;
1445
$old;
1446
}
1447
1448
=item $content = $input->content
1449
1450
=item $input->content( $new_content )
1451
1452
This get/sets the file content provided to the server during file
1453
upload. This method can be used if you do not want the content to be
1454
read from an actual file.
1455
1456
=cut
1457
1458
sub content {
1459
my $self = shift;
1460
my $old = $self->{content};
1461
$self->{content} = shift if @_;
1462
$old;
1463
}
1464
1465
=item @headers = $input->headers
1466
1467
=item input->headers($key => $value, .... )
1468
1469
This get/set additional header fields describing the file uploaded.
1470
This can for instance be used to set the C<Content-Type> reported for
1471
the file.
1472
1473
=cut
1474
1475
sub headers {
1476
my $self = shift;
1477
my $old = $self->{headers} || [];
1478
$self->{headers} = [@_] if @_;
1479
@$old;
1480
}
1481
1482
sub form_name_value {
1483
my($self, $form) = @_;
1484
return $self->SUPER::form_name_value($form)
1485
if $form->method ne "POST" ||
1486
$form->enctype ne "multipart/form-data";
1487
1488
my $name = $self->name;
1489
return unless defined $name;
1490
return if $self->{disabled};
1491
1492
my $file = $self->file;
1493
my $filename = $self->filename;
1494
my @headers = $self->headers;
1495
my $content = $self->content;
1496
if (defined $content) {
1497
$filename = $file unless defined $filename;
1498
$file = undef;
1499
unshift(@headers, "Content" => $content);
1500
}
1501
elsif (!defined($file) || length($file) == 0) {
1502
return;
1503
}
1504
1505
# legacy (this used to be the way to do it)
1506
if (ref($file) eq "ARRAY") {
1507
my $f = shift @$file;
1508
my $fn = shift @$file;
1509
push(@headers, @$file);
1510
$file = $f;
1511
$filename = $fn unless defined $filename;
1512
}
1513
1514
return ($name => [$file, $filename, @headers]);
1515
}
1516
1517
package HTML::Form::KeygenInput;
1518
@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
1519
1520
sub challenge {
1521
my $self = shift;
1522
return $self->{challenge};
1523
}
1524
1525
sub keytype {
1526
my $self = shift;
1527
return lc($self->{keytype} || 'rsa');
1528
}
1529
1530
1;
1531
1532
__END__
1533
1534
=back
1535
1536
=head1 SEE ALSO
1537
1538
L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
1539
1540
=head1 COPYRIGHT
1541
1542
Copyright 1998-2008 Gisle Aas.
1543
1544
This library is free software; you can redistribute it and/or
1545
modify it under the same terms as Perl itself.
1546
1547
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1