local-lib5/lib/perl5/LWP/Protocol/http.pm

   1 package LWP::Protocol::http;
   2
   3 use strict;
   4
   5 require HTTP::Response;
   6 require HTTP::Status;
   7 require Net::HTTP;
   8
   9 use vars qw(@ISA @EXTRA_SOCK_OPTS);
  10
  11 require LWP::Protocol;
  12 @ISA = qw(LWP::Protocol);
  13
  14 my $CRLF = "\015\012";
  15
  16 sub _new_socket
  17 {
  18     my($self, $host, $port, $timeout) = @_;
  19     my $conn_cache = $self->{ua}{conn_cache};
  20     if ($conn_cache) {
  21         if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
  22             return $sock if $sock && !$sock->can_read(0);
  23             # if the socket is readable, then either the peer has closed the
  24             # connection or there are some garbage bytes on it.  In either
  25             # case we abandon it.
  26             $sock->close;
  27         }
  28     }
  29
  30     local($^W) = 0;  # IO::Socket::INET can be noisy
  31     my $sock = $self->socket_class->new(PeerAddr => $host,
  32                                         PeerPort => $port,
  33                                         LocalAddr => $self->{ua}{local_address},
  34                                         Proto    => 'tcp',
  35                                         Timeout  => $timeout,
  36                                         KeepAlive => !!$conn_cache,
  37                                         SendTE    => 1,
  38                                         $self->_extra_sock_opts($host, $port),
  39                                        );
  40
  41     unless ($sock) {
  42         # IO::Socket::INET leaves additional error messages in $@
  43         $@ =~ s/^.*?: //;
  44         die "Can't connect to $host:$port ($@)";
  45     }
  46
  47     # perl 5.005's IO::Socket does not have the blocking method.
  48     eval { $sock->blocking(0); };
  49
  50     $sock;
  51 }
  52
  53 sub socket_type
  54 {
  55     return "http";
  56 }
  57
  58 sub socket_class
  59 {
  60     my $self = shift;
  61     (ref($self) || $self) . "::Socket";
  62 }
  63
  64 sub _extra_sock_opts  # to be overridden by subclass
  65 {
  66     return @EXTRA_SOCK_OPTS;
  67 }
  68
  69 sub _check_sock
  70 {
  71     #my($self, $req, $sock) = @_;
  72 }
  73
  74 sub _get_sock_info
  75 {
  76     my($self, $res, $sock) = @_;
  77     if (defined(my $peerhost = $sock->peerhost)) {
  78         $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
  79     }
  80 }
  81
  82 sub _fixup_header
  83 {
  84     my($self, $h, $url, $proxy) = @_;
  85
  86     # Extract 'Host' header
  87     my $hhost = $url->authority;
  88     if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
  89         # add authorization header if we need them.  HTTP URLs do
  90         # not really support specification of user and password, but
  91         # we allow it.
  92         if (defined($1) && not $h->header('Authorization')) {
  93             require URI::Escape;
  94             $h->authorization_basic(map URI::Escape::uri_unescape($_),
  95                                     split(":", $1, 2));
  96         }
  97     }
  98     $h->init_header('Host' => $hhost);
  99
 100     if ($proxy) {
 101         # Check the proxy URI's userinfo() for proxy credentials
 102         # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
 103         my $p_auth = $proxy->userinfo();
 104         if(defined $p_auth) {
 105             require URI::Escape;
 106             $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
 107                                           split(":", $p_auth, 2))
 108         }
 109     }
 110 }
 111
 112 sub hlist_remove {
 113     my($hlist, $k) = @_;
 114     $k = lc $k;
 115     for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
 116         next unless lc($hlist->[$i]) eq $k;
 117         splice(@$hlist, $i, 2);
 118     }
 119 }
 120
 121 sub request
 122 {
 123     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
 124
 125     $size ||= 4096;
 126
 127     # check method
 128     my $method = $request->method;
 129     unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
 130         return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
 131                                   'Library does not allow method ' .
 132                                   "$method for 'http:' URLs";
 133     }
 134
 135     my $url = $request->uri;
 136     my($host, $port, $fullpath);
 137
 138     # Check if we're proxy'ing
 139     if (defined $proxy) {
 140         # $proxy is an URL to an HTTP server which will proxy this request
 141         $host = $proxy->host;
 142         $port = $proxy->port;
 143         $fullpath = $method eq "CONNECT" ?
 144                        ($url->host . ":" . $url->port) :
 145                        $url->as_string;
 146     }
 147     else {
 148         $host = $url->host;
 149         $port = $url->port;
 150         $fullpath = $url->path_query;
 151         $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
 152     }
 153
 154     # connect to remote site
 155     my $socket = $self->_new_socket($host, $port, $timeout);
 156     $self->_check_sock($request, $socket);
 157
 158     my @h;
 159     my $request_headers = $request->headers->clone;
 160     $self->_fixup_header($request_headers, $url, $proxy);
 161
 162     $request_headers->scan(sub {
 163                                my($k, $v) = @_;
 164                                $k =~ s/^://;
 165                                $v =~ s/\n/ /g;
 166                                push(@h, $k, $v);
 167                            });
 168
 169     my $content_ref = $request->content_ref;
 170     $content_ref = $$content_ref if ref($$content_ref);
 171     my $chunked;
 172     my $has_content;
 173
 174     if (ref($content_ref) eq 'CODE') {
 175         my $clen = $request_headers->header('Content-Length');
 176         $has_content++ if $clen;
 177         unless (defined $clen) {
 178             push(@h, "Transfer-Encoding" => "chunked");
 179             $has_content++;
 180             $chunked++;
 181         }
 182     }
 183     else {
 184         # Set (or override) Content-Length header
 185         my $clen = $request_headers->header('Content-Length');
 186         if (defined($$content_ref) && length($$content_ref)) {
 187             $has_content = length($$content_ref);
 188             if (!defined($clen) || $clen ne $has_content) {
 189                 if (defined $clen) {
 190                     warn "Content-Length header value was wrong, fixed";
 191                     hlist_remove(\@h, 'Content-Length');
 192                 }
 193                 push(@h, 'Content-Length' => $has_content);
 194             }
 195         }
 196         elsif ($clen) {
 197             warn "Content-Length set when there is no content, fixed";
 198             hlist_remove(\@h, 'Content-Length');
 199         }
 200     }
 201
 202     my $write_wait = 0;
 203     $write_wait = 2
 204         if ($request_headers->header("Expect") || "") =~ /100-continue/;
 205
 206     my $req_buf = $socket->format_request($method, $fullpath, @h);
 207     #print "------\n$req_buf\n------\n";
 208
 209     if (!$has_content || $write_wait || $has_content > 8*1024) {
 210       WRITE:
 211         {
 212             # Since this just writes out the header block it should almost
 213             # always succeed to send the whole buffer in a single write call.
 214             my $n = $socket->syswrite($req_buf, length($req_buf));
 215             unless (defined $n) {
 216                 redo WRITE if $!{EINTR};
 217                 if ($!{EAGAIN}) {
 218                     select(undef, undef, undef, 0.1);
 219                     redo WRITE;
 220                 }
 221                 die "write failed: $!";
 222             }
 223             if ($n) {
 224                 substr($req_buf, 0, $n, "");
 225             }
 226             else {
 227                 select(undef, undef, undef, 0.5);
 228             }
 229             redo WRITE if length $req_buf;
 230         }
 231     }
 232
 233     my($code, $mess, @junk);
 234     my $drop_connection;
 235
 236     if ($has_content) {
 237         my $eof;
 238         my $wbuf;
 239         my $woffset = 0;
 240         if (ref($content_ref) eq 'CODE') {
 241             my $buf = &$content_ref();
 242             $buf = "" unless defined($buf);
 243             $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
 244                 if $chunked;
 245             substr($buf, 0, 0) = $req_buf if $req_buf;
 246             $wbuf = \$buf;
 247         }
 248         else {
 249             if ($req_buf) {
 250                 my $buf = $req_buf . $$content_ref;
 251                 $wbuf = \$buf;
 252             }
 253             else {
 254                 $wbuf = $content_ref;
 255             }
 256             $eof = 1;
 257         }
 258
 259         my $fbits = '';
 260         vec($fbits, fileno($socket), 1) = 1;
 261
 262       WRITE:
 263         while ($woffset < length($$wbuf)) {
 264
 265             my $sel_timeout = $timeout;
 266             if ($write_wait) {
 267                 $sel_timeout = $write_wait if $write_wait < $sel_timeout;
 268             }
 269             my $time_before;
 270             $time_before = time if $sel_timeout;
 271
 272             my $rbits = $fbits;
 273             my $wbits = $write_wait ? undef : $fbits;
 274             my $sel_timeout_before = $sel_timeout;
 275           SELECT:
 276             {
 277                 my $nfound = select($rbits, $wbits, undef, $sel_timeout);
 278                 if ($nfound < 0) {
 279                     if ($!{EINTR} || $!{EAGAIN}) {
 280                         if ($time_before) {
 281                             $sel_timeout = $sel_timeout_before - (time - $time_before);
 282                             $sel_timeout = 0 if $sel_timeout < 0;
 283                         }
 284                         redo SELECT;
 285                     }
 286                     die "select failed: $!";
 287                 }
 288             }
 289
 290             if ($write_wait) {
 291                 $write_wait -= time - $time_before;
 292                 $write_wait = 0 if $write_wait < 0;
 293             }
 294
 295             if (defined($rbits) && $rbits =~ /[^\0]/) {
 296                 # readable
 297                 my $buf = $socket->_rbuf;
 298                 my $n = $socket->sysread($buf, 1024, length($buf));
 299                 unless (defined $n) {
 300                     die "read failed: $!" unless  $!{EINTR} || $!{EAGAIN};
 301                     # if we get here the rest of the block will do nothing
 302                     # and we will retry the read on the next round
 303                 }
 304                 elsif ($n == 0) {
 305                     # the server closed the connection before we finished
 306                     # writing all the request content.  No need to write any more.
 307                     $drop_connection++;
 308                     last WRITE;
 309                 }
 310                 $socket->_rbuf($buf);
 311                 if (!$code && $buf =~ /\015?\012\015?\012/) {
 312                     # a whole response header is present, so we can read it without blocking
 313                     ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
 314                                                                         junk_out => \@junk,
 315                                                                        );
 316                     if ($code eq "100") {
 317                         $write_wait = 0;
 318                         undef($code);
 319                     }
 320                     else {
 321                         $drop_connection++;
 322                         last WRITE;
 323                         # XXX should perhaps try to abort write in a nice way too
 324                     }
 325                 }
 326             }
 327             if (defined($wbits) && $wbits =~ /[^\0]/) {
 328                 my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
 329                 unless (defined $n) {
 330                     die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
 331                     $n = 0;  # will retry write on the next round
 332                 }
 333                 elsif ($n == 0) {
 334                     die "write failed: no bytes written";
 335                 }
 336                 $woffset += $n;
 337
 338                 if (!$eof && $woffset >= length($$wbuf)) {
 339                     # need to refill buffer from $content_ref code
 340                     my $buf = &$content_ref();
 341                     $buf = "" unless defined($buf);
 342                     $eof++ unless length($buf);
 343                     $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
 344                         if $chunked;
 345                     $wbuf = \$buf;
 346                     $woffset = 0;
 347                 }
 348             }
 349         } # WRITE
 350     }
 351
 352     ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
 353         unless $code;
 354     ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
 355         if $code eq "100";
 356
 357     my $response = HTTP::Response->new($code, $mess);
 358     my $peer_http_version = $socket->peer_http_version;
 359     $response->protocol("HTTP/$peer_http_version");
 360     {
 361         local $HTTP::Headers::TRANSLATE_UNDERSCORE;
 362         $response->push_header(@h);
 363     }
 364     $response->push_header("Client-Junk" => \@junk) if @junk;
 365
 366     $response->request($request);
 367     $self->_get_sock_info($response, $socket);
 368
 369     if ($method eq "CONNECT") {
 370         $response->{client_socket} = $socket;  # so it can be picked up
 371         return $response;
 372     }
 373
 374     if (my @te = $response->remove_header('Transfer-Encoding')) {
 375         $response->push_header('Client-Transfer-Encoding', \@te);
 376     }
 377     $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
 378
 379     my $complete;
 380     $response = $self->collect($arg, $response, sub {
 381         my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
 382         my $n;
 383       READ:
 384         {
 385             $n = $socket->read_entity_body($buf, $size);
 386             unless (defined $n) {
 387                 redo READ if $!{EINTR} || $!{EAGAIN};
 388                 die "read failed: $!";
 389             }
 390             redo READ if $n == -1;
 391         }
 392         $complete++ if !$n;
 393         return \$buf;
 394     } );
 395     $drop_connection++ unless $complete;
 396
 397     @h = $socket->get_trailers;
 398     if (@h) {
 399         local $HTTP::Headers::TRANSLATE_UNDERSCORE;
 400         $response->push_header(@h);
 401     }
 402
 403     # keep-alive support
 404     unless ($drop_connection) {
 405         if (my $conn_cache = $self->{ua}{conn_cache}) {
 406             my %connection = map { (lc($_) => 1) }
 407                              split(/\s*,\s*/, ($response->header("Connection") || ""));
 408             if (($peer_http_version eq "1.1" && !$connection{close}) ||
 409                 $connection{"keep-alive"})
 410             {
 411                 $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
 412             }
 413         }
 414     }
 415
 416     $response;
 417 }
 418
 419
 420 #-----------------------------------------------------------
 421 package LWP::Protocol::http::SocketMethods;
 422
 423 sub sysread {
 424     my $self = shift;
 425     if (my $timeout = ${*$self}{io_socket_timeout}) {
 426         die "read timeout" unless $self->can_read($timeout);
 427     }
 428     else {
 429         # since we have made the socket non-blocking we
 430         # use select to wait for some data to arrive
 431         $self->can_read(undef) || die "Assert";
 432     }
 433     sysread($self, $_[0], $_[1], $_[2] || 0);
 434 }
 435
 436 sub can_read {
 437     my($self, $timeout) = @_;
 438     my $fbits = '';
 439     vec($fbits, fileno($self), 1) = 1;
 440   SELECT:
 441     {
 442         my $before;
 443         $before = time if $timeout;
 444         my $nfound = select($fbits, undef, undef, $timeout);
 445         if ($nfound < 0) {
 446             if ($!{EINTR} || $!{EAGAIN}) {
 447                 # don't really think EAGAIN can happen here
 448                 if ($timeout) {
 449                     $timeout -= time - $before;
 450                     $timeout = 0 if $timeout < 0;
 451                 }
 452                 redo SELECT;
 453             }
 454             die "select failed: $!";
 455         }
 456         return $nfound > 0;
 457     }
 458 }
 459
 460 sub ping {
 461     my $self = shift;
 462     !$self->can_read(0);
 463 }
 464
 465 sub increment_response_count {
 466     my $self = shift;
 467     return ++${*$self}{'myhttp_response_count'};
 468 }
 469
 470 #-----------------------------------------------------------
 471 package LWP::Protocol::http::Socket;
 472 use vars qw(@ISA);
 473 @ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
 474
 475 1;