1
package HTTP::Request::Common;
4
use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
6
$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
9
*import = \&Exporter::import;
10
@EXPORT =qw(GET HEAD PUT POST);
11
@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
13
require HTTP::Request;
18
my $CRLF = "\015\012"; # "\r\n" is not portable
20
sub GET { _simple_req('GET', @_); }
21
sub HEAD { _simple_req('HEAD', @_); }
22
sub PUT { _simple_req('PUT' , @_); }
23
sub DELETE { _simple_req('DELETE', @_); }
28
my $req = HTTP::Request->new(POST => $url);
30
$content = shift if @_ and ref $_[0];
32
while (($k,$v) = splice(@_, 0, 2)) {
33
if (lc($k) eq 'content') {
37
$req->push_header($k, $v);
40
my $ct = $req->header('Content-Type');
42
$ct = 'application/x-www-form-urlencoded';
44
elsif ($ct eq 'form-data') {
45
$ct = 'multipart/form-data';
49
if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
50
require HTTP::Headers::Util;
51
my @v = HTTP::Headers::Util::split_header_words($ct);
52
Carp::carp("Multiple Content-Type headers") if @v > 1;
57
for (my @tmp = @v; @tmp;) {
58
my($k, $v) = splice(@tmp, 0, 2);
59
if ($k eq "boundary") {
61
$boundary_index = @v - @tmp - 1;
66
($content, $boundary) = form_data($content, $boundary, $req);
68
if ($boundary_index) {
69
$v[$boundary_index] = $boundary;
72
push(@v, boundary => $boundary);
75
$ct = HTTP::Headers::Util::join_header_words(@v);
78
# We use a temporary URI object to format
79
# the application/x-www-form-urlencoded content.
81
my $url = URI->new('http:');
82
$url->query_form(ref($content) eq "HASH" ? %$content : @$content);
83
$content = $url->query;
87
$req->header('Content-Type' => $ct); # might be redundant
88
if (defined($content)) {
89
$req->header('Content-Length' =>
90
length($content)) unless ref($content);
91
$req->content($content);
94
$req->header('Content-Length' => 0);
102
my($method, $url) = splice(@_, 0, 2);
103
my $req = HTTP::Request->new($method => $url);
106
while (($k,$v) = splice(@_, 0, 2)) {
107
if (lc($k) eq 'content') {
108
$req->add_content($v);
112
$req->push_header($k, $v);
115
if ($content && !defined($req->header("Content-Length"))) {
116
$req->header("Content-Length", length(${$req->content_ref}));
122
sub form_data # RFC1867
124
my($data, $boundary, $req) = @_;
125
my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
129
while (($k,$v) = splice(@data, 0, 2)) {
131
$k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
133
qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
136
my($file, $usename, @headers) = @$v;
137
unless (defined $usename) {
139
$usename =~ s,.*/,, if defined($usename);
141
$k =~ s/([\\\"])/\\$1/g;
142
my $disp = qq(form-data; name="$k");
143
if (defined($usename) and length($usename)) {
144
$usename =~ s/([\\\"])/\\$1/g;
145
$disp .= qq(; filename="$usename");
148
my $h = HTTP::Headers->new(@headers);
150
open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
152
if ($DYNAMIC_FILE_UPLOAD) {
153
# will read file later, close it now in order to
154
# not accumulate to many open file handles
159
local($/) = undef; # slurp files
163
unless ($h->header("Content-Type")) {
164
require LWP::MediaTypes;
165
LWP::MediaTypes::guess_media_type($file, $h);
168
if ($h->header("Content-Disposition")) {
169
# just to get it sorted first
170
$disp = $h->header("Content-Disposition");
171
$h->remove_header("Content-Disposition");
173
if ($h->header("Content")) {
174
$content = $h->header("Content");
175
$h->remove_header("Content");
177
my $head = join($CRLF, "Content-Disposition: $disp",
178
$h->as_string($CRLF),
181
push(@parts, [$head, $$content]);
185
push(@parts, $head . $content);
189
return ("", "none") unless @parts;
193
$boundary = boundary(10) # hopefully enough randomness
196
# add the boundaries to the @parts array
198
splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
200
unshift(@parts, "--$boundary$CRLF");
201
push(@parts, "$CRLF--$boundary--$CRLF");
203
# See if we can generate Content-Length header
207
my ($head, $f) = @$_;
209
unless ( -f $f && ($file_size = -s _) ) {
210
# The file is either a dynamic file like /dev/audio
211
# or perhaps a file in the /proc file system where
212
# stat may return a 0 size even though reading it
213
# will produce data. So we cannot make
214
# a Content-Length header.
218
$length += $file_size + length $head;
224
$length && $req->header('Content-Length' => $length);
226
# set up a closure that will return content piecemeal
230
defined $length && $length != 0 &&
231
Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
234
my $p = shift @parts;
236
$p .= shift @parts while @parts && !ref($parts[0]);
237
defined $length && ($length -= length $p);
244
open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
247
my $buflength = length $buf;
248
my $n = read($fh, $buf, 2048, $buflength);
251
unshift(@parts, ["", $fh]);
257
defined $length && ($length -= $buflength);
265
$boundary = boundary() unless $boundary;
271
if (index($_, $boundary) >= 0) {
272
# must have a better boundary
273
$boundary = boundary(++$bno);
279
$content = "--$boundary$CRLF" .
280
join("$CRLF--$boundary$CRLF", @parts) .
281
"$CRLF--$boundary--$CRLF";
284
wantarray ? ($content, $boundary) : $content;
290
my $size = shift || return "xYzZY";
291
require MIME::Base64;
292
my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
293
$b =~ s/[\W]/X/g; # ensure alnum only
303
HTTP::Request::Common - Construct common HTTP::Request objects
307
use HTTP::Request::Common;
308
$ua = LWP::UserAgent->new;
309
$ua->request(GET 'http://www.sn.no/');
310
$ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
314
This module provide functions that return newly created C<HTTP::Request>
315
objects. These functions are usually more convenient to use than the
316
standard C<HTTP::Request> constructor for the most common requests. The
317
following functions are provided:
323
=item GET $url, Header => Value,...
325
The GET() function returns an C<HTTP::Request> object initialized with
326
the "GET" method and the specified URL. It is roughly equivalent to the
331
HTTP::Headers->new(Header => Value,...),
334
but is less cluttered. What is different is that a header named
335
C<Content> will initialize the content part of the request instead of
336
setting a header field. Note that GET requests should normally not
337
have a content, so this hack makes more sense for the PUT() and POST()
338
functions described below.
340
The get(...) method of C<LWP::UserAgent> exists as a shortcut for
341
$ua->request(GET ...).
345
=item HEAD $url, Header => Value,...
347
Like GET() but the method in the request is "HEAD".
349
The head(...) method of "LWP::UserAgent" exists as a shortcut for
350
$ua->request(HEAD ...).
354
=item PUT $url, Header => Value,...
356
=item PUT $url, Header => Value,..., Content => $content
358
Like GET() but the method in the request is "PUT".
360
The content of the request can be specified using the "Content"
361
pseudo-header. This steals a bit of the header field namespace as
362
there is no way to directly specify a header that is actually called
363
"Content". If you really need this you must update the request
364
returned in a separate statement.
368
=item DELETE $url, Header => Value,...
370
Like GET() but the method in the request is "DELETE". This function
371
is not exported by default.
375
=item POST $url, Header => Value,...
377
=item POST $url, $form_ref, Header => Value,...
379
=item POST $url, Header => Value,..., Content => $form_ref
381
=item POST $url, Header => Value,..., Content => $content
383
This works mostly like PUT() with "POST" as the method, but this
384
function also takes a second optional array or hash reference
385
parameter $form_ref. As for PUT() the content can also be specified
386
directly using the "Content" pseudo-header, and you may also provide
387
the $form_ref this way.
389
The $form_ref argument can be used to pass key/value pairs for the
390
form content. By default we will initialize a request using the
391
C<application/x-www-form-urlencoded> content type. This means that
392
you can emulate a HTML E<lt>form> POSTing like this:
394
POST 'http://www.perl.org/survey.cgi',
395
[ name => 'Gisle Aas',
396
email => 'gisle@aas.no',
402
This will create a HTTP::Request object that looks like this:
404
POST http://www.perl.org/survey.cgi
406
Content-Type: application/x-www-form-urlencoded
408
name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
410
Multivalued form fields can be specified by either repeating the field
411
name or by passing the value as an array reference.
413
The POST method also supports the C<multipart/form-data> content used
414
for I<Form-based File Upload> as specified in RFC 1867. You trigger
415
this content format by specifying a content type of C<'form-data'> as
416
one of the request headers. If one of the values in the $form_ref is
417
an array reference, then it is treated as a file part specification
418
with the following interpretation:
420
[ $file, $filename, Header => Value... ]
421
[ undef, $filename, Header => Value,..., Content => $content ]
423
The first value in the array ($file) is the name of a file to open.
424
This file will be read and its content placed in the request. The
425
routine will croak if the file can't be opened. Use an C<undef> as
426
$file value if you want to specify the content directly with a
427
C<Content> header. The $filename is the filename to report in the
428
request. If this value is undefined, then the basename of the $file
429
will be used. You can specify an empty string as $filename if you
430
want to suppress sending the filename when you provide a $file value.
432
If a $file is provided by no C<Content-Type> header, then C<Content-Type>
433
and C<Content-Encoding> will be filled in automatically with the values
434
returned by LWP::MediaTypes::guess_media_type()
436
Sending my F<~/.profile> to the survey used as example above can be
439
POST 'http://www.perl.org/survey.cgi',
440
Content_Type => 'form-data',
441
Content => [ name => 'Gisle Aas',
442
email => 'gisle@aas.no',
445
init => ["$ENV{HOME}/.profile"],
448
This will create a HTTP::Request object that almost looks this (the
449
boundary and the content of your F<~/.profile> is likely to be
452
POST http://www.perl.org/survey.cgi
454
Content-Type: multipart/form-data; boundary="6G+f"
457
Content-Disposition: form-data; name="name"
461
Content-Disposition: form-data; name="email"
465
Content-Disposition: form-data; name="gender"
469
Content-Disposition: form-data; name="born"
473
Content-Disposition: form-data; name="init"; filename=".profile"
474
Content-Type: text/plain
476
PATH=/local/perl/bin:$PATH
481
If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
482
value, then you get back a request object with a subroutine closure as
483
the content attribute. This subroutine will read the content of any
484
files on demand and return it in suitable chunks. This allow you to
485
upload arbitrary big files without using lots of memory. You can even
486
upload infinite files like F</dev/audio> if you wish; however, if
487
the file is not a plain file, there will be no Content-Length header
488
defined for the request. Not all servers (or server
489
applications) like this. Also, if the file(s) change in size between
490
the time the Content-Length is calculated and the time that the last
491
chunk is delivered, the subroutine will C<Croak>.
493
The post(...) method of "LWP::UserAgent" exists as a shortcut for
494
$ua->request(POST ...).
500
L<HTTP::Request>, L<LWP::UserAgent>
505
Copyright 1997-2004, Gisle Aas
507
This library is free software; you can redistribute it and/or
508
modify it under the same terms as Perl itself.
added
removed
lib/HTTP/Request/Common.pm
