lib/HTTP/Request/Common.pm

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