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