git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/http10.pm

   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;