home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol / http10.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-11  |  8.2 KB  |  304 lines
  1. package LWP::Protocol::http10;
  2.  
  3. use strict;
  4.  
  5. require LWP::Debug;
  6. require HTTP::Response;
  7. require HTTP::Status;
  8. require IO::Socket;
  9. require IO::Select;
  10.  
  11. use vars qw(@ISA @EXTRA_SOCK_OPTS);
  12.  
  13. require LWP::Protocol;
  14. @ISA = qw(LWP::Protocol);
  15.  
  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.                      $self->_extra_sock_opts($host, $port),
  30.                     );
  31.     unless ($sock) {
  32.     # IO::Socket::INET leaves additional error messages in $@
  33.     $@ =~ s/^.*?: //;
  34.     die "Can't connect to $host:$port ($@)";
  35.     }
  36.     $sock;
  37. }
  38.  
  39. sub _extra_sock_opts  # to be overridden by subclass
  40. {
  41.     return @EXTRA_SOCK_OPTS;
  42. }
  43.  
  44.  
  45. sub _check_sock
  46. {
  47.     #my($self, $req, $sock) = @_;
  48. }
  49.  
  50. sub _get_sock_info
  51. {
  52.     my($self, $res, $sock) = @_;
  53.     if (defined(my $peerhost = $sock->peerhost)) {
  54.     $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
  55.     }
  56. }
  57.  
  58. sub _fixup_header
  59. {
  60.     my($self, $h, $url, $proxy) = @_;
  61.  
  62.     $h->remove_header('Connection');  # need support here to be useful
  63.  
  64.     # HTTP/1.1 will require us to send the 'Host' header, so we might
  65.     # as well start now.
  66.     my $hhost = $url->authority;
  67.     if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
  68.     # add authorization header if we need them.  HTTP URLs do
  69.     # not really support specification of user and password, but
  70.     # we allow it.
  71.     if (defined($1) && not $h->header('Authorization')) {
  72.         require URI::Escape;
  73.         $h->authorization_basic(map URI::Escape::uri_unescape($_),
  74.                     split(":", $1, 2));
  75.     }
  76.     }
  77.     $h->init_header('Host' => $hhost);
  78.  
  79.     if ($proxy) {
  80.     # Check the proxy URI's userinfo() for proxy credentials
  81.     # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
  82.     my $p_auth = $proxy->userinfo();
  83.     if(defined $p_auth) {
  84.         require URI::Escape;
  85.         $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
  86.                       split(":", $p_auth, 2))
  87.     }
  88.     }
  89. }
  90.  
  91.  
  92. sub request
  93. {
  94.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  95.     LWP::Debug::trace('()');
  96.  
  97.     $size ||= 4096;
  98.  
  99.     # check method
  100.     my $method = $request->method;
  101.     unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
  102.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  103.                   'Library does not allow method ' .
  104.                   "$method for 'http:' URLs";
  105.     }
  106.  
  107.     my $url = $request->url;
  108.     my($host, $port, $fullpath);
  109.  
  110.     # Check if we're proxy'ing
  111.     if (defined $proxy) {
  112.     # $proxy is an URL to an HTTP server which will proxy this request
  113.     $host = $proxy->host;
  114.     $port = $proxy->port;
  115.     $fullpath = $method eq "CONNECT" ?
  116.                        ($url->host . ":" . $url->port) :
  117.                        $url->as_string;
  118.     }
  119.     else {
  120.     $host = $url->host;
  121.     $port = $url->port;
  122.     $fullpath = $url->path_query;
  123.     $fullpath = "/" unless length $fullpath;
  124.     }
  125.  
  126.     # connect to remote site
  127.     my $socket = $self->_new_socket($host, $port, $timeout);
  128.     $self->_check_sock($request, $socket);
  129.  
  130.     my $sel = IO::Select->new($socket) if $timeout;
  131.  
  132.     my $request_line = "$method $fullpath HTTP/1.0$CRLF";
  133.  
  134.     my $h = $request->headers->clone;
  135.     my $cont_ref = $request->content_ref;
  136.     $cont_ref = $$cont_ref if ref($$cont_ref);
  137.     my $ctype = ref($cont_ref);
  138.  
  139.     # If we're sending content we *have* to specify a content length
  140.     # otherwise the server won't know a messagebody is coming.
  141.     if ($ctype eq 'CODE') {
  142.     die 'No Content-Length header for request with dynamic content'
  143.         unless defined($h->header('Content-Length')) ||
  144.            $h->content_type =~ /^multipart\//;
  145.     # For HTTP/1.1 we could have used chunked transfer encoding...
  146.     }
  147.     else {
  148.     $h->header('Content-Length' => length $$cont_ref)
  149.             if defined($$cont_ref) && length($$cont_ref);
  150.     }
  151.  
  152.     $self->_fixup_header($h, $url, $proxy);
  153.  
  154.     my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
  155.     my $n;  # used for return value from syswrite/sysread
  156.     my $length;
  157.     my $offset;
  158.  
  159.     # syswrite $buf
  160.     $length = length($buf);
  161.     $offset = 0;
  162.     while ( $offset < $length ) {
  163.     die "write timeout" if $timeout && !$sel->can_write($timeout);
  164.     $n = $socket->syswrite($buf, $length-$offset, $offset );
  165.     die $! unless defined($n);
  166.     $offset += $n;
  167.     }
  168.     LWP::Debug::conns($buf);
  169.  
  170.     if ($ctype eq 'CODE') {
  171.     while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
  172.         # syswrite $buf
  173.         $length = length($buf);
  174.         $offset = 0;
  175.         while ( $offset < $length ) {
  176.         die "write timeout" if $timeout && !$sel->can_write($timeout);
  177.         $n = $socket->syswrite($buf, $length-$offset, $offset );
  178.         die $! unless defined($n);
  179.         $offset += $n;
  180.         }
  181.         LWP::Debug::conns($buf);
  182.     }
  183.     }
  184.     elsif (defined($$cont_ref) && length($$cont_ref)) {
  185.     # syswrite $$cont_ref
  186.     $length = length($$cont_ref);
  187.     $offset = 0;
  188.     while ( $offset < $length ) {
  189.         die "write timeout" if $timeout && !$sel->can_write($timeout);
  190.         $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
  191.         die $! unless defined($n);
  192.         $offset += $n;
  193.     }
  194.     LWP::Debug::conns($$cont_ref);
  195.     }
  196.  
  197.     # read response line from server
  198.     LWP::Debug::debug('reading response');
  199.  
  200.     my $response;
  201.     $buf = '';
  202.  
  203.     # Inside this loop we will read the response line and all headers
  204.     # found in the response.
  205.     while (1) {
  206.     die "read timeout" if $timeout && !$sel->can_read($timeout);
  207.     $n = $socket->sysread($buf, $size, length($buf));
  208.     die $! unless defined($n);
  209.     die "unexpected EOF before status line seen" unless $n;
  210.     LWP::Debug::conns($buf);
  211.  
  212.     if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
  213.         # HTTP/1.0 response or better
  214.         my($ver,$code,$msg) = ($1, $2, $3);
  215.         $msg =~ s/\015$//;
  216.         LWP::Debug::debug("$ver $code $msg");
  217.         $response = HTTP::Response->new($code, $msg);
  218.         $response->protocol($ver);
  219.  
  220.         # ensure that we have read all headers.  The headers will be
  221.         # terminated by two blank lines
  222.         until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
  223.         # must read more if we can...
  224.         LWP::Debug::debug("need more header data");
  225.         die "read timeout" if $timeout && !$sel->can_read($timeout);
  226.         my $old_len = length($buf);
  227.         $n = $socket->sysread($buf, $size, $old_len);
  228.         die $! unless defined($n);
  229.         die "unexpected EOF before all headers seen" unless $n;
  230.         LWP::Debug::conns(substr($buf, $old_len));
  231.         }
  232.  
  233.         # now we start parsing the headers.  The strategy is to
  234.         # remove one line at a time from the beginning of the header
  235.         # buffer ($res).
  236.         my($key, $val);
  237.         while ($buf =~ s/([^\012]*)\012//) {
  238.         my $line = $1;
  239.  
  240.         # if we need to restore as content when illegal headers
  241.         # are found.
  242.         my $save = "$line\012"; 
  243.  
  244.         $line =~ s/\015$//;
  245.         last unless length $line;
  246.  
  247.         if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
  248.             $response->push_header($key, $val) if $key;
  249.             ($key, $val) = ($1, $2);
  250.         }
  251.         elsif ($line =~ /^\s+(.*)/ && $key) {
  252.             $val .= " $1";
  253.         }
  254.         else {
  255.             $response->push_header("Client-Bad-Header-Line" => $line);
  256.         }
  257.         }
  258.         $response->push_header($key, $val) if $key;
  259.         last;
  260.  
  261.     }
  262.     elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
  263.            $buf =~ /\012/ ) {
  264.         # HTTP/0.9 or worse
  265.         LWP::Debug::debug("HTTP/0.9 assume OK");
  266.         $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  267.         $response->protocol('HTTP/0.9');
  268.         last;
  269.  
  270.     }
  271.     else {
  272.         # need more data
  273.         LWP::Debug::debug("need more status line data");
  274.     }
  275.     };
  276.     $response->request($request);
  277.     $self->_get_sock_info($response, $socket);
  278.  
  279.     if ($method eq "CONNECT") {
  280.     $response->{client_socket} = $socket;  # so it can be picked up
  281.     $response->content($buf);     # in case we read more than the headers
  282.     return $response;
  283.     }
  284.  
  285.     my $usebuf = length($buf) > 0;
  286.     $response = $self->collect($arg, $response, sub {
  287.         if ($usebuf) {
  288.         $usebuf = 0;
  289.         return \$buf;
  290.     }
  291.     die "read timeout" if $timeout && !$sel->can_read($timeout);
  292.     my $n = $socket->sysread($buf, $size);
  293.     die $! unless defined($n);
  294.     #LWP::Debug::conns($buf);
  295.     return \$buf;
  296.     } );
  297.  
  298.     #$socket->close;
  299.  
  300.     $response;
  301. }
  302.  
  303. 1;
  304.