home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / HTTP / Request / Common.pm
Text File  |  1997-12-01  |  9KB  |  326 lines
  1. # $Id: Common.pm,v 1.6 1997/12/01 13:17:11 aas Exp $
  2. #
  3. package HTTP::Request::Common;
  4.  
  5. use strict;
  6. use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  7.  
  8. require Exporter;
  9. @ISA=qw(Exporter);
  10.  
  11. @EXPORT=qw(GET HEAD PUT POST);
  12. @EXPORT_OK=qw(cat);
  13.  
  14. require HTTP::Request;
  15. use Carp();
  16.  
  17. $VERSION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
  18.  
  19. my $CRLF = "\015\012";   # "\r\n" is not portable
  20.  
  21. sub GET  { _simple_req('GET',  @_); }
  22. sub HEAD { _simple_req('HEAD', @_); }
  23. sub PUT  { _simple_req('PUT' , @_); }
  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.     } 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.     } elsif ($ct eq 'form-data') {
  43.     $ct = 'multipart/form-data';
  44.     }
  45.  
  46.     if (ref $content) {
  47.     if (lc($ct) eq 'multipart/form-data') {    #XXX: boundary="..."
  48.         my $boundary;
  49.         ($content, $boundary) = form_data($content, $boundary);
  50.         $boundary = qq("$boundary") if $boundary =~ /\W/;
  51.         $ct = qq(multipart/form-data; boundary=$boundary);
  52.     } else {
  53.         # We use a temporary URI::URL object to format
  54.         # the application/x-www-form-urlencoded content.
  55.         require URI::URL;
  56.         my $url = URI::URL->new('http:');
  57.         $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
  58.         $content = $url->equery;
  59.     }
  60.     }
  61.  
  62.     $req->header('Content-Type' => $ct);  # might be redundant
  63.     if (defined($content)) {
  64.     $req->header('Content-Length' => length($content));
  65.     $req->content($content);
  66.     }
  67.     $req;
  68. }
  69.  
  70.  
  71. sub _simple_req
  72. {
  73.     my($method, $url) = splice(@_, 0, 2);
  74.     my $req = HTTP::Request->new($method => $url);
  75.     my($k, $v);
  76.     while (($k,$v) = splice(@_, 0, 2)) {
  77.     if (lc($k) eq 'content') {
  78.         $req->add_content($v);
  79.     } else {
  80.         $req->push_header($k, $v);
  81.     }
  82.     }
  83.     $req;
  84. }
  85.  
  86.  
  87. sub form_data   # RFC1867
  88. {
  89.     my($data, $boundary) = @_;
  90.     my @parts;
  91.     my($k,$v);
  92.     while (($k,$v) = splice(@$data, 0, 2)) {
  93.     if (ref $v) {
  94.         my $file = shift(@$v);
  95.         my $usename = shift(@$v);
  96.         unless (defined $usename) {
  97.         $usename = $file;
  98.         $usename =~ s,.*/,, if defined($usename);
  99.         }
  100.         my $disp = qq(form-data; name="$k");
  101.         $disp .= qq(; filename="$usename") if $usename;
  102.         my $content = "";
  103.         my $h = HTTP::Headers->new(@$v);
  104.         my $ct = $h->header("Content-Type");
  105.         if ($file) {
  106.         local(*F);
  107.         local($/) = undef; # slurp files
  108.         open(F, $file) or Carp::croak("Can't open file $file: $!");
  109.         binmode(F);
  110.         $content = <F>;
  111.         close(F);
  112.         unless ($ct) {
  113.             require LWP::MediaTypes;
  114.             $ct = LWP::MediaTypes::guess_media_type($file);
  115.             $h->header("Content-Type" => $ct); # XXX: content-encoding
  116.         }
  117.         }
  118.         if ($h->header("Content-Disposition")) {
  119.         $h->remove_header("Content-Disposition");
  120.         $disp = $h->remove_header("Content-Disposition");
  121.         }
  122.         if ($h->header("Content")) {
  123.         $content = $h->header("Content");
  124.         $h->remove_header("Content");
  125.         }
  126.         push(@parts, "Content-Disposition: $disp$CRLF" .
  127.                          $h->as_string($CRLF) .
  128.                          "$CRLF$content");
  129.     } else {
  130.         push(@parts, qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
  131.     }
  132.     }
  133.     return "" unless @parts;
  134.     $boundary = boundary() unless $boundary;
  135.  
  136.     my $bno = 1;
  137.   CHECK_BOUNDARY:
  138.     {
  139.     for (@parts) {
  140.         if (index($_, $boundary) >= 0) {
  141.         # must have a better boundary
  142.         #warn "Need something better that '$boundary' as boundary\n";
  143.         $boundary = boundary(++$bno);
  144.         redo CHECK_BOUNDARY;
  145.         }
  146.     }
  147.     last;
  148.     }
  149.  
  150.     my $content = "--$boundary$CRLF" .
  151.                   join("$CRLF--$boundary$CRLF", @parts) .
  152.                   "$CRLF--$boundary--$CRLF";
  153.     wantarray ? ($content, $boundary) : $content;
  154. }
  155.  
  156.  
  157. sub boundary
  158. {
  159.     my $size = shift || 1;
  160.     require MIME::Base64;
  161.     my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
  162.     $b =~ s/[\W]/X/g;  # ensure alnum only
  163.     $b;
  164. }
  165.  
  166. 1;
  167.  
  168. __END__
  169.  
  170. =head1 NAME
  171.  
  172. HTTP::Request::Common - Construct common HTTP::Request objects
  173.  
  174. =head1 SYNOPSIS
  175.  
  176.   use HTTP::Request::Common;
  177.   $ua = LWP::UserAgent->new;
  178.   $ua->request(GET 'http://www.sn.no/');
  179.   $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
  180.  
  181. =head1 DESCRIPTION
  182.  
  183. This module provide functions that return newly created HTTP::Request
  184. objects.  These functions are usually more convenient than the
  185. standard HTTP::Request constructor for these common requests.  The
  186. following functions are provided.
  187.  
  188. =over 4
  189.  
  190. =item GET $url, [Header => Value,...]
  191.  
  192. The GET() function returns a HTTP::Request object initialized with the
  193. GET method and the specified URL.  Without additional arguments it
  194. is exactly equivalent to the following call
  195.  
  196.   HTTP::Request->new(GET => $url)
  197.  
  198. but is less clutter.  It also reads better when used together with the
  199. LWP::UserAgent->request() method:
  200.  
  201.   my $ua = new LWP::UserAgent;
  202.   my $res = $ua->request(GET 'http://www.sn.no')
  203.   if ($res->is_success) { ...
  204.  
  205. You can also initialize the header values in the request by specifying
  206. some key/value pairs as optional arguments.  For instance:
  207.  
  208.   $ua->request(GET 'http://www.sn.no',
  209.                If_Match => 'foo',
  210.                    From     => 'gisle@aas.no',
  211.               );
  212.  
  213. A header key called 'Content' is special and when seen the value will
  214. initialize the content part of the request instead of setting a header.
  215.  
  216. =item HEAD $url, [Header => Value,...]
  217.  
  218. Like GET() but the method in the request is HEAD.
  219.  
  220. =item PUT $url, [Header => Value,...]
  221.  
  222. Like GET() but the method in the request is PUT.
  223.  
  224. =item POST $url, [$form_ref], [Header => Value,...]
  225.  
  226. This works mostly like GET() with POST as method, but this function
  227. also takes a second optional array or hash reference parameter
  228. ($form_ref).  This argument can be used to pass key/value pairs for
  229. the form content.  By default we will initialize a request using the
  230. C<application/x-www-form-urlencoded> content type.  This means that
  231. you can emulate a HTML E<lt>form> POSTing like this:
  232.  
  233.   POST 'http://www.perl.org/survey.cgi',
  234.        [ name   => 'Gisle Aas',
  235.          email  => 'gisle@aas.no',
  236.          gender => 'M',
  237.          born   => '1964',
  238.          perc   => '3%',
  239.        ];
  240.  
  241. This will create a HTTP::Request object that looks like this:
  242.  
  243.   POST http://www.perl.org/survey.cgi
  244.   Content-Length: 66
  245.   Content-Type: application/x-www-form-urlencoded
  246.  
  247.   name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
  248.  
  249. The POST method also supports the C<multipart/form-data> content used
  250. for I<Form-based File Upload> as specified in RFC 1867.  You trigger
  251. this content format by specifying a content type of C<'form-data'>.
  252. If one of the values in the $form_ref is an array reference, then it
  253. is treated as a file part specification with the following values:
  254.  
  255.   [ $file, $filename, Header => Value... ]
  256.  
  257. The first value in the array ($file) is the name of a file to open.
  258. This file will be read an its content placed in the request.  The
  259. routine will croak if the file can't be opened.  Use an undef as $file
  260. value if you want to specify the content directly.  The $filename is
  261. the filename to report in the request.  If this value is undefined,
  262. then the basename of the $file will be used.  You can specify an empty
  263. string as $filename if you don't want any filename in the request.
  264.  
  265. Sending my F<~/.profile> to the survey used as example above can be
  266. achieved by this:
  267.  
  268.   POST 'http://www.perl.org/survey.cgi',
  269.        Content_Type => 'form-data',
  270.        Content      => [ name  => 'Gisle Aas',
  271.                          email => 'gisle@aas.no',
  272.                          gender => 'M',
  273.                          born   => '1964',
  274.                          init   => ["$ENV{HOME}/.profile"],
  275.                        ]
  276.  
  277. This will create a HTTP::Request object that almost looks this (the
  278. boundary and the content of your F<~/.profile> is likely to be
  279. different):
  280.  
  281.   POST http://www.perl.org/survey.cgi
  282.   Content-Length: 388
  283.   Content-Type: multipart/form-data; boundary="6G+f"
  284.  
  285.   --6G+f
  286.   Content-Disposition: form-data; name="name"
  287.   
  288.   Gisle Aas
  289.   --6G+f
  290.   Content-Disposition: form-data; name="email"
  291.   
  292.   gisle@aas.no
  293.   --6G+f
  294.   Content-Disposition: form-data; name="gender"
  295.   
  296.   M
  297.   --6G+f
  298.   Content-Disposition: form-data; name="born"
  299.   
  300.   1964
  301.   --6G+f
  302.   Content-Disposition: form-data; name="init"; filename=".profile"
  303.   Content-Type: text/plain
  304.   
  305.   PATH=/local/perl/bin:$PATH
  306.   export PATH
  307.  
  308.   --6G+f--
  309.  
  310. =back
  311.  
  312. =head1 SEE ALSO
  313.  
  314. L<HTTP::Request>, L<LWP::UserAgent>
  315.  
  316.  
  317. =head1 COPYRIGHT
  318.  
  319. Copyright 1997, Gisle Aas
  320.  
  321. This library is free software; you can redistribute it and/or
  322. modify it under the same terms as Perl itself.
  323.  
  324. =cut
  325.  
  326.