local-lib5/lib/perl5/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 DELETE);
  12
  13 require HTTP::Request;
  14 use Carp();
  15
  16 $VERSION = "5.824";
  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 sub DELETE { _simple_req('DELETE', @_); }
  24
  25 sub POST
  26 {
  27     my $url = shift;
  28     my $req = HTTP::Request->new(POST => $url);
  29     my $content;
  30     $content = shift if @_ and ref $_[0];
  31     my($k, $v);
  32     while (($k,$v) = splice(@_, 0, 2)) {
  33         if (lc($k) eq 'content') {
  34             $content = $v;
  35         }
  36         else {
  37             $req->push_header($k, $v);
  38         }
  39     }
  40     my $ct = $req->header('Content-Type');
  41     unless ($ct) {
  42         $ct = 'application/x-www-form-urlencoded';
  43     }
  44     elsif ($ct eq 'form-data') {
  45         $ct = 'multipart/form-data';
  46     }
  47
  48     if (ref $content) {
  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;
  53             @v = @{$v[0]};
  54
  55             my $boundary;
  56             my $boundary_index;
  57             for (my @tmp = @v; @tmp;) {
  58                 my($k, $v) = splice(@tmp, 0, 2);
  59                 if ($k eq "boundary") {
  60                     $boundary = $v;
  61                     $boundary_index = @v - @tmp - 1;
  62                     last;
  63                 }
  64             }
  65
  66             ($content, $boundary) = form_data($content, $boundary, $req);
  67
  68             if ($boundary_index) {
  69                 $v[$boundary_index] = $boundary;
  70             }
  71             else {
  72                 push(@v, boundary => $boundary);
  73             }
  74
  75             $ct = HTTP::Headers::Util::join_header_words(@v);
  76         }
  77         else {
  78             # We use a temporary URI object to format
  79             # the application/x-www-form-urlencoded content.
  80             require URI;
  81             my $url = URI->new('http:');
  82             $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
  83             $content = $url->query;
  84         }
  85     }
  86
  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);
  92     }
  93     else {
  94         $req->header('Content-Length' => 0);
  95     }
  96     $req;
  97 }
  98
  99
 100 sub _simple_req
 101 {
 102     my($method, $url) = splice(@_, 0, 2);
 103     my $req = HTTP::Request->new($method => $url);
 104     my($k, $v);
 105     my $content;
 106     while (($k,$v) = splice(@_, 0, 2)) {
 107         if (lc($k) eq 'content') {
 108             $req->add_content($v);
 109             $content++;
 110         }
 111         else {
 112             $req->push_header($k, $v);
 113         }
 114     }
 115     if ($content && !defined($req->header("Content-Length"))) {
 116         $req->header("Content-Length", length(${$req->content_ref}));
 117     }
 118     $req;
 119 }
 120
 121
 122 sub form_data   # RFC1867
 123 {
 124     my($data, $boundary, $req) = @_;
 125     my @data = ref($data) eq "HASH" ? %$data : @$data;  # copy
 126     my $fhparts;
 127     my @parts;
 128     my($k,$v);
 129     while (($k,$v) = splice(@data, 0, 2)) {
 130         if (!ref($v)) {
 131             $k =~ s/([\\\"])/\\$1/g;  # escape quotes and backslashes
 132             push(@parts,
 133                  qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
 134         }
 135         else {
 136             my($file, $usename, @headers) = @$v;
 137             unless (defined $usename) {
 138                 $usename = $file;
 139                 $usename =~ s,.*/,, if defined($usename);
 140             }
 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");
 146             }
 147             my $content = "";
 148             my $h = HTTP::Headers->new(@headers);
 149             if ($file) {
 150                 open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
 151                 binmode($fh);
 152                 if ($DYNAMIC_FILE_UPLOAD) {
 153                     # will read file later, close it now in order to
 154                     # not accumulate to many open file handles
 155                     close($fh);
 156                     $content = \$file;
 157                 }
 158                 else {
 159                     local($/) = undef; # slurp files
 160                     $content = <$fh>;
 161                     close($fh);
 162                 }
 163                 unless ($h->header("Content-Type")) {
 164                     require LWP::MediaTypes;
 165                     LWP::MediaTypes::guess_media_type($file, $h);
 166                 }
 167             }
 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");
 172             }
 173             if ($h->header("Content")) {
 174                 $content = $h->header("Content");
 175                 $h->remove_header("Content");
 176             }
 177             my $head = join($CRLF, "Content-Disposition: $disp",
 178                                    $h->as_string($CRLF),
 179                                    "");
 180             if (ref $content) {
 181                 push(@parts, [$head, $$content]);
 182                 $fhparts++;
 183             }
 184             else {
 185                 push(@parts, $head . $content);
 186             }
 187         }
 188     }
 189     return ("", "none") unless @parts;
 190
 191     my $content;
 192     if ($fhparts) {
 193         $boundary = boundary(10) # hopefully enough randomness
 194             unless $boundary;
 195
 196         # add the boundaries to the @parts array
 197         for (1..@parts-1) {
 198             splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
 199         }
 200         unshift(@parts, "--$boundary$CRLF");
 201         push(@parts, "$CRLF--$boundary--$CRLF");
 202
 203         # See if we can generate Content-Length header
 204         my $length = 0;
 205         for (@parts) {
 206             if (ref $_) {
 207                 my ($head, $f) = @$_;
 208                 my $file_size;
 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.
 215                     undef $length;
 216                     last;
 217                 }
 218                 $length += $file_size + length $head;
 219             }
 220             else {
 221                 $length += length;
 222             }
 223         }
 224         $length && $req->header('Content-Length' => $length);
 225
 226         # set up a closure that will return content piecemeal
 227         $content = sub {
 228             for (;;) {
 229                 unless (@parts) {
 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.";
 232                     return;
 233                 }
 234                 my $p = shift @parts;
 235                 unless (ref $p) {
 236                     $p .= shift @parts while @parts && !ref($parts[0]);
 237                     defined $length && ($length -= length $p);
 238                     return $p;
 239                 }
 240                 my($buf, $fh) = @$p;
 241                 unless (ref($fh)) {
 242                     my $file = $fh;
 243                     undef($fh);
 244                     open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
 245                     binmode($fh);
 246                 }
 247                 my $buflength = length $buf;
 248                 my $n = read($fh, $buf, 2048, $buflength);
 249                 if ($n) {
 250                     $buflength += $n;
 251                     unshift(@parts, ["", $fh]);
 252                 }
 253                 else {
 254                     close($fh);
 255                 }
 256                 if ($buflength) {
 257                     defined $length && ($length -= $buflength);
 258                     return $buf
 259                 }
 260             }
 261         };
 262
 263     }
 264     else {
 265         $boundary = boundary() unless $boundary;
 266
 267         my $bno = 0;
 268       CHECK_BOUNDARY:
 269         {
 270             for (@parts) {
 271                 if (index($_, $boundary) >= 0) {
 272                     # must have a better boundary
 273                     $boundary = boundary(++$bno);
 274                     redo CHECK_BOUNDARY;
 275                 }
 276             }
 277             last;
 278         }
 279         $content = "--$boundary$CRLF" .
 280                    join("$CRLF--$boundary$CRLF", @parts) .
 281                    "$CRLF--$boundary--$CRLF";
 282     }
 283
 284     wantarray ? ($content, $boundary) : $content;
 285 }
 286
 287
 288 sub boundary
 289 {
 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
 294     $b;
 295 }
 296
 297 1;
 298
 299 __END__
 300
 301 =head1 NAME
 302
 303 HTTP::Request::Common - Construct common HTTP::Request objects
 304
 305 =head1 SYNOPSIS
 306
 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]);
 311
 312 =head1 DESCRIPTION
 313
 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:
 318
 319 =over 4
 320
 321 =item GET $url
 322
 323 =item GET $url, Header => Value,...
 324
 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
 327 following call
 328
 329   HTTP::Request->new(
 330      GET => $url,
 331      HTTP::Headers->new(Header => Value,...),
 332   )
 333
 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.
 339
 340 The get(...) method of C<LWP::UserAgent> exists as a shortcut for
 341 $ua->request(GET ...).
 342
 343 =item HEAD $url
 344
 345 =item HEAD $url, Header => Value,...
 346
 347 Like GET() but the method in the request is "HEAD".
 348
 349 The head(...)  method of "LWP::UserAgent" exists as a shortcut for
 350 $ua->request(HEAD ...).
 351
 352 =item PUT $url
 353
 354 =item PUT $url, Header => Value,...
 355
 356 =item PUT $url, Header => Value,..., Content => $content
 357
 358 Like GET() but the method in the request is "PUT".
 359
 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.
 365
 366 =item DELETE $url
 367
 368 =item DELETE $url, Header => Value,...
 369
 370 Like GET() but the method in the request is "DELETE".  This function
 371 is not exported by default.
 372
 373 =item POST $url
 374
 375 =item POST $url, Header => Value,...
 376
 377 =item POST $url, $form_ref, Header => Value,...
 378
 379 =item POST $url, Header => Value,..., Content => $form_ref
 380
 381 =item POST $url, Header => Value,..., Content => $content
 382
 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.
 388
 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:
 393
 394   POST 'http://www.perl.org/survey.cgi',
 395        [ name   => 'Gisle Aas',
 396          email  => 'gisle@aas.no',
 397          gender => 'M',
 398          born   => '1964',
 399          perc   => '3%',
 400        ];
 401
 402 This will create a HTTP::Request object that looks like this:
 403
 404   POST http://www.perl.org/survey.cgi
 405   Content-Length: 66
 406   Content-Type: application/x-www-form-urlencoded
 407
 408   name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
 409
 410 Multivalued form fields can be specified by either repeating the field
 411 name or by passing the value as an array reference.
 412
 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:
 419
 420   [ $file, $filename, Header => Value... ]
 421   [ undef, $filename, Header => Value,..., Content => $content ]
 422
 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.
 431
 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()
 435
 436 Sending my F<~/.profile> to the survey used as example above can be
 437 achieved by this:
 438
 439   POST 'http://www.perl.org/survey.cgi',
 440        Content_Type => 'form-data',
 441        Content      => [ name  => 'Gisle Aas',
 442                          email => 'gisle@aas.no',
 443                          gender => 'M',
 444                          born   => '1964',
 445                          init   => ["$ENV{HOME}/.profile"],
 446                        ]
 447
 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
 450 different):
 451
 452   POST http://www.perl.org/survey.cgi
 453   Content-Length: 388
 454   Content-Type: multipart/form-data; boundary="6G+f"
 455
 456   --6G+f
 457   Content-Disposition: form-data; name="name"
 458
 459   Gisle Aas
 460   --6G+f
 461   Content-Disposition: form-data; name="email"
 462
 463   gisle@aas.no
 464   --6G+f
 465   Content-Disposition: form-data; name="gender"
 466
 467   M
 468   --6G+f
 469   Content-Disposition: form-data; name="born"
 470
 471   1964
 472   --6G+f
 473   Content-Disposition: form-data; name="init"; filename=".profile"
 474   Content-Type: text/plain
 475
 476   PATH=/local/perl/bin:$PATH
 477   export PATH
 478
 479   --6G+f--
 480
 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>.
 492
 493 The post(...)  method of "LWP::UserAgent" exists as a shortcut for
 494 $ua->request(POST ...).
 495
 496 =back
 497
 498 =head1 SEE ALSO
 499
 500 L<HTTP::Request>, L<LWP::UserAgent>
 501
 502
 503 =head1 COPYRIGHT
 504
 505 Copyright 1997-2004, Gisle Aas
 506
 507 This library is free software; you can redistribute it and/or
 508 modify it under the same terms as Perl itself.
 509
 510 =cut
 511