home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / LWP / Protocol / http.pm < prev    next >
Text File  |  1997-12-12  |  5KB  |  205 lines

  1. #
  2. # $Id: http.pm,v 1.33 1997/12/12 10:09:53 aas Exp $
  3.  
  4. package LWP::Protocol::http;
  5.  
  6. require LWP::Debug;
  7. require LWP::Protocol;
  8. require LWP::Socket;
  9. require HTTP::Request;
  10. require HTTP::Response;
  11. require HTTP::Status;
  12.  
  13. use Carp ();
  14.  
  15. @ISA = qw(LWP::Protocol);
  16.  
  17. use strict;
  18.  
  19. my $httpversion  = 'HTTP/1.0';     # for requests
  20. my $endl         = "\015\012";     # how lines should be terminated;
  21.                    # "\r\n" is not correct on all systems, for
  22.                    # instance MacPerl defines it to "\012\015"
  23.  
  24. sub _new_socket
  25. {
  26.     LWP::Socket->new;
  27. }
  28.  
  29. sub request
  30. {
  31.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  32.     LWP::Debug::trace('()');
  33.  
  34.     $size ||= 4096;
  35.  
  36.     # check method
  37.     my $method = $request->method;
  38.     unless ($method =~ /^[A-Za-z0-9_!#\$%&'*+\-.^`|~]+$/) {     # HTTP token
  39.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  40.                   'Library does not allow method ' .
  41.                   "$method for 'http:' URLs";
  42.     }
  43.  
  44.     my $url = $request->url;
  45.     my($host, $port, $fullpath);
  46.  
  47.     # Check if we're proxy'ing
  48.     if (defined $proxy) {
  49.     # $proxy is an URL to an HTTP server which will proxy this request
  50.     $host = $proxy->host;
  51.     $port = $proxy->port;
  52.     $fullpath = $url->as_string;
  53.     }
  54.     else {
  55.     $host = $url->host;
  56.     $port = $url->port;
  57.     $fullpath = $url->full_path;
  58.     }
  59.  
  60.     alarm($timeout) if $self->use_alarm and $timeout;
  61.  
  62.     # connect to remote site
  63.     my $socket = $self->_new_socket();
  64.     $socket->connect($host, $port);
  65.  
  66.     my $request_line = "$method $fullpath $httpversion$endl";
  67.  
  68.     # If we're sending content we *have* to specify a content length
  69.     # otherwise the server won't know a messagebody is coming.
  70.  
  71.     my $content = $request->content;
  72.  
  73.     # All this mess because we want to support content as both scalar,
  74.     # ref to scalar and ref to code.
  75.     my $contRef;
  76.     if (defined $content){
  77.     $contRef = ref($content) ? $content : \$content;
  78.     if (ref($contRef) eq 'SCALAR') {
  79.         $request->header('Content-Length', length $$contRef)
  80.           if length $$contRef;
  81.     } elsif (ref($contRef) eq 'CODE') {
  82.         Carp::croak('No Content-Length header for request with content')
  83.           unless $request->header('Content-Length');
  84.     } else {
  85.         Carp::croak("Illegal content in request ($content)");
  86.     }
  87.     }
  88.  
  89.     # HTTP/1.1 will require us to send the 'Host' header, so we might
  90.     # as well start now.
  91.     {
  92.     my $host = $url->netloc;
  93.     $host =~ s/^([^\@]*)\@//;  # get rid of potential "user:pass@"
  94.     $request->header('Host' => $host);
  95.  
  96.     # add authorization header if we need them
  97.     if (defined($1) && not $request->header('Authorization')) {
  98.         $request->authorization_basic($url->user, $url->password);
  99.     }
  100.     }
  101.  
  102.     $socket->write($request_line . $request->headers_as_string($endl) . $endl);
  103.     if (defined $content) {
  104.     if (ref($contRef) eq 'CODE') {
  105.         $socket->write($contRef, $timeout);
  106.     } else {
  107.         $socket->write($$contRef, $timeout);
  108.     }
  109.     }
  110.  
  111.     # read response line from server
  112.     LWP::Debug::debug('reading response');
  113.  
  114.     my $res = "";
  115.     my $buf = "";
  116.     my $response;
  117.  
  118.     # Inside this loop we will read the response line and all headers
  119.     # found in the response.
  120.     while ($socket->read(\$buf, undef, $timeout)) {
  121.     $res .= $buf;
  122.     if ($res =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
  123.         # HTTP/1.0 response or better
  124.         my($ver,$code,$msg) = ($1, $2, $3);
  125.         $msg =~ s/\015$//;
  126.         LWP::Debug::debug("$ver $code $msg");
  127.         $response = HTTP::Response->new($code, $msg);
  128.         $response->protocol($ver);
  129.  
  130.         # ensure that we have read all headers.  The headers will be
  131.         # terminated by two blank lines
  132.         while ($res !~ /\015?\012\015?\012/) {
  133.         # must read more if we can...
  134.         LWP::Debug::debug("need more data for headers");
  135.         last unless $socket->read(\$buf, undef, $timeout);
  136.         $res .= $buf;
  137.         }
  138.  
  139.         # now we start parsing the headers.  The strategy is to
  140.         # remove one line at a time from the beginning of the header
  141.         # buffer ($res).
  142.         my($key, $val);
  143.         while ($res =~ s/([^\012]*)\012//) {
  144.         my $line = $1;
  145.  
  146.         # if we need to restore as content when illegal headers
  147.         # are found.
  148.         my $save = "$line\012"; 
  149.  
  150.         $line =~ s/\015$//;
  151.         last unless length $line;
  152.  
  153.         if ($line =~ /^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) {
  154.             $response->push_header($key, $val) if $key;
  155.             ($key, $val) = ($1, $2);
  156.         } elsif ($line =~ /^\s+(.*)/) {
  157.             unless ($key) {
  158.             LWP::Debug::debug("Illegal continuation header");
  159.             $res = "$save$res";
  160.             last;
  161.             }
  162.             $val .= " $1";
  163.         } else {
  164.             LWP::Debug::debug("Illegal header '$line'");
  165.             $res = "$save$res";
  166.             last;
  167.         }
  168.         }
  169.         $response->push_header($key, $val) if $key;
  170.         last;
  171.  
  172.     } elsif ((length($res) >= 5 and $res !~ /^HTTP\//) or
  173.          $res =~ /\012/ ) {
  174.         # HTTP/0.9 or worse
  175.         LWP::Debug::debug("HTTP/0.9 assume OK");
  176.         $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  177.         $response->protocol('HTTP/0.9');
  178.         last;
  179.  
  180.     } else {
  181.         # need more data
  182.         LWP::Debug::debug("need more data to know which protocol");
  183.     }
  184.     };
  185.     die "Unexpected EOF" unless $response;
  186.  
  187.     $socket->pushback($res) if length $res;
  188.     $response->request($request);
  189.  
  190.     # need to read content
  191.     alarm($timeout) if $self->use_alarm and $timeout;
  192.  
  193.     $response = $self->collect($arg, $response, sub {
  194.     LWP::Debug::debug('Collecting');
  195.     my $content = '';
  196.     my $result = $socket->read(\$content, $size, $timeout);
  197.     return \$content;
  198.     } );
  199.     $socket = undef;  # close it
  200.  
  201.     $response;
  202. }
  203.  
  204. 1;
  205.