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