home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _b64aea5b0d3b3a507bd4993960dedab4 < prev    next >
Encoding:
Text File  |  2000-03-15  |  7.3 KB  |  254 lines
  1. #
  2. # $Id: http.pm,v 1.46 1999/03/19 22:03:10 gisle Exp $
  3.  
  4. package LWP::Protocol::http;
  5.  
  6. require LWP::Debug;
  7. require HTTP::Response;
  8. require HTTP::Status;
  9. require IO::Socket;
  10. require IO::Select;
  11.  
  12. require LWP::Protocol;
  13. @ISA = qw(LWP::Protocol);
  14.  
  15. use strict;
  16. my $CRLF         = "\015\012";     # how lines should be terminated;
  17.                    # "\r\n" is not correct on all systems, for
  18.                    # instance MacPerl defines it to "\012\015"
  19.  
  20. sub _new_socket
  21. {
  22.     my($self, $host, $port, $timeout) = @_;
  23.  
  24.     local($^W) = 0;  # IO::Socket::INET can be noisy
  25.     my $sock = IO::Socket::INET->new(PeerAddr => $host,
  26.                      PeerPort => $port,
  27.                      Proto    => 'tcp',
  28.                      Timeout  => $timeout,
  29.                     );
  30.     unless ($sock) {
  31.     # IO::Socket::INET leaves additional error messages in $@
  32.     $@ =~ s/^.*?: //;
  33.     die "Can't connect to $host:$port ($@)";
  34.     }
  35.     $sock;
  36. }
  37.  
  38.  
  39. sub _check_sock
  40. {
  41.     #my($self, $req, $sock) = @_;
  42. }
  43.  
  44. sub _get_sock_info
  45. {
  46.     my($self, $res, $sock) = @_;
  47.     $res->header("Client-Peer" =>
  48.          $sock->peerhost . ":" . $sock->peerport);
  49. }
  50.  
  51.  
  52. sub request
  53. {
  54.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  55.     LWP::Debug::trace('()');
  56.  
  57.     $size ||= 4096;
  58.  
  59.     # check method
  60.     my $method = $request->method;
  61.     unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
  62.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  63.                   'Library does not allow method ' .
  64.                   "$method for 'http:' URLs";
  65.     }
  66.  
  67.     my $url = $request->url;
  68.     my($host, $port, $fullpath);
  69.  
  70.     # Check if we're proxy'ing
  71.     if (defined $proxy) {
  72.     # $proxy is an URL to an HTTP server which will proxy this request
  73.     $host = $proxy->host;
  74.     $port = $proxy->port;
  75.     $fullpath = $url->as_string;
  76.     }
  77.     else {
  78.     $host = $url->host;
  79.     $port = $url->port;
  80.     $fullpath = $url->path_query;
  81.     $fullpath = "/" unless length $fullpath;
  82.     }
  83.  
  84.     # connect to remote site
  85.     my $socket = $self->_new_socket($host, $port, $timeout);
  86.     $self->_check_sock($request, $socket);
  87.         
  88.     my $sel = IO::Select->new($socket) if $timeout;
  89.  
  90.     my $request_line = "$method $fullpath HTTP/1.0$CRLF";
  91.  
  92.     my $h = $request->headers->clone;
  93.     my $cont_ref = $request->content_ref;
  94.     $cont_ref = $$cont_ref if ref($$cont_ref);
  95.     my $ctype = ref($cont_ref);
  96.  
  97.     # If we're sending content we *have* to specify a content length
  98.     # otherwise the server won't know a messagebody is coming.
  99.     if ($ctype eq 'CODE') {
  100.     die 'No Content-Length header for request with dynamic content'
  101.         unless defined($h->header('Content-Length')) ||
  102.            $h->content_type =~ /^multipart\//;
  103.     # For HTTP/1.1 we could have used chunked transfer encoding...
  104.     } else {
  105.     $h->header('Content-Length' => length $$cont_ref)
  106.             if defined($$cont_ref) && length($$cont_ref);
  107.     }
  108.     
  109.     # HTTP/1.1 will require us to send the 'Host' header, so we might
  110.     # as well start now.
  111.     my $hhost = $url->authority;
  112.     $hhost =~ s/^([^\@]*)\@//;  # get rid of potential "user:pass@"
  113.     $h->header('Host' => $hhost) unless defined $h->header('Host');
  114.  
  115.     # add authorization header if we need them.  HTTP URLs do
  116.     # not really support specification of user and password, but
  117.     # we allow it.
  118.     if (defined($1) && not $h->header('Authorization')) {
  119.     $h->authorization_basic(split(":", $1));
  120.     }
  121.  
  122.     my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
  123.     my $n;  # used for return value from syswrite/sysread
  124.  
  125.     die "write timeout" if $timeout && !$sel->can_write($timeout);
  126.     $n = $socket->syswrite($buf, length($buf));
  127.     die $! unless defined($n);
  128.     die "short write" unless $n == length($buf);
  129.     LWP::Debug::conns($buf);
  130.  
  131.     if ($ctype eq 'CODE') {
  132.     while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
  133.         die "write timeout" if $timeout && !$sel->can_write($timeout);
  134.         $n = $socket->syswrite($buf, length($buf));
  135.         die $! unless defined($n);
  136.         die "short write" unless $n == length($buf);
  137.         LWP::Debug::conns($buf);
  138.     }
  139.     } elsif (defined($$cont_ref) && length($$cont_ref)) {
  140.     die "write timeout" if $timeout && !$sel->can_write($timeout);
  141.     $n = $socket->syswrite($$cont_ref, length($$cont_ref));
  142.     die $! unless defined($n);
  143.     die "short write" unless $n == length($$cont_ref);
  144.     LWP::Debug::conns($buf);
  145.     }
  146.     
  147.     # read response line from server
  148.     LWP::Debug::debug('reading response');
  149.  
  150.     my $response;
  151.     $buf = '';
  152.  
  153.     # Inside this loop we will read the response line and all headers
  154.     # found in the response.
  155.     while (1) {
  156.     {
  157.         die "read timeout" if $timeout && !$sel->can_read($timeout);
  158.         $n = $socket->sysread($buf, $size, length($buf));
  159.         die $! unless defined($n);
  160.         die "unexpected EOF before status line seen" unless $n;
  161.         LWP::Debug::conns($buf);
  162.     }
  163.     if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
  164.         # HTTP/1.0 response or better
  165.         my($ver,$code,$msg) = ($1, $2, $3);
  166.         $msg =~ s/\015$//;
  167.         LWP::Debug::debug("$ver $code $msg");
  168.         $response = HTTP::Response->new($code, $msg);
  169.         $response->protocol($ver);
  170.  
  171.         # ensure that we have read all headers.  The headers will be
  172.         # terminated by two blank lines
  173.         until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
  174.         # must read more if we can...
  175.         LWP::Debug::debug("need more header data");
  176.         die "read timeout" if $timeout && !$sel->can_read($timeout);
  177.         $n = $socket->sysread($buf, $size, length($buf));
  178.         die $! unless defined($n);
  179.         die "unexpected EOF before all headers seen" unless $n;
  180.         #LWP::Debug::conns($buf);
  181.         }
  182.  
  183.         # now we start parsing the headers.  The strategy is to
  184.         # remove one line at a time from the beginning of the header
  185.         # buffer ($res).
  186.         my($key, $val);
  187.         while ($buf =~ s/([^\012]*)\012//) {
  188.         my $line = $1;
  189.  
  190.         # if we need to restore as content when illegal headers
  191.         # are found.
  192.         my $save = "$line\012"; 
  193.  
  194.         $line =~ s/\015$//;
  195.         last unless length $line;
  196.  
  197.         if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
  198.             $response->push_header($key, $val) if $key;
  199.             ($key, $val) = ($1, $2);
  200.         } elsif ($line =~ /^\s+(.*)/) {
  201.             unless ($key) {
  202.             $response->header("Client-Warning" =>
  203.                      => "Illegal continuation header");
  204.             $buf = "$save$buf";
  205.             last;
  206.             }
  207.             $val .= " $1";
  208.         } else {
  209.             $response->header("Client-Warning" =>
  210.                       "Illegal header '$line'");
  211.             $buf = "$save$buf";
  212.             last;
  213.         }
  214.         }
  215.         $response->push_header($key, $val) if $key;
  216.         last;
  217.  
  218.     } elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
  219.          $buf =~ /\012/ ) {
  220.         # HTTP/0.9 or worse
  221.         LWP::Debug::debug("HTTP/0.9 assume OK");
  222.         $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  223.         $response->protocol('HTTP/0.9');
  224.         last;
  225.  
  226.     } else {
  227.         # need more data
  228.         LWP::Debug::debug("need more status line data");
  229.     }
  230.     };
  231.     $response->request($request);
  232.     $self->_get_sock_info($response, $socket);
  233.  
  234.  
  235.     my $usebuf = length($buf) > 0;
  236.     $response = $self->collect($arg, $response, sub {
  237.         if ($usebuf) {
  238.         $usebuf = 0;
  239.         return \$buf;
  240.     }
  241.     die "read timeout" if $timeout && !$sel->can_read($timeout);
  242.     my $n = $socket->sysread($buf, $size);
  243.     die $! unless defined($n);
  244.     #LWP::Debug::conns($buf);
  245.     return \$buf;
  246.     } );
  247.  
  248.     $socket->close;
  249.  
  250.     $response;
  251. }
  252.  
  253. 1;
  254.