git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/HTTP/Request/Common.pm

   1 package HTTP::Request::Common;
   2
   3 use strict;
   4 use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
   5
   6 $DYNAMIC_FILE_UPLOAD ||= 0;  # make it defined (don't know why)
   7
   8 require Exporter;
   9 *import = \&Exporter::import;
  10 @EXPORT =qw(GET HEAD PUT POST);
  11 @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD);
  12
  13 require HTTP::Request;
  14 use Carp();
  15
  16 $VERSION = "5.811";
  17
  18 my $CRLF = "\015\012";   # "\r\n" is not portable
  19
  20 sub GET  { _simple_req('GET',  @_); }
  21 sub HEAD { _simple_req('HEAD', @_); }
  22 sub PUT  { _simple_req('PUT' , @_); }
  23
  24 sub POST
  25 {
  26     my $url = shift;
  27     my $req = HTTP::Request->new(POST => $url);
  28     my $content;
  29     $content = shift if @_ and ref $_[0];
  30     my($k, $v);
  31     while (($k,$v) = splice(@_, 0, 2)) {
  32         if (lc($k) eq 'content') {
  33             $content = $v;
  34         }
  35         else {
  36             $req->push_header($k, $v);
  37         }
  38     }
  39     my $ct = $req->header('Content-Type');
  40     unless ($ct) {
  41         $ct = 'application/x-www-form-urlencoded';
  42     }
  43     elsif ($ct eq 'form-data') {
  44         $ct = 'multipart/form-data';
  45     }
  46
  47     if (ref $content) {
  48         if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
  49             require HTTP::Headers::Util;
  50             my @v = HTTP::Headers::Util::split_header_words($ct);
  51             Carp::carp("Multiple Content-Type headers") if @v > 1;
  52             @v = @{$v[0]};
  53
  54             my $boundary;
  55             my $boundary_index;
  56             for (my @tmp = @v; @tmp;) {
  57                 my($k, $v) = splice(@tmp, 0, 2);
  58                 if (lc($k) eq "boundary") {
  59                     $boundary = $v;
  60                     $boundary_index = @v - @tmp - 1;
  61                     last;
  62                 }
  63             }
  64
  65             ($content, $boundary) = form_data($content, $boundary, $req);
  66
  67             if ($boundary_index) {
  68                 $v[$boundary_index] = $boundary;
  69             }
  70             else {
  71                 push(@v, boundary => $boundary);
  72             }
  73
  74             $ct = HTTP::Headers::Util::join_header_words(@v);
  75         }
  76         else {
  77             # We use a temporary URI object to format
  78             # the application/x-www-form-urlencoded content.
  79             require URI;
  80             my $url = URI->new('http:');
  81             $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
  82             $content = $url->query;
  83         }
  84     }
  85
  86     $req->header('Content-Type' => $ct);  # might be redundant
  87     if (defined($content)) {
  88         $req->header('Content-Length' =>
  89                      length($content)) unless ref($content);
  90         $req->content($content);
  91     }
  92     else {
  93         $req->header('Content-Length' => 0);
  94     }
  95     $req;
  96 }
  97
  98
  99 sub _simple_req
 100 {
 101     my($method, $url) = splice(@_, 0, 2);
 102     my $req = HTTP::Request->new($method => $url);
 103     my($k, $v);
 104     while (($k,$v) = splice(@_, 0, 2)) {
 105         if (lc($k) eq 'content') {
 106             $req->add_content($v);
 107             $req->header("Content-Length", length(${$req->content_ref}));
 108         }
 109         else {
 110             $req->push_header($k, $v);
 111         }
 112     }
 113     $req;
 114 }
 115
 116
 117 sub form_data   # RFC1867
 118 {
 119     my($data, $boundary, $req) = @_;
 120     my @data = ref($data) eq "HASH" ? %$data : @$data;  # copy
 121     my $fhparts;
 122     my @parts;
 123     my($k,$v);
 124     while (($k,$v) = splice(@data, 0, 2)) {
 125         if (!ref($v)) {
 126             $k =~ s/([\\\"])/\\$1/g;  # escape quotes and backslashes
 127             push(@parts,
 128                  qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
 129         }
 130         else {
 131             my($file, $usename, @headers) = @$v;
 132             unless (defined $usename) {
 133                 $usename = $file;
 134                 $usename =~ s,.*/,, if defined($usename);
 135             }
 136             $k =~ s/([\\\"])/\\$1/g;
 137             my $disp = qq(form-data; name="$k");
 138             if (defined($usename) and length($usename)) {
 139                 $usename =~ s/([\\\"])/\\$1/g;
 140                 $disp .= qq(; filename="$usename");
 141             }
 142             my $content = "";
 143             my $h = HTTP::Headers->new(@headers);
 144             if ($file) {
 145                 require Symbol;
 146                 my $fh = Symbol::gensym();
 147                 open($fh, $file) or Carp::croak("Can't open file $file: $!");
 148                 binmode($fh);
 149                 if ($DYNAMIC_FILE_UPLOAD) {
 150                     # will read file later
 151                     $content = $fh;
 152                 }
 153                 else {
 154                     local($/) = undef; # slurp files
 155                     $content = <$fh>;
 156                     close($fh);
 157                 }
 158                 unless ($h->header("Content-Type")) {
 159                     require LWP::MediaTypes;
 160                     LWP::MediaTypes::guess_media_type($file, $h);
 161                 }
 162             }
 163             if ($h->header("Content-Disposition")) {
 164                 # just to get it sorted first
 165                 $disp = $h->header("Content-Disposition");
 166                 $h->remove_header("Content-Disposition");
 167             }
 168             if ($h->header("Content")) {
 169                 $content = $h->header("Content");
 170                 $h->remove_header("Content");
 171             }
 172             my $head = join($CRLF, "Content-Disposition: $disp",
 173                                    $h->as_string($CRLF),
 174                                    "");
 175             if (ref $content) {
 176                 push(@parts, [$head, $content]);
 177                 $fhparts++;
 178             }
 179             else {
 180                 push(@parts, $head . $content);
 181             }
 182         }
 183     }
 184     return ("", "none") unless @parts;
 185
 186     my $content;
 187     if ($fhparts) {
 188         $boundary = boundary(10) # hopefully enough randomness
 189             unless $boundary;
 190
 191         # add the boundaries to the @parts array
 192         for (1..@parts-1) {
 193             splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
 194         }
 195         unshift(@parts, "--$boundary$CRLF");
 196         push(@parts, "$CRLF--$boundary--$CRLF");
 197
 198         # See if we can generate Content-Length header
 199         my $length = 0;
 200         for (@parts) {
 201             if (ref $_) {
 202                 my ($head, $f) = @$_;
 203                 my $file_size;
 204                 unless ( -f $f && ($file_size = -s _) ) {
 205                     # The file is either a dynamic file like /dev/audio
 206                     # or perhaps a file in the /proc file system where
 207                     # stat may return a 0 size even though reading it
 208                     # will produce data.  So we cannot make
 209                     # a Content-Length header.
 210                     undef $length;
 211                     last;
 212                 }
 213                 $length += $file_size + length $head;
 214             }
 215             else {
 216                 $length += length;
 217             }
 218         }
 219         $length && $req->header('Content-Length' => $length);
 220
 221         # set up a closure that will return content piecemeal
 222         $content = sub {
 223             for (;;) {
 224                 unless (@parts) {
 225                     defined $length && $length != 0 &&
 226                         Carp::croak "length of data sent did not match calculated Content-Length header.  Probably because uploaded file changed in size during transfer.";
 227                     return;
 228                 }
 229                 my $p = shift @parts;
 230                 unless (ref $p) {
 231                     $p .= shift @parts while @parts && !ref($parts[0]);
 232                     defined $length && ($length -= length $p);
 233                     return $p;
 234                 }
 235                 my($buf, $fh) = @$p;
 236                 my $buflength = length $buf;
 237                 my $n = read($fh, $buf, 2048, $buflength);
 238                 if ($n) {
 239                     $buflength += $n;
 240                     unshift(@parts, ["", $fh]);
 241                 }
 242                 else {
 243                     close($fh);
 244                 }
 245                 if ($buflength) {
 246                     defined $length && ($length -= $buflength);
 247                     return $buf
 248                 }
 249             }
 250         };
 251
 252     }
 253     else {
 254         $boundary = boundary() unless $boundary;
 255
 256         my $bno = 0;
 257       CHECK_BOUNDARY:
 258         {
 259             for (@parts) {
 260                 if (index($_, $boundary) >= 0) {
 261                     # must have a better boundary
 262                     $boundary = boundary(++$bno);
 263                     redo CHECK_BOUNDARY;
 264                 }
 265             }
 266             last;
 267         }
 268         $content = "--$boundary$CRLF" .
 269                    join("$CRLF--$boundary$CRLF", @parts) .
 270                    "$CRLF--$boundary--$CRLF";
 271     }
 272
 273     wantarray ? ($content, $boundary) : $content;
 274 }
 275
 276
 277 sub boundary
 278 {
 279     my $size = shift || return "xYzZY";
 280     require MIME::Base64;
 281     my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
 282     $b =~ s/[\W]/X/g;  # ensure alnum only
 283     $b;
 284 }
 285
 286 1;
 287
 288 __END__
 289
 290 =head1 NAME
 291
 292 HTTP::Request::Common - Construct common HTTP::Request objects
 293
 294 =head1 SYNOPSIS
 295
 296   use HTTP::Request::Common;
 297   $ua = LWP::UserAgent->new;
 298   $ua->request(GET 'http://www.sn.no/');
 299   $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
 300
 301 =head1 DESCRIPTION
 302
 303 This module provide functions that return newly created C<HTTP::Request>
 304 objects.  These functions are usually more convenient to use than the
 305 standard C<HTTP::Request> constructor for the most common requests.  The
 306 following functions are provided:
 307
 308 =over 4
 309
 310 =item GET $url
 311
 312 =item GET $url, Header => Value,...
 313
 314 The GET() function returns an C<HTTP::Request> object initialized with
 315 the "GET" method and the specified URL.  It is roughly equivalent to the
 316 following call
 317
 318   HTTP::Request->new(
 319      GET => $url,
 320      HTTP::Headers->new(Header => Value,...),
 321   )
 322
 323 but is less cluttered.  What is different is that a header named
 324 C<Content> will initialize the content part of the request instead of
 325 setting a header field.  Note that GET requests should normally not
 326 have a content, so this hack makes more sense for the PUT() and POST()
 327 functions described below.
 328
 329 The get(...) method of C<LWP::UserAgent> exists as a shortcut for
 330 $ua->request(GET ...).
 331
 332 =item HEAD $url
 333
 334 =item HEAD $url, Header => Value,...
 335
 336 Like GET() but the method in the request is "HEAD".
 337
 338 The head(...)  method of "LWP::UserAgent" exists as a shortcut for
 339 $ua->request(HEAD ...).
 340
 341 =item PUT $url
 342
 343 =item PUT $url, Header => Value,...
 344
 345 =item PUT $url, Header => Value,..., Content => $content
 346
 347 Like GET() but the method in the request is "PUT".
 348
 349 The content of the request can be specified using the "Content"
 350 pseudo-header.  This steals a bit of the header field namespace as
 351 there is no way to directly specify a header that is actually called
 352 "Content".  If you really need this you must update the request
 353 returned in a separate statement.
 354
 355 =item POST $url
 356
 357 =item POST $url, Header => Value,...
 358
 359 =item POST $url, $form_ref, Header => Value,...
 360
 361 =item POST $url, Header => Value,..., Content => $form_ref
 362
 363 =item POST $url, Header => Value,..., Content => $content
 364
 365 This works mostly like PUT() with "POST" as the method, but this
 366 function also takes a second optional array or hash reference
 367 parameter $form_ref.  As for PUT() the content can also be specified
 368 directly using the "Content" pseudo-header, and you may also provide
 369 the $form_ref this way.
 370
 371 The $form_ref argument can be used to pass key/value pairs for the
 372 form content.  By default we will initialize a request using the
 373 C<application/x-www-form-urlencoded> content type.  This means that
 374 you can emulate a HTML E<lt>form> POSTing like this:
 375
 376   POST 'http://www.perl.org/survey.cgi',
 377        [ name   => 'Gisle Aas',
 378          email  => 'gisle@aas.no',
 379          gender => 'M',
 380          born   => '1964',
 381          perc   => '3%',
 382        ];
 383
 384 This will create a HTTP::Request object that looks like this:
 385
 386   POST http://www.perl.org/survey.cgi
 387   Content-Length: 66
 388   Content-Type: application/x-www-form-urlencoded
 389
 390   name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
 391
 392 Multivalued form fields can be specified by either repeating the field
 393 name or by passing the value as an array reference.
 394
 395 The POST method also supports the C<multipart/form-data> content used
 396 for I<Form-based File Upload> as specified in RFC 1867.  You trigger
 397 this content format by specifying a content type of C<'form-data'> as
 398 one of the request headers.  If one of the values in the $form_ref is
 399 an array reference, then it is treated as a file part specification
 400 with the following interpretation:
 401
 402   [ $file, $filename, Header => Value... ]
 403   [ undef, $filename, Header => Value,..., Content => $content ]
 404
 405 The first value in the array ($file) is the name of a file to open.
 406 This file will be read and its content placed in the request.  The
 407 routine will croak if the file can't be opened.  Use an C<undef> as
 408 $file value if you want to specify the content directly with a
 409 C<Content> header.  The $filename is the filename to report in the
 410 request.  If this value is undefined, then the basename of the $file
 411 will be used.  You can specify an empty string as $filename if you
 412 want to suppress sending the filename when you provide a $file value.
 413
 414 If a $file is provided by no C<Content-Type> header, then C<Content-Type>
 415 and C<Content-Encoding> will be filled in automatically with the values
 416 returned by LWP::MediaTypes::guess_media_type()
 417
 418 Sending my F<~/.profile> to the survey used as example above can be
 419 achieved by this:
 420
 421   POST 'http://www.perl.org/survey.cgi',
 422        Content_Type => 'form-data',
 423        Content      => [ name  => 'Gisle Aas',
 424                          email => 'gisle@aas.no',
 425                          gender => 'M',
 426                          born   => '1964',
 427                          init   => ["$ENV{HOME}/.profile"],
 428                        ]
 429
 430 This will create a HTTP::Request object that almost looks this (the
 431 boundary and the content of your F<~/.profile> is likely to be
 432 different):
 433
 434   POST http://www.perl.org/survey.cgi
 435   Content-Length: 388
 436   Content-Type: multipart/form-data; boundary="6G+f"
 437
 438   --6G+f
 439   Content-Disposition: form-data; name="name"
 440
 441   Gisle Aas
 442   --6G+f
 443   Content-Disposition: form-data; name="email"
 444
 445   gisle@aas.no
 446   --6G+f
 447   Content-Disposition: form-data; name="gender"
 448
 449   M
 450   --6G+f
 451   Content-Disposition: form-data; name="born"
 452
 453   1964
 454   --6G+f
 455   Content-Disposition: form-data; name="init"; filename=".profile"
 456   Content-Type: text/plain
 457
 458   PATH=/local/perl/bin:$PATH
 459   export PATH
 460
 461   --6G+f--
 462
 463 If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
 464 value, then you get back a request object with a subroutine closure as
 465 the content attribute.  This subroutine will read the content of any
 466 files on demand and return it in suitable chunks.  This allow you to
 467 upload arbitrary big files without using lots of memory.  You can even
 468 upload infinite files like F</dev/audio> if you wish; however, if
 469 the file is not a plain file, there will be no Content-Length header
 470 defined for the request.  Not all servers (or server
 471 applications) like this.  Also, if the file(s) change in size between
 472 the time the Content-Length is calculated and the time that the last
 473 chunk is delivered, the subroutine will C<Croak>.
 474
 475 The post(...)  method of "LWP::UserAgent" exists as a shortcut for
 476 $ua->request(POST ...).
 477
 478 =back
 479
 480 =head1 SEE ALSO
 481
 482 L<HTTP::Request>, L<LWP::UserAgent>
 483
 484
 485 =head1 COPYRIGHT
 486
 487 Copyright 1997-2004, Gisle Aas
 488
 489 This library is free software; you can redistribute it and/or
 490 modify it under the same terms as Perl itself.
 491
 492 =cut
 493