# # $Id: http.pm,v 1.50 2000/05/24 09:41:13 gisle Exp $ package LWP::Protocol::http; use strict; require LWP::Debug; require HTTP::Response; require HTTP::Status; require IO::Socket; require IO::Select; use vars qw(@ISA @EXTRA_SOCK_OPTS); require LWP::Protocol; @ISA = qw(LWP::Protocol); my $CRLF = "\015\012"; # how lines should be terminated; # "\r\n" is not correct on all systems, for # instance MacPerl defines it to "\012\015" sub _new_socket { my($self, $host, $port, $timeout) = @_; local($^W) = 0; # IO::Socket::INET can be noisy my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port, Proto => 'tcp', Timeout => $timeout, $self->_extra_sock_opts($host, $port), ); unless ($sock) { # IO::Socket::INET leaves additional error messages in $@ $@ =~ s/^.*?: //; die "Can't connect to $host:$port ($@)"; } $sock; } sub _extra_sock_opts # to be overridden by subclass { return @EXTRA_SOCK_OPTS; } sub _check_sock { #my($self, $req, $sock) = @_; } sub _get_sock_info { my($self, $res, $sock) = @_; if (defined(my $peerhost = $sock->peerhost)) { $res->header("Client-Peer" => "$peerhost:" . $sock->peerport); } } sub _fixup_header { my($self, $h, $url) = @_; $h->remove_header('Connection'); # need support here to be useful # HTTP/1.1 will require us to send the 'Host' header, so we might # as well start now. my $hhost = $url->authority; $hhost =~ s/^([^\@]*)\@//; # get rid of potential "user:pass@" $h->header('Host' => $hhost) unless defined $h->header('Host'); # add authorization header if we need them. HTTP URLs do # not really support specification of user and password, but # we allow it. if (defined($1) && not $h->header('Authorization')) { require URI::Escape; $h->authorization_basic(map URI::Escape::uri_unescape($_), split(":", $1)); } } sub request { my($self, $request, $proxy, $arg, $size, $timeout) = @_; LWP::Debug::trace('()'); $size ||= 4096; # check method my $method = $request->method; unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'http:' URLs"; } my $url = $request->url; my($host, $port, $fullpath); # Check if we're proxy'ing if (defined $proxy) { # $proxy is an URL to an HTTP server which will proxy this request $host = $proxy->host; $port = $proxy->port; $fullpath = $method eq "CONNECT" ? ($url->host . ":" . $url->port) : $url->as_string; } else { $host = $url->host; $port = $url->port; $fullpath = $url->path_query; $fullpath = "/" unless length $fullpath; } # connect to remote site my $socket = $self->_new_socket($host, $port, $timeout); $self->_check_sock($request, $socket); my $sel = IO::Select->new($socket) if $timeout; my $request_line = "$method $fullpath HTTP/1.0$CRLF"; my $h = $request->headers->clone; my $cont_ref = $request->content_ref; $cont_ref = $$cont_ref if ref($$cont_ref); my $ctype = ref($cont_ref); # If we're sending content we *have* to specify a content length # otherwise the server won't know a messagebody is coming. if ($ctype eq 'CODE') { die 'No Content-Length header for request with dynamic content' unless defined($h->header('Content-Length')) || $h->content_type =~ /^multipart\//; # For HTTP/1.1 we could have used chunked transfer encoding... } else { $h->header('Content-Length' => length $$cont_ref) if defined($$cont_ref) && length($$cont_ref); } $self->_fixup_header($h, $url); my $buf = $request_line . $h->as_string($CRLF) . $CRLF; my $n; # used for return value from syswrite/sysread die "write timeout" if $timeout && !$sel->can_write($timeout); $n = $socket->syswrite($buf, length($buf)); die $! unless defined($n); die "short write" unless $n == length($buf); LWP::Debug::conns($buf); if ($ctype eq 'CODE') { while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) { die "write timeout" if $timeout && !$sel->can_write($timeout); $n = $socket->syswrite($buf, length($buf)); die $! unless defined($n); die "short write" unless $n == length($buf); LWP::Debug::conns($buf); } } elsif (defined($$cont_ref) && length($$cont_ref)) { die "write timeout" if $timeout && !$sel->can_write($timeout); $n = $socket->syswrite($$cont_ref, length($$cont_ref)); die $! unless defined($n); die "short write" unless $n == length($$cont_ref); LWP::Debug::conns($buf); } # read response line from server LWP::Debug::debug('reading response'); my $response; $buf = ''; # Inside this loop we will read the response line and all headers # found in the response. while (1) { die "read timeout" if $timeout && !$sel->can_read($timeout); $n = $socket->sysread($buf, $size, length($buf)); die $! unless defined($n); die "unexpected EOF before status line seen" unless $n; LWP::Debug::conns($buf); if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) { # HTTP/1.0 response or better my($ver,$code,$msg) = ($1, $2, $3); $msg =~ s/\015$//; LWP::Debug::debug("$ver $code $msg"); $response = HTTP::Response->new($code, $msg); $response->protocol($ver); # ensure that we have read all headers. The headers will be # terminated by two blank lines until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) { # must read more if we can... LWP::Debug::debug("need more header data"); die "read timeout" if $timeout && !$sel->can_read($timeout); $n = $socket->sysread($buf, $size, length($buf)); die $! unless defined($n); die "unexpected EOF before all headers seen" unless $n; #LWP::Debug::conns($buf); } # now we start parsing the headers. The strategy is to # remove one line at a time from the beginning of the header # buffer ($res). my($key, $val); while ($buf =~ s/([^\012]*)\012//) { my $line = $1; # if we need to restore as content when illegal headers # are found. my $save = "$line\012"; $line =~ s/\015$//; last unless length $line; if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) { $response->push_header($key, $val) if $key; ($key, $val) = ($1, $2); } elsif ($line =~ /^\s+(.*)/ && $key) { $val .= " $1"; } else { $response->push_header("Client-Bad-Header-Line" => $line); } } $response->push_header($key, $val) if $key; last; } elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or $buf =~ /\012/ ) { # HTTP/0.9 or worse LWP::Debug::debug("HTTP/0.9 assume OK"); $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); $response->protocol('HTTP/0.9'); last; } else { # need more data LWP::Debug::debug("need more status line data"); } }; $response->request($request); $self->_get_sock_info($response, $socket); if ($method eq "CONNECT") { $response->{client_socket} = $socket; # so it can be picked up $response->content($buf); # in case we read more than the headers return $response; } my $usebuf = length($buf) > 0; $response = $self->collect($arg, $response, sub { if ($usebuf) { $usebuf = 0; return \$buf; } die "read timeout" if $timeout && !$sel->can_read($timeout); my $n = $socket->sysread($buf, $size); die $! unless defined($n); #LWP::Debug::conns($buf); return \$buf; } ); #$socket->close; $response; } 1;