« back to all changes in this revision
Viewing changes to lib/HTML/Form.pm
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Michael Alan Dorman
- Date: 2004-06-18 16:11:57 UTC
- mfrom: (1.1.1 upstream)
- Revision ID: james.westby@ubuntu.com-20040618161157-6t4bfw7luro4fi9v
Tags: 5.800-1
* New upstream version. (closes: bug#254742)
* Fix problem of dangling symlinks---was really a result of the
Makefile.PL changing up on us (closes: bug#252638)
* Fix problem of dangling symlinks---was really a result of the
Makefile.PL changing up on us (closes: bug#252638)
added
removed
lib/HTML/Form.pm
1
1
package HTML::Form;
2
2
3
# $Id: Form.pm,v 1.44 2004/06/16 10:06:07 gisle Exp $
4
3
5
use strict;
4
6
use URI;
5
7
use Carp ();
6
8
7
9
use vars qw($VERSION);
8
$VERSION='0.03';
10
$VERSION = sprintf("%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/);
9
11
10
12
my %form_tags = map {$_ => 1} qw(input textarea button select option);
11
13
12
14
my %type2class = (
13
15
text => "TextInput",
14
16
password => "TextInput",
15
file => "TextInput",
16
17
hidden => "TextInput",
17
18
textarea => "TextInput",
18
19
25
26
26
27
submit => "SubmitInput",
27
28
image => "ImageInput",
29
file => "FileInput",
30
31
keygen => "KeygenInput",
28
32
);
29
33
30
34
=head1 NAME
31
35
32
HTML::Form - Class that represents HTML forms
36
HTML::Form - Class that represents an HTML form element
33
37
34
38
=head1 SYNOPSIS
35
39
37
41
$form = HTML::Form->parse($html, $base_uri);
38
42
$form->value(query => "Perl");
39
43
40
use LWP;
41
LWP::UserAgent->new->request($form->click);
44
use LWP::UserAgent;
45
$ua = LWP::UserAgent->new;
46
$response = $ua->request($form->click);
42
47
43
48
=head1 DESCRIPTION
44
49
45
Objects of the C<HTML::Form> class represents a single HTML <form>
46
... </form> instance. A form consist of a sequence of inputs that
47
usually have names, and which can take on various values.
50
Objects of the C<HTML::Form> class represents a single HTML
51
C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
52
sequence of inputs that usually have names, and which can take on
53
various values. The state of a form can be tweaked and it can then be
54
asked to provide C<HTTP::Request> objects that can be passed to the
55
request() method of C<LWP::UserAgent>.
48
56
49
57
The following methods are available:
50
58
51
59
=over 4
52
60
53
=item $form = HTML::Form->new($method, $action_uri, [[$enctype], $input,...])
54
55
The constructor takes a $method and a $uri as argument. The $enctype
56
and and initial inputs are optional. You will normally use
57
HTML::Form->parse() to create new HTML::Form objects.
58
59
=cut
60
61
sub new {
62
my $class = shift;
63
my $self = bless {}, $class;
64
$self->{method} = uc(shift || "GET");
65
$self->{action} = shift || Carp::croak("No action defined");
66
$self->{enctype} = shift || "application/x-www-form-urlencoded";
67
$self->{inputs} = [@_];
68
$self;
69
}
70
71
72
=item @forms = HTML::Form->parse($html_document, $base_uri)
61
=item @forms = HTML::Form->parse( $html_document, $base_uri )
62
63
=item @forms = HTML::Form->parse( $response )
73
64
74
65
The parse() class method will parse an HTML document and build up
75
C<HTML::Form> objects for each <form> found. If called in scalar
66
C<HTML::Form> objects for each <form> element found. If called in scalar
76
67
context only returns the first <form>. Returns an empty list if there
77
68
are no forms to be found.
78
69
79
The $base_uri is (usually) the URI used to access the $html_document.
80
It is needed to resolve relative action URIs. For LWP this parameter
81
is obtained from the $response->base() method.
70
The $base_uri is the URI used to retrieve the $html_document. It is
71
needed to resolve relative action URIs. If the document was retrieved
72
with LWP then this this parameter is obtained from the
73
$response->base() method, as shown by the following example:
74
75
my $ua = LWP::UserAgent->new;
76
my $response = $ua->get("http://www.example.com/form.html");
77
my @forms = HTML::Form->parse($response->content,
78
$response->base);
79
80
The parse() method can parse from an C<HTTP::Response> object
81
directly, so the example above can be better written as:
82
83
my $ua = LWP::UserAgent->new;
84
my $response = $ua->get("http://www.example.com/form.html");
85
my @forms = HTML::Form->parse($response);
86
87
Note that any object that implements a content_ref() and base() method
88
with similar behaviour as C<HTTP::Response> will do.
82
89
83
90
=cut
84
91
86
93
{
87
94
my($class, $html, $base_uri) = @_;
88
95
require HTML::TokeParser;
89
my $p = HTML::TokeParser->new(\$html);
96
my $p = HTML::TokeParser->new(ref($html) ? $html->content_ref : \$html);
90
97
eval {
91
98
# optimization
92
$p->report_tags(qw(form input textarea select optgroup option));
99
$p->report_tags(qw(form input textarea select optgroup option keygen));
93
100
};
94
101
102
unless (defined $base_uri) {
103
if (ref($html)) {
104
$base_uri = $html->base;
105
}
106
else {
107
Carp::croak("HTML::Form::parse: No \$base_uri provided");
108
}
109
}
110
95
111
my @forms;
96
112
my $f; # current form
97
113
101
117
my $action = delete $attr->{'action'};
102
118
$action = "" unless defined $action;
103
119
$action = URI->new_abs($action, $base_uri);
104
$f = $class->new(delete $attr->{'method'},
120
$f = $class->new($attr->{'method'},
105
121
$action,
106
delete $attr->{'enctype'});
107
$f->{extra_attr} = $attr;
122
$attr->{'enctype'});
123
$f->{attr} = $attr;
108
124
push(@forms, $f);
109
125
while (my $t = $p->get_tag) {
110
126
my($tag, $attr) = @$t;
111
127
last if $tag eq "/form";
112
128
if ($tag eq "input") {
113
129
my $type = delete $attr->{type} || "text";
130
$attr->{value_name} = $p->get_phrase;
114
131
$f->push_input($type, $attr);
115
} elsif ($tag eq "textarea") {
132
}
133
elsif ($tag eq "textarea") {
116
134
$attr->{textarea_value} = $attr->{value}
117
135
if exists $attr->{value};
118
136
my $text = $p->get_text("/textarea");
119
137
$attr->{value} = $text;
120
138
$f->push_input("textarea", $attr);
121
} elsif ($tag eq "select") {
122
$attr->{select_value} = $attr->{value}
123
if exists $attr->{value};
139
}
140
elsif ($tag eq "select") {
141
# rename attributes reserved to come for the option tag
142
for ("value", "value_name") {
143
$attr->{"select_$_"} = delete $attr->{$_}
144
if exists $attr->{$_};
145
}
124
146
while ($t = $p->get_tag) {
125
147
my $tag = shift @$t;
126
148
last if $tag eq "/select";
127
149
next if $tag =~ m,/?optgroup,;
128
150
next if $tag eq "/option";
129
151
if ($tag eq "option") {
130
my %a = (%$attr, %{$t->[0]});
131
$a{value} = $p->get_trimmed_text
152
my %a = %{$t->[0]};
153
# rename keys so they don't clash with %attr
154
for (keys %a) {
155
next if $_ eq "value";
156
$a{"option_$_"} = delete $a{$_};
157
}
158
while (my($k,$v) = each %$attr) {
159
$a{$k} = $v;
160
}
161
$a{value_name} = $p->get_trimmed_text;
162
$a{value} = delete $a{value_name}
132
163
unless defined $a{value};
133
164
$f->push_input("option", \%a);
134
} else {
165
}
166
else {
135
167
Carp::carp("Bad <select> tag '$tag'") if $^W;
168
if ($tag eq "/form" ||
169
$tag eq "input" ||
170
$tag eq "textarea" ||
171
$tag eq "select" ||
172
$tag eq "keygen")
173
{
174
# MSIE implictly terminate the <select> here, so we
175
# try to do the same. Actually the MSIE behaviour
176
# appears really strange: <input> and <textarea>
177
# do implictly close, but not <select>, <keygen> or
178
# </form>.
179
my $type = ($tag =~ s,^/,,) ? "E" : "S";
180
$p->unget_token([$type, $tag, @$t]);
181
last;
182
}
136
183
}
137
184
}
138
185
}
186
elsif ($tag eq "keygen") {
187
$f->push_input("keygen", $attr);
188
}
139
189
}
140
} elsif ($form_tags{$tag}) {
190
}
191
elsif ($form_tags{$tag}) {
141
192
Carp::carp("<$tag> outside <form>") if $^W;
142
193
}
143
194
}
148
199
wantarray ? @forms : $forms[0];
149
200
}
150
201
151
=item $form->push_input($type, \%attr)
152
153
Adds a new input to the form.
154
155
=cut
202
sub new {
203
my $class = shift;
204
my $self = bless {}, $class;
205
$self->{method} = uc(shift || "GET");
206
$self->{action} = shift || Carp::croak("No action defined");
207
$self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
208
$self->{inputs} = [@_];
209
$self;
210
}
211
156
212
157
213
sub push_input
158
214
{
161
217
my $class = $type2class{$type};
162
218
unless ($class) {
163
219
Carp::carp("Unknown input type '$type'") if $^W;
164
$class = "IgnoreInput";
220
$class = "TextInput";
165
221
}
166
$class = "IgnoreInput" if exists $attr->{disabled};
167
222
$class = "HTML::Form::$class";
223
my @extra;
224
push(@extra, readonly => 1) if $type eq "hidden";
168
225
169
my $input = $class->new(type => $type, %$attr);
226
delete $attr->{type}; # don't confuse the type argument
227
my $input = $class->new(type => $type, %$attr, @extra);
170
228
$input->add_to_form($self);
171
229
}
172
230
173
231
174
=item $form->method( [$new] )
175
176
=item $form->action( [$new] )
177
178
=item $form->enctype( [$new] )
179
180
These method can be used to get/set the corresponding attribute of the
181
form.
232
=item $method = $form->method
233
234
=item $form->method( $new_method )
235
236
This method is gets/sets the I<method> name used for the
237
C<HTTP::Request> generated. It is a string like "GET" or "POST".
238
239
=item $action = $form->action
240
241
=item $form->action( $new_action )
242
243
This method gets/sets the URI which we want to apply the request
244
I<method> to.
245
246
=item $enctype = $form->enctype
247
248
=item $form->enctype( $new_enctype )
249
250
This method gets/sets the encoding type for the form data. It is a
251
string like "application/x-www-form-urlencoded" or "multipart/form-data".
182
252
183
253
=cut
184
254
197
267
*uri = \&action; # alias
198
268
}
199
269
200
201
=item $form->inputs
202
203
This method returns the list of inputs in the form.
270
=item $value = $form->attr( $name )
271
272
=item $form->attr( $name, $new_value )
273
274
This method give access to the original HTML attributes of the <form> tag.
275
The $name should always be passed in lower case.
276
277
Example:
278
279
@f = HTML::Form->parse( $html, $foo );
280
@f = grep $_->attr("id") == "foo", @f;
281
die "No form named 'foo' found" unless @f;
282
$foo = shift @f;
283
284
=cut
285
286
sub attr {
287
my $self = shift;
288
my $name = shift;
289
return undef unless defined $name;
290
291
my $old = $self->{attr}{$name};
292
$self->{attr}{$name} = shift if @_;
293
return $old;
294
}
295
296
=item @inputs = $form->inputs
297
298
This method returns the list of inputs in the form. If called in
299
scalar context it returns the number of inputs contained in the form.
300
See L</INPUTS> for what methods are available for the input objects
301
returned.
204
302
205
303
=cut
206
304
211
309
}
212
310
213
311
214
=item $form->find_input($name, $type, $no)
215
216
This method is used to locate some specific input within the form. At
217
least one of the arguments must be defined. If no matching input is
218
found, C<undef> is returned.
312
=item $input = $form->find_input( $name )
313
314
=item $input = $form->find_input( $name, $type )
315
316
=item $input = $form->find_input( $name, $type, $index )
317
318
This method is used to locate specific inputs within the form. All
319
inputs that match the arguments given are returned. In scalar context
320
only the first is returned, or C<undef> if none match.
219
321
220
322
If $name is specified, then the input must have the indicated name.
221
If $type is specified then the input must have the specified type. In
222
addition to the types possible for <input> HTML tags, we also have
223
"textarea" and "option". The $no is the sequence number of the input
224
with the indicated $name and/or $type (where 1 is the first).
323
324
If $type is specified, then the input must have the specified type.
325
The following type names are used: "text", "password", "hidden",
326
"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
327
328
The $index is the sequence number of the input matched where 1 is the
329
first. If combined with $name and/or $type then it select the I<n>th
330
input with the given name and/or type.
225
331
226
332
=cut
227
333
228
334
sub find_input
229
335
{
230
336
my($self, $name, $type, $no) = @_;
231
$no ||= 1;
232
for (@{$self->{'inputs'}}) {
233
if (defined $name) {
234
next unless exists $_->{name};
235
next if $name ne $_->{name};
236
}
237
next if $type && $type ne $_->{type};
238
next if --$no;
239
return $_;
240
}
241
return;
337
if (wantarray) {
338
my @res;
339
my $c;
340
for (@{$self->{'inputs'}}) {
341
if (defined $name) {
342
next unless exists $_->{name};
343
next if $name ne $_->{name};
344
}
345
next if $type && $type ne $_->{type};
346
$c++;
347
next if $no && $no != $c;
348
push(@res, $_);
349
}
350
return @res;
351
352
}
353
else {
354
$no ||= 1;
355
for (@{$self->{'inputs'}}) {
356
if (defined $name) {
357
next unless exists $_->{name};
358
next if $name ne $_->{name};
359
}
360
next if $type && $type ne $_->{type};
361
next if --$no;
362
return $_;
363
}
364
return undef;
365
}
242
366
}
243
367
244
368
sub fixup
250
374
}
251
375
252
376
253
=item $form->value($name, [$value])
377
=item $value = $form->value( $name )
378
379
=item $form->value( $name, $new_value )
254
380
255
381
The value() method can be used to get/set the value of some input. If
256
no input have the indicated name, then this method will croak.
382
no input has the indicated name, then this method will croak.
383
384
If multiple inputs have the same name, only the first one will be
385
affected.
386
387
The call:
388
389
$form->value('foo')
390
391
is a short-hand for:
392
393
$form->find_input('foo')->value;
257
394
258
395
=cut
259
396
267
404
$input->value(@_);
268
405
}
269
406
270
271
=item $form->try_others(\&callback)
407
=item @names = $form->param
408
409
=item @values = $form->param( $name )
410
411
=item $form->param( $name, $value, ... )
412
413
=item $form->param( $name, \@values )
414
415
Alternative interface to examining and setting the values of the form.
416
417
If called without arguments then it returns the names of all the
418
inputs in the form. The names will not repeat even if multiple inputs
419
have the same name. In scalar context the number of different names
420
is returned.
421
422
If called with a single argument then it returns the value or values
423
of inputs with the given name. If called in scalar context only the
424
first value is returned. If no input exists with the given name, then
425
C<undef> is returned.
426
427
If called with 2 or more arguments then it will set values of the
428
named inputs. This form will croak if no inputs have the given name
429
or if any of the values provided does not fit. Values can also be
430
provided as a reference to an array. This form will allow unsetting
431
all values with the given name as well.
432
433
This interface resembles that of the param() function of the CGI
434
module.
435
436
=cut
437
438
sub param {
439
my $self = shift;
440
if (@_) {
441
my $name = shift;
442
my @inputs;
443
for ($self->inputs) {
444
my $n = $_->name;
445
next if !defined($n) || $n ne $name;
446
push(@inputs, $_);
447
}
448
449
if (@_) {
450
# set
451
die "No '$name' parameter exists" unless @inputs;
452
my @v = @_;
453
@v = @{$v[0]} if @v == 1 && ref($v[0]);
454
while (@v) {
455
my $v = shift @v;
456
my $err;
457
for my $i (0 .. @inputs-1) {
458
eval {
459
$inputs[$i]->value($v);
460
};
461
unless ($@) {
462
undef($err);
463
splice(@inputs, $i, 1);
464
last;
465
}
466
$err ||= $@;
467
}
468
die $err if $err;
469
}
470
471
# the rest of the input should be cleared
472
for (@inputs) {
473
$_->value(undef);
474
}
475
}
476
else {
477
# get
478
my @v;
479
for (@inputs) {
480
if (defined(my $v = $_->value)) {
481
push(@v, $v);
482
}
483
}
484
return wantarray ? @v : $v[0];
485
}
486
}
487
else {
488
# list parameter names
489
my @n;
490
my %seen;
491
for ($self->inputs) {
492
my $n = $_->name;
493
next if !defined($n) || $seen{$n}++;
494
push(@n, $n);
495
}
496
return @n;
497
}
498
}
499
500
501
=item $form->try_others( \&callback )
272
502
273
503
This method will iterate over all permutations of unvisited enumerated
274
504
values (<select>, <radio>, <checkbox>) and invoke the callback for
275
each. The callback is passed the $form as argument.
505
each. The callback is passed the $form as argument. The return value
506
from the callback is ignored and the try_others() method itself does
507
not return anything.
276
508
277
509
=cut
278
510
300
532
}
301
533
302
534
303
=item $form->make_request
535
=item $request = $form->make_request
304
536
305
Will return a HTTP::Request object that reflects the current setting
306
of the form. You might want to use the click method instead.
537
Will return an C<HTTP::Request> object that reflects the current setting
538
of the form. You might want to use the click() method instead.
307
539
308
540
=cut
309
541
320
552
$uri = URI->new($uri, "http");
321
553
$uri->query_form(@form);
322
554
return HTTP::Request->new(GET => $uri);
323
} elsif ($method eq "POST") {
555
}
556
elsif ($method eq "POST") {
324
557
require HTTP::Request::Common;
325
558
return HTTP::Request::Common::POST($uri, \@form,
326
559
Content_Type => $enctype);
327
} else {
560
}
561
else {
328
562
Carp::croak("Unknown method '$method'");
329
563
}
330
564
}
331
565
332
566
333
=item $form->click([$name], [$x, $y])
334
335
Will click on the first clickable input (C<input/submit> or
336
C<input/image>), with the indicated $name, if specified. You can
337
optinally specify a coordinate clicked, which only makes a difference
338
if you clicked on an image. The default coordinate is (1,1).
567
=item $request = $form->click
568
569
=item $request = $form->click( $name )
570
571
=item $request = $form->click( $x, $y )
572
573
=item $request = $form->click( $name, $x, $y )
574
575
Will "click" on the first clickable input (which will be of type
576
C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
577
object that can then be passed to C<LWP::UserAgent> if you want to
578
obtain the server response.
579
580
If a $name is specified, we will click on the first clickable input
581
with the given name, and the method will croak if no clickable input
582
with the given name is found. If $name is I<not> specified, then it
583
is ok if the form contains no clickable inputs. In this case the
584
click() method returns the same request as the make_request() method
585
would do.
586
587
If there are multiple clickable inputs with the same name, then there
588
is no way to get the click() method of the C<HTML::Form> to click on
589
any but the first. If you need this you would have to locate the
590
input with find_input() and invoke the click() method on the given
591
input yourself.
592
593
A click coordinate pair can also be provided, but this only makes a
594
difference if you clicked on an image. The default coordinate is
595
(1,1). The upper-left corner of the image is (0,0), but some badly
596
coded CGI scripts are known to not recognize this. Therefore (1,1) was
597
selected as a safer default.
339
598
340
599
=cut
341
600
356
615
}
357
616
358
617
359
=item $form->form
360
361
Returns the current setting as a sequence of key/value pairs.
618
=item @kw = $form->form
619
620
Returns the current setting as a sequence of key/value pairs. Note
621
that keys might be repeated, which means that some values might be
622
lost if the return values are assigned to a hash.
623
624
In scalar context this method returns the number of key/value pairs
625
generated.
362
626
363
627
=cut
364
628
365
629
sub form
366
630
{
367
631
my $self = shift;
368
map {$_->form_name_value} @{$self->{'inputs'}};
632
map { $_->form_name_value($self) } @{$self->{'inputs'}};
369
633
}
370
634
371
635
372
636
=item $form->dump
373
637
374
Returns a textual representation of the form. Mainly useful for
375
debugging. If called in void context, then the dump is printed on
376
STDERR.
638
Returns a textual representation of current state of the form. Mainly
639
useful for debugging. If called in void context, then the dump is
640
printed on STDERR.
377
641
378
642
=cut
379
643
385
649
my $enctype = $self->{'enctype'};
386
650
my $dump = "$method $uri";
387
651
$dump .= " ($enctype)"
388
if $enctype eq "application/xxx-www-form-urlencoded";
652
if $enctype ne "application/x-www-form-urlencoded";
653
$dump .= " [$self->{attr}{name}]"
654
if exists $self->{attr}{name};
389
655
$dump .= "\n";
390
656
for ($self->inputs) {
391
657
$dump .= " " . $_->dump . "\n";
402
668
403
669
=head1 INPUTS
404
670
405
An C<HTML::Form> contains a sequence of inputs. References to the
406
inputs can be obtained with the $form->inputs or $form->find_input
407
methods. Once you have such a reference, then one of the following
408
methods can be used on it:
671
An C<HTML::Form> objects contains a sequence of I<inputs>. References to
672
the inputs can be obtained with the $form->inputs or $form->find_input
673
methods.
674
675
Note that there is I<not> a one-to-one correspondence between input
676
I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
677
input object basically represents a name/value pair, so when multiple
678
HTML elements contribute to the same name/value pair in the submitted
679
form they are combined.
680
681
The input elements that are mapped one-to-one are "text", "textarea",
682
"password", "hidden", "file", "image", "submit" and "checkbox". For
683
the "radio" and "option" inputs the story is not as simple: All
684
E<lt>input type="radio"E<gt> elements with the same name will
685
contribute to the same input radio object. The number of radio input
686
objects will be the same as the number of distinct names used for the
687
E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
688
without the C<multiple> attribute there will be one input object of
689
type of "option". For a E<lt>select multipleE<gt> element there will
690
be one input object for each contained E<lt>optionE<gt> element. Each
691
one of these option objects will have the same name.
692
693
The following methods are available for the I<input> objects:
409
694
410
695
=over 4
411
696
430
715
431
716
=item $input->type
432
717
433
Returns the type of this input. Types are stuff like "text",
434
"password", "hidden", "textarea", "image", "submit", "radio",
435
"checkbox", "option"...
718
Returns the type of this input. The type is one of the following
719
strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
720
"radio", "checkbox" or "option".
436
721
437
722
=cut
438
723
441
726
shift->{type};
442
727
}
443
728
444
=item $input->name([$new])
445
446
=item $input->value([$new])
447
448
These methods can be used to set/get the current name or value of an
449
input. If the input only can take an enumerated list of values, then
450
it is an error to try to set it to something else and the method will
451
croak if you try.
729
=item $name = $input->name
730
731
=item $input->name( $new_name )
732
733
This method can be used to get/set the current name of the input.
734
735
=item $value = $input->value
736
737
=item $input->value( $new_value )
738
739
This method can be used to get/set the current value of an
740
input.
741
742
If the input only can take an enumerated list of values, then it is an
743
error to try to set it to something else and the method will croak if
744
you try.
745
746
You will also be able to set the value of read-only inputs, but a
747
warning will be generated if running under C<perl -w>.
452
748
453
749
=cut
454
750
470
766
471
767
=item $input->possible_values
472
768
473
Returns a list of all values that and input can take. For inputs that
474
does not have discrete values this returns an empty list.
769
Returns a list of all values that an input can take. For inputs that
770
do not have discrete values, this returns an empty list.
475
771
476
772
=cut
477
773
491
787
return;
492
788
}
493
789
790
=item $input->value_names
791
792
For some inputs the values can have names that are different from the
793
values themselves. The number of names returned by this method will
794
match the number of values reported by $input->possible_values.
795
796
When setting values using the value() method it is also possible to
797
use the value names in place of the value itself.
798
799
=cut
800
801
sub value_names {
802
return
803
}
804
805
=item $bool = $input->readonly
806
807
=item $input->readonly( $bool )
808
809
This method is used to get/set the value of the readonly attribute.
810
You are allowed to modify the value of readonly inputs, but setting
811
the value will generate some noise when warnings are enabled. Hidden
812
fields always start out readonly.
813
814
=cut
815
816
sub readonly {
817
my $self = shift;
818
my $old = $self->{readonly};
819
$self->{readonly} = shift if @_;
820
$old;
821
}
822
823
=item $bool = $input->disabled
824
825
=item $input->disabled( $bool )
826
827
This method is used to get/set the value of the disabled attribute.
828
Disabled inputs do not contribute any key/value pairs for the form
829
value.
830
831
=cut
832
833
sub disabled {
834
my $self = shift;
835
my $old = $self->{disabled};
836
$self->{disabled} = shift if @_;
837
$old;
838
}
839
494
840
=item $input->form_name_value
495
841
496
842
Returns a (possible empty) list of key/value pairs that should be
503
849
my $self = shift;
504
850
my $name = $self->{'name'};
505
851
return unless defined $name;
852
return if $self->{disabled};
506
853
my $value = $self->value;
507
854
return unless defined $value;
508
855
return ($name => $value);
518
865
my $dump = "$name=$value";
519
866
520
867
my $type = $self->type;
521
return $dump if $type eq "text";
522
523
$type = ($type eq "text") ? "" : " ($type)";
524
my $menu = $self->{menu} || "";
525
if ($menu) {
526
my @menu;
527
for (0 .. @$menu-1) {
528
my $opt = $menu->[$_];
529
$opt = "<UNDEF>" unless defined $opt;
530
substr($opt,0,0) = "*" if $self->{seen}[$_];
531
push(@menu, $opt);
532
}
533
$menu = "[" . join("|", @menu) . "]";
868
869
$type .= " disabled" if $self->disabled;
870
$type .= " readonly" if $self->readonly;
871
return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
872
873
my @menu;
874
my $i = 0;
875
for (@{$self->{menu}}) {
876
my $opt = $_->{value};
877
$opt = "<UNDEF>" unless defined $opt;
878
$opt .= "/$_->{name}"
879
if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
880
substr($opt,0,0) = "-" if $_->{disabled};
881
if (exists $self->{current} && $self->{current} == $i) {
882
substr($opt,0,0) = "!" unless $_->{seen};
883
substr($opt,0,0) = "*";
884
}
885
else {
886
substr($opt,0,0) = ":" if $_->{seen};
887
}
888
push(@menu, $opt);
889
$i++;
534
890
}
535
sprintf "%-30s %-10s %s", $dump, $type, $menu;
891
892
return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
536
893
}
537
894
538
895
542
899
543
900
#input/text
544
901
#input/password
545
#input/file
546
902
#input/hidden
547
903
#textarea
548
904
549
905
sub value
550
906
{
551
907
my $self = shift;
908
my $old = $self->{value};
909
$old = "" unless defined $old;
552
910
if (@_) {
553
if (exists($self->{readonly}) || $self->{type} eq "hidden") {
554
Carp::carp("Input '$self->{name}' is readonly") if $^W;
555
}
911
Carp::carp("Input '$self->{name}' is readonly")
912
if $^W && $self->{readonly};
913
$self->{value} = shift;
556
914
}
557
$self->SUPER::value(@_);
915
$old;
558
916
}
559
917
560
918
#---------------------------------------------------
574
932
#select/option (val1, val2, ....)
575
933
#input/radio (undef, val1, val2,...)
576
934
#input/checkbox (undef, value)
935
#select-multiple/option (undef, value)
577
936
578
937
sub new
579
938
{
580
939
my $class = shift;
581
940
my $self = $class->SUPER::new(@_);
582
if ($self->type eq "checkbox") {
583
my $value = delete $self->{value};
941
942
my $value = delete $self->{value};
943
my $value_name = delete $self->{value_name};
944
my $type = $self->{type};
945
946
if ($type eq "checkbox") {
584
947
$value = "on" unless defined $value;
585
$self->{menu} = [undef, $value];
586
$self->{current} = (exists $self->{checked}) ? 1 : 0;
587
delete $self->{checked};
588
} else {
589
$self->{menu} = [delete $self->{value}];
590
my $checked = exists $self->{checked} || exists $self->{selected};
591
delete $self->{checked};
592
delete $self->{selected};
948
$self->{menu} = [
949
{ value => undef, name => "off", },
950
{ value => $value, name => $value_name, },
951
];
952
$self->{current} = (delete $self->{checked}) ? 1 : 0;
953
;
954
}
955
else {
956
$self->{option_disabled}++
957
if $type eq "radio" && delete $self->{disabled};
958
$self->{menu} = [
959
{value => $value, name => $value_name},
960
];
961
my $checked = $self->{checked} || $self->{option_selected};
962
delete $self->{checked};
963
delete $self->{option_selected};
593
964
if (exists $self->{multiple}) {
594
unshift(@{$self->{menu}}, undef);
965
unshift(@{$self->{menu}}, { value => undef, name => "off"});
595
966
$self->{current} = $checked ? 1 : 0;
596
} else {
967
}
968
else {
597
969
$self->{current} = 0 if $checked;
598
970
}
599
971
}
604
976
{
605
977
my($self, $form) = @_;
606
978
my $type = $self->type;
979
607
980
return $self->SUPER::add_to_form($form)
608
if $type eq "checkbox" ||
609
($type eq "option" && exists $self->{multiple});
981
if $type eq "checkbox";
982
983
if ($type eq "option" && $self->{multiple}) {
984
$self->{disabled} ||= $self->{option_disabled};
985
return $self->SUPER::add_to_form($form);
986
}
987
988
die "Assert" if @{$self->{menu}} != 1;
989
my $m = $self->{menu}[0];
990
$m->{disabled}++ if $self->{option_disabled};
610
991
611
992
my $prev = $form->find_input($self->{name}, $self->{type});
612
993
return $self->SUPER::add_to_form($form) unless $prev;
613
994
614
995
# merge menues
615
push(@{$prev->{menu}}, @{$self->{menu}});
616
$prev->{current} = @{$prev->{menu}} - 1 if exists $self->{current};
996
$prev->{current} = @{$prev->{menu}} if exists $self->{current};
997
push(@{$prev->{menu}}, $m);
617
998
}
618
999
619
1000
sub fixup
622
1003
if ($self->{type} eq "option" && !(exists $self->{current})) {
623
1004
$self->{current} = 0;
624
1005
}
625
$self->{seen} = [(0) x @{$self->{menu}}];
626
$self->{seen}[$self->{current}] = 1 if exists $self->{current};
1006
$self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
627
1007
}
628
1008
629
1009
sub value
630
1010
{
631
1011
my $self = shift;
632
1012
my $old;
633
$old = $self->{menu}[$self->{current}] if exists $self->{current};
1013
$old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
634
1014
if (@_) {
635
1015
my $i = 0;
636
1016
my $val = shift;
637
1017
my $cur;
1018
my $disabled;
638
1019
for (@{$self->{menu}}) {
639
if ((defined($val) && defined($_) && $val eq $_) ||
640
(!defined($val) && !defined($_))
1020
if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
1021
(!defined($val) && !defined($_->{value}))
641
1022
)
642
1023
{
643
1024
$cur = $i;
644
last;
1025
$disabled = $_->{disabled};
1026
last unless $disabled;
645
1027
}
646
1028
$i++;
647
1029
}
648
Carp::croak("Illegal value '$val'") unless defined $cur;
1030
if (!(defined $cur) || $disabled) {
1031
if (defined $val) {
1032
# try to search among the alternative names as well
1033
my $i = 0;
1034
my $cur_ignorecase;
1035
my $lc_val = lc($val);
1036
for (@{$self->{menu}}) {
1037
if (defined $_->{name}) {
1038
if ($val eq $_->{name}) {
1039
$disabled = $_->{disabled};
1040
$cur = $i;
1041
last unless $disabled;
1042
}
1043
if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
1044
$cur_ignorecase = $i;
1045
}
1046
}
1047
$i++;
1048
}
1049
unless (defined $cur) {
1050
$cur = $cur_ignorecase;
1051
if (defined $cur) {
1052
$disabled = $self->{menu}[$cur]{disabled};
1053
}
1054
else {
1055
my $n = $self->name;
1056
Carp::croak("Illegal value '$val' for field '$n'");
1057
}
1058
}
1059
}
1060
else {
1061
my $n = $self->name;
1062
Carp::croak("The '$n' field can't be unchecked");
1063
}
1064
}
1065
if ($disabled) {
1066
my $n = $self->name;
1067
Carp::croak("The value '$val' has been disabled for field '$n'");
1068
}
649
1069
$self->{current} = $cur;
650
$self->{seen}[$cur] = 1;
1070
$self->{menu}[$cur]{seen}++;
651
1071
}
652
1072
$old;
653
1073
}
654
1074
1075
=item $input->check
1076
1077
Some input types represent toggles that can be turned on/off. This
1078
includes "checkbox" and "option" inputs. Calling this method turns
1079
this input on without having to know the value name. If the input is
1080
already on, then nothing happens.
1081
1082
This has the same effect as:
1083
1084
$input->value($input->possible_values[1]);
1085
1086
The input can be turned off with:
1087
1088
$input->value(undef);
1089
1090
=cut
1091
1092
sub check
1093
{
1094
my $self = shift;
1095
$self->{current} = 1;
1096
$self->{menu}[1]{seen}++;
1097
}
1098
655
1099
sub possible_values
656
1100
{
657
1101
my $self = shift;
658
@{$self->{menu}};
1102
map $_->{value}, @{$self->{menu}};
659
1103
}
660
1104
661
1105
sub other_possible_values
662
1106
{
663
1107
my $self = shift;
664
map { $self->{menu}[$_] }
665
grep {!$self->{seen}[$_]}
666
0 .. (@{$self->{seen}} - 1);
1108
map $_->{value}, grep !$_->{seen}, @{$self->{menu}};
1109
}
1110
1111
sub value_names {
1112
my $self = shift;
1113
my @names;
1114
for (@{$self->{menu}}) {
1115
my $n = $_->{name};
1116
$n = $_->{value} unless defined $n;
1117
push(@names, $n);
1118
}
1119
@names;
667
1120
}
668
1121
669
1122
676
1129
677
1130
=item $input->click($form, $x, $y)
678
1131
679
Some input types (currently "sumbit" buttons and "images") can be
1132
Some input types (currently "submit" buttons and "images") can be
680
1133
clicked to submit the form. The click() method returns the
681
corrsponding C<HTTP::Request> object.
1134
corresponding C<HTTP::Request> object.
682
1135
683
1136
=cut
684
1137
709
1162
return unless $clicked;
710
1163
my $name = $self->{name};
711
1164
return unless defined $name;
1165
return if $self->{disabled};
712
1166
return ("$name.x" => $clicked->[0],
713
1167
"$name.y" => $clicked->[1]
714
1168
);
715
1169
}
716
1170
1171
#---------------------------------------------------
1172
package HTML::Form::FileInput;
1173
@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
1174
1175
=back
1176
1177
If the input is of type C<file>, then it has these additional methods:
1178
1179
=over 4
1180
1181
=item $input->file
1182
1183
This is just an alias for the value() method. It sets the filename to
1184
read data from.
1185
1186
=cut
1187
1188
sub file {
1189
my $self = shift;
1190
$self->value(@_);
1191
}
1192
1193
=item $filename = $input->filename
1194
1195
=item $input->filename( $new_filename )
1196
1197
This get/sets the filename reported to the server during file upload.
1198
This attribute defaults to the value reported by the file() method.
1199
1200
=cut
1201
1202
sub filename {
1203
my $self = shift;
1204
my $old = $self->{filename};
1205
$self->{filename} = shift if @_;
1206
$old = $self->file unless defined $old;
1207
$old;
1208
}
1209
1210
=item $content = $input->content
1211
1212
=item $input->content( $new_content )
1213
1214
This get/sets the file content provided to the server during file
1215
upload. This method can be used if you do not want the content to be
1216
read from an actual file.
1217
1218
=cut
1219
1220
sub content {
1221
my $self = shift;
1222
my $old = $self->{content};
1223
$self->{content} = shift if @_;
1224
$old;
1225
}
1226
1227
=item @headers = $input->headers
1228
1229
=item input->headers($key => $value, .... )
1230
1231
This get/set additional header fields describing the file uploaded.
1232
This can for instance be used to set the C<Content-Type> reported for
1233
the file.
1234
1235
=cut
1236
1237
sub headers {
1238
my $self = shift;
1239
my $old = $self->{headers} || [];
1240
$self->{headers} = [@_] if @_;
1241
@$old;
1242
}
1243
1244
sub form_name_value {
1245
my($self, $form) = @_;
1246
return $self->SUPER::form_name_value($form)
1247
if $form->method ne "POST" ||
1248
$form->enctype ne "multipart/form-data";
1249
1250
my $name = $self->name;
1251
return unless defined $name;
1252
return if $self->{disabled};
1253
1254
my $file = $self->file;
1255
my $filename = $self->filename;
1256
my @headers = $self->headers;
1257
my $content = $self->content;
1258
if (defined $content) {
1259
$filename = $file unless defined $filename;
1260
$file = undef;
1261
unshift(@headers, "Content" => $content);
1262
}
1263
elsif (!defined($file) || length($file) == 0) {
1264
return;
1265
}
1266
1267
# legacy (this used to be the way to do it)
1268
if (ref($file) eq "ARRAY") {
1269
my $f = shift @$file;
1270
my $fn = shift @$file;
1271
push(@headers, @$file);
1272
$file = $f;
1273
$filename = $fn unless defined $filename;
1274
}
1275
1276
return ($name => [$file, $filename, @headers]);
1277
}
1278
1279
package HTML::Form::KeygenInput;
1280
@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
1281
1282
sub challenge {
1283
my $self = shift;
1284
return $self->{challenge};
1285
}
1286
1287
sub keytype {
1288
my $self = shift;
1289
return lc($self->{keytype} || 'rsa');
1290
}
1291
717
1292
1;
718
1293
719
1294
__END__
722
1297
723
1298
=head1 SEE ALSO
724
1299
725
L<LWP>, L<HTML::Parser>, L<webchatpp>
1300
L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
726
1301
727
1302
=head1 COPYRIGHT
728
1303
729
Copyright 1998-2000 Gisle Aas.
1304
Copyright 1998-2003 Gisle Aas.
730
1305
731
1306
This library is free software; you can redistribute it and/or
732
1307
modify it under the same terms as Perl itself.
Loggerhead is a web-based interface for Breezy
Version: 2.0.1