1 package LWP::Protocol::http;
6 require HTTP::Response;
10 use vars qw(@ISA @EXTRA_SOCK_OPTS);
12 require LWP::Protocol;
13 @ISA = qw(LWP::Protocol);
15 my $CRLF = "\015\012";
19 my($self, $host, $port, $timeout) = @_;
20 my $conn_cache = $self->{ua}{conn_cache};
22 if (my $sock = $conn_cache->withdraw("http", "$host:$port")) {
23 return $sock if $sock && !$sock->can_read(0);
24 # if the socket is readable, then either the peer has closed the
25 # connection or there are some garbage bytes on it. In either
31 local($^W) = 0; # IO::Socket::INET can be noisy
32 my $sock = $self->socket_class->new(PeerAddr => $host,
36 KeepAlive => !!$conn_cache,
38 $self->_extra_sock_opts($host, $port),
42 # IO::Socket::INET leaves additional error messages in $@
44 die "Can't connect to $host:$port ($@)";
47 # perl 5.005's IO::Socket does not have the blocking method.
48 eval { $sock->blocking(0); };
56 (ref($self) || $self) . "::Socket";
59 sub _extra_sock_opts # to be overridden by subclass
61 return @EXTRA_SOCK_OPTS;
66 #my($self, $req, $sock) = @_;
71 my($self, $res, $sock) = @_;
72 if (defined(my $peerhost = $sock->peerhost)) {
73 $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
79 my($self, $h, $url, $proxy) = @_;
81 # Extract 'Host' header
82 my $hhost = $url->authority;
83 if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
84 # add authorization header if we need them. HTTP URLs do
85 # not really support specification of user and password, but
87 if (defined($1) && not $h->header('Authorization')) {
89 $h->authorization_basic(map URI::Escape::uri_unescape($_),
93 $h->init_header('Host' => $hhost);
96 # Check the proxy URI's userinfo() for proxy credentials
97 # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
98 my $p_auth = $proxy->userinfo();
101 $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
102 split(":", $p_auth, 2))
110 for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
111 next unless lc($hlist->[$i]) eq $k;
112 splice(@$hlist, $i, 2);
118 my($self, $request, $proxy, $arg, $size, $timeout) = @_;
119 LWP::Debug::trace('()');
124 my $method = $request->method;
125 unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
126 return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
127 'Library does not allow method ' .
128 "$method for 'http:' URLs";
131 my $url = $request->url;
132 my($host, $port, $fullpath);
134 # Check if we're proxy'ing
135 if (defined $proxy) {
136 # $proxy is an URL to an HTTP server which will proxy this request
137 $host = $proxy->host;
138 $port = $proxy->port;
139 $fullpath = $method eq "CONNECT" ?
140 ($url->host . ":" . $url->port) :
146 $fullpath = $url->path_query;
147 $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
150 # connect to remote site
151 my $socket = $self->_new_socket($host, $port, $timeout);
152 $self->_check_sock($request, $socket);
155 my $request_headers = $request->headers->clone;
156 $self->_fixup_header($request_headers, $url, $proxy);
158 $request_headers->scan(sub {
165 my $content_ref = $request->content_ref;
166 $content_ref = $$content_ref if ref($$content_ref);
170 if (ref($content_ref) eq 'CODE') {
171 my $clen = $request_headers->header('Content-Length');
172 $has_content++ if $clen;
173 unless (defined $clen) {
174 push(@h, "Transfer-Encoding" => "chunked");
180 # Set (or override) Content-Length header
181 my $clen = $request_headers->header('Content-Length');
182 if (defined($$content_ref) && length($$content_ref)) {
183 $has_content = length($$content_ref);
184 if (!defined($clen) || $clen ne $has_content) {
186 warn "Content-Length header value was wrong, fixed";
187 hlist_remove(\@h, 'Content-Length');
189 push(@h, 'Content-Length' => $has_content);
193 warn "Content-Length set when there is no content, fixed";
194 hlist_remove(\@h, 'Content-Length');
200 if ($request_headers->header("Expect") || "") =~ /100-continue/;
202 my $req_buf = $socket->format_request($method, $fullpath, @h);
203 #print "------\n$req_buf\n------\n";
205 if (!$has_content || $write_wait || $has_content > 8*1024) {
207 # Since this just writes out the header block it should almost
208 # always succeed to send the whole buffer in a single write call.
209 my $n = $socket->syswrite($req_buf, length($req_buf));
210 unless (defined $n) {
213 select(undef, undef, undef, 0.1);
216 die "write failed: $!";
219 substr($req_buf, 0, $n, "");
222 select(undef, undef, undef, 0.5);
225 while (length $req_buf);
228 my($code, $mess, @junk);
235 if (ref($content_ref) eq 'CODE') {
236 my $buf = &$content_ref();
237 $buf = "" unless defined($buf);
238 $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
240 substr($buf, 0, 0) = $req_buf if $req_buf;
245 my $buf = $req_buf . $$content_ref;
249 $wbuf = $content_ref;
255 vec($fbits, fileno($socket), 1) = 1;
258 while ($woffset < length($$wbuf)) {
260 my $sel_timeout = $timeout;
262 $sel_timeout = $write_wait if $write_wait < $sel_timeout;
265 $time_before = time if $sel_timeout;
268 my $wbits = $write_wait ? undef : $fbits;
269 my $sel_timeout_before = $sel_timeout;
272 my $nfound = select($rbits, $wbits, undef, $sel_timeout);
273 unless (defined $nfound) {
274 if ($!{EINTR} || $!{EAGAIN}) {
276 $sel_timeout = $sel_timeout_before - (time - $time_before);
277 $sel_timeout = 0 if $sel_timeout < 0;
281 die "select failed: $!";
286 $write_wait -= time - $time_before;
287 $write_wait = 0 if $write_wait < 0;
290 if (defined($rbits) && $rbits =~ /[^\0]/) {
292 my $buf = $socket->_rbuf;
293 my $n = $socket->sysread($buf, 1024, length($buf));
294 unless (defined $n) {
295 die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
296 # if we get here the rest of the block will do nothing
297 # and we will retry the read on the next round
300 # the server closed the connection before we finished
301 # writing all the request content. No need to write any more.
305 $socket->_rbuf($buf);
306 if (!$code && $buf =~ /\015?\012\015?\012/) {
307 # a whole response header is present, so we can read it without blocking
308 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
311 if ($code eq "100") {
318 # XXX should perhaps try to abort write in a nice way too
322 if (defined($wbits) && $wbits =~ /[^\0]/) {
323 my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
324 unless (defined $n) {
325 die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
326 $n = 0; # will retry write on the next round
329 die "write failed: no bytes written";
333 if (!$eof && $woffset >= length($$wbuf)) {
334 # need to refill buffer from $content_ref code
335 my $buf = &$content_ref();
336 $buf = "" unless defined($buf);
337 $eof++ unless length($buf);
338 $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
347 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
349 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
352 my $response = HTTP::Response->new($code, $mess);
353 my $peer_http_version = $socket->peer_http_version;
354 $response->protocol("HTTP/$peer_http_version");
356 my($k, $v) = splice(@h, 0, 2);
357 $response->push_header($k, $v);
359 $response->push_header("Client-Junk" => \@junk) if @junk;
361 $response->request($request);
362 $self->_get_sock_info($response, $socket);
364 if ($method eq "CONNECT") {
365 $response->{client_socket} = $socket; # so it can be picked up
369 if (my @te = $response->remove_header('Transfer-Encoding')) {
370 $response->push_header('Client-Transfer-Encoding', \@te);
372 $response->push_header('Client-Response-Num', $socket->increment_response_count);
375 $response = $self->collect($arg, $response, sub {
376 my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
380 $n = $socket->read_entity_body($buf, $size);
381 unless (defined $n) {
382 redo READ if $!{EINTR} || $!{EAGAIN};
383 die "read failed: $!";
385 redo READ if $n == -1;
390 $drop_connection++ unless $complete;
392 @h = $socket->get_trailers;
394 my($k, $v) = splice(@h, 0, 2);
395 $response->push_header($k, $v);
399 unless ($drop_connection) {
400 if (my $conn_cache = $self->{ua}{conn_cache}) {
401 my %connection = map { (lc($_) => 1) }
402 split(/\s*,\s*/, ($response->header("Connection") || ""));
403 if (($peer_http_version eq "1.1" && !$connection{close}) ||
404 $connection{"keep-alive"})
406 LWP::Debug::debug("Keep the http connection to $host:$port");
407 $conn_cache->deposit("http", "$host:$port", $socket);
416 #-----------------------------------------------------------
417 package LWP::Protocol::http::SocketMethods;
421 if (my $timeout = ${*$self}{io_socket_timeout}) {
422 die "read timeout" unless $self->can_read($timeout);
425 # since we have made the socket non-blocking we
426 # use select to wait for some data to arrive
427 $self->can_read(undef) || die "Assert";
429 sysread($self, $_[0], $_[1], $_[2] || 0);
433 my($self, $timeout) = @_;
435 vec($fbits, fileno($self), 1) = 1;
439 $before = time if $timeout;
440 my $nfound = select($fbits, undef, undef, $timeout);
441 unless (defined $nfound) {
442 if ($!{EINTR} || $!{EAGAIN}) {
443 # don't really think EAGAIN can happen here
445 $timeout -= time - $before;
446 $timeout = 0 if $timeout < 0;
450 die "select failed: $!";
461 sub increment_response_count {
463 return ++${*$self}{'myhttp_response_count'};
466 #-----------------------------------------------------------
467 package LWP::Protocol::http::Socket;
469 @ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);