home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / HTTP / Request / Common.pm
Encoding:
Text File  |  1997-09-05  |  8.6 KB  |  325 lines  |  [TEXT/McPL]
  1. # $Id: Common.pm,v 1.4 1997/09/03 11:18:13 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.4 $ =~ /(\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(@$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.         $content = <F>;
  110.         close(F);
  111.         unless ($ct) {
  112.             require LWP::MediaTypes;
  113.             $ct = LWP::MediaTypes::guess_media_type($file);
  114.             $h->header("Content-Type" => $ct); # XXX: content-encoding
  115.         }
  116.         }
  117.         if ($h->header("Content-Disposition")) {
  118.         $h->remove_header("Content-Disposition");
  119.         $disp = $h->remove_header("Content-Disposition");
  120.         }
  121.         if ($h->header("Content")) {
  122.         $content = $h->header("Content");
  123.         $h->remove_header("Content");
  124.         }
  125.         push(@parts, "Content-Disposition: $disp$CRLF" .
  126.                          $h->as_string($CRLF) .
  127.                          "$CRLF$content");
  128.     } else {
  129.         push(@parts, qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
  130.     }
  131.     }
  132.     return "" unless @parts;
  133.     $boundary = boundary() unless $boundary;
  134.  
  135.     my $bno = 1;
  136.   CHECK_BOUNDARY:
  137.     {
  138.     for (@parts) {
  139.         if (index($_, $boundary) >= 0) {
  140.         # must have a better boundary
  141.         #warn "Need something better that '$boundary' as boundary\n";
  142.         $boundary = boundary(++$bno);
  143.         redo CHECK_BOUNDARY;
  144.         }
  145.     }
  146.     last;
  147.     }
  148.  
  149.     my $content = "--$boundary$CRLF" .
  150.                   join("$CRLF--$boundary$CRLF", @parts) .
  151.                   "$CRLF--$boundary--$CRLF";
  152.     wantarray ? ($content, $boundary) : $content;
  153. }
  154.  
  155.  
  156. sub boundary
  157. {
  158.     my $size = shift || 1;
  159.     require MIME::Base64;
  160.     my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
  161.     $b =~ s/[\W]/X/g;  # ensure alnum only
  162.     $b;
  163. }
  164.  
  165. 1;
  166.  
  167. __END__
  168.  
  169. =head1 NAME
  170.  
  171. HTTP::Request::Common - Construct common HTTP::Request objects
  172.  
  173. =head1 SYNOPSIS
  174.  
  175.   use HTTP::Request::Common;
  176.   $ua = LWP::UserAgent->new;
  177.   $ua->request(GET 'http://www.sn.no/');
  178.   $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
  179.  
  180. =head1 DESCRIPTION
  181.  
  182. This module provide functions that return newly created HTTP::Request
  183. objects.  These functions are usually more convenient than the
  184. standard HTTP::Request constructor for these common requests.  The
  185. following functions are provided.
  186.  
  187. =over 4
  188.  
  189. =item GET $url, [Header => Value,...]
  190.  
  191. The GET() function returns a HTTP::Request object initialized with the
  192. GET method and the specified URL.  Without additional arguments it
  193. is exactly equivalent to the following call
  194.  
  195.   HTTP::Request->new(GET => $url)
  196.  
  197. but is less clutter.  It also reads better when used together with the
  198. LWP::UserAgent->request() method:
  199.  
  200.   my $ua = new LWP::UserAgent;
  201.   my $res = $ua->request(GET 'http://www.sn.no')
  202.   if ($res->is_success) { ...
  203.  
  204. You can also initialize the header values in the request by specifying
  205. some key/value pairs as optional arguments.  For instance:
  206.  
  207.   $ua->request(GET 'http://www.sn.no',
  208.                If_Match => 'foo',
  209.                    From     => 'gisle@aas.no',
  210.               );
  211.  
  212. A header key called 'Content' is special and when seen the value will
  213. initialize the content part of the request instead of setting a header.
  214.  
  215. =item HEAD $url, [Header => Value,...]
  216.  
  217. Like GET() but the method in the request is HEAD.
  218.  
  219. =item PUT $url, [Header => Value,...]
  220.  
  221. Like GET() but the method in the request is PUT.
  222.  
  223. =item POST $url, [$form_ref], [Header => Value,...]
  224.  
  225. This works mostly like GET() with POST as method, but this function
  226. also takes a second optional array reference parameter ($form_ref).
  227. This argument can be used to pass key/value pairs for the form
  228. content.  By default we will initialize a request using the
  229. C<application/x-www-form-urlencoded> content type.  This means that
  230. you can emulate a HTML E<lt>form> POSTing like this:
  231.  
  232.   POST 'http://www.perl.org/survey.cgi',
  233.        [ name  => 'Gisle',
  234.          email => 'gisle@aas.no',
  235.          gender => 'm',
  236.          born   => '1964',
  237.          trust  => '3%',
  238.     ];
  239.  
  240. This will create a HTTP::Request object that looks like this:
  241.  
  242.   POST http://www.perl.org/survey.cgi
  243.   Content-Length: 61
  244.   Content-Type: application/x-www-form-urlencoded
  245.  
  246.   name=Gisle&email=gisle%40aas.no&gender=m&born=1964&trust=3%25
  247.  
  248. The POST method also supports the C<multipart/form-data> content used
  249. for I<Form-based File Upload> as specified in RFC 1867.  You trigger
  250. this content format by specifying a content type of C<'form-data'>.
  251. If one of the values in the $form_ref is an array reference, then it
  252. is treated as a file part specification with the following values:
  253.  
  254.   [ $file, $filename, Header => Value... ]
  255.  
  256. The first value in the array ($file) is the name of a file to open.
  257. This file will be read an its content placed in the request.  The
  258. routine will croak if the file can't be opened.  Use an undef as $file
  259. value if you want to specify the content directly.  The $filename is
  260. the filename to report in the request.  If this value is undefined,
  261. then the basename of the $file will be used.  You can specify an empty
  262. string as $filename if you don't want any filename in the request.
  263.  
  264. Sending my F<~/.profile> to the survey used as example above can be
  265. achieved by this:
  266.  
  267.   POST 'http://www.perl.org/survey.cgi',
  268.        Content_Type => 'form-data',
  269.        Content      => [ name  => 'Gisle Aas',
  270.                          email => 'gisle@aas.no',
  271.                          gender => 'm',
  272.                          born   => '1964',
  273.                          init   => ["$ENV{HOME}/.profile"],
  274.                        ]
  275.  
  276. This will create a HTTP::Request object that almost looks this (the
  277. boundary and the content of your F<~/.profile> is likely to be
  278. different):
  279.  
  280.   POST http://www.perl.org/survey.cgi
  281.   Content-Length: 388
  282.   Content-Type: multipart/form-data; boundary="6G+f"
  283.  
  284.   --6G+f
  285.   Content-Disposition: form-data; name="name"
  286.   
  287.   Gisle Aas
  288.   --6G+f
  289.   Content-Disposition: form-data; name="email"
  290.   
  291.   gisle@aas.no
  292.   --6G+f
  293.   Content-Disposition: form-data; name="gender"
  294.   
  295.   m
  296.   --6G+f
  297.   Content-Disposition: form-data; name="born"
  298.   
  299.   1964
  300.   --6G+f
  301.   Content-Disposition: form-data; name="init"; filename=".profile"
  302.   Content-Type: text/plain
  303.   
  304.   PATH=/local/perl/bin:$PATH
  305.   export PATH
  306.  
  307.   --6G+f--
  308.  
  309. =back
  310.  
  311. =head1 SEE ALSO
  312.  
  313. L<HTTP::Request>, L<LWP::UserAgent>
  314.  
  315.  
  316. =head1 COPYRIGHT
  317.  
  318. Copyright 1997, Gisle Aas
  319.  
  320. This library is free software; you can redistribute it and/or
  321. modify it under the same terms as Perl itself.
  322.  
  323. =cut
  324.  
  325.