*** /usr/lib/perl5/site_perl/5.005/LWP/Protocol/http.pm Fri Mar 19 17:03:10 1999 --- LWP/Protocol/http.pm Tue Nov 2 02:09:20 1999 *************** *** 1,5 **** # ! # $Id: http.pm,v 1.46 1999/03/19 22:03:10 gisle Exp $ package LWP::Protocol::http; --- 1,5 ---- # ! # $Id: http.pm,v 1.2 1999/11/02 07:09:20 sgifford Exp $ package LWP::Protocol::http; *************** *** 20,37 **** 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, ! ); unless ($sock) { # IO::Socket::INET leaves additional error messages in $@ $@ =~ s/^.*?: //; die "Can't connect to $host:$port ($@)"; } $sock; } --- 20,58 ---- sub _new_socket { my($self, $host, $port, $timeout) = @_; ! my($sock); ! ! if ($self->connection_cache_active()) ! { ! if (defined($sock=$self->connection_cache_get($host,$port))) ! { ! # Make an effort to make sure the connection is still there. ! unless (IO::Select->new($sock)->has_exception(0)) ! { ! LWP::Debug::debug("Using kept-alive connection to $host:$port"); ! $self->{socket_from_cache}=1; ! return $sock; ! } ! &LWP::Debug::debug("Exception occured on kept-alive connection to $host:$port; closing cached socket."); ! } ! } ! $self->{socket_from_cache}=undef; local($^W) = 0; # IO::Socket::INET can be noisy ! $sock = IO::Socket::INET->new(PeerAddr => $host, ! PeerPort => $port, ! Proto => 'tcp', ! Timeout => $timeout, ! ); unless ($sock) { # IO::Socket::INET leaves additional error messages in $@ $@ =~ s/^.*?: //; die "Can't connect to $host:$port ($@)"; } + if ($self->connection_cache_active()) + { + $self->connection_cache_add($host,$port,$sock); + LWP::Debug::debug("Caching socket at $host:$port"); + } $sock; } *************** *** 48,53 **** --- 69,111 ---- $sock->peerhost . ":" . $sock->peerport); } + sub connection_cache + { + my($self,$pCache)=@_; + + LWP::Debug::debug("Activating connection cache for http"); + $self->{connection_cache}=$pCache; + } + + sub connection_cache_add + { + my($self,$host,$port,$sock)=@_; + my($lcHost,$lcPort)=(lc $host, lc $port); + + $self->{connection_cache}{"$lcHost:$lcPort"}=$sock; + } + + sub connection_cache_del + { + my($self,$host,$port)=@_; + my($lcHost,$lcPort)=(lc $host, lc $port); + + delete $self->{connection_cache}{"$lcHost:$lcPort"}; + } + + sub connection_cache_get + { + my($self,$host,$port)=@_; + my($lcHost,$lcPort)=(lc $host, lc $port); + + return $self->{connection_cache}{"$lcHost:$lcPort"}; + } + + sub connection_cache_active + { + my($self)=@_; + return (defined($self->{connection_cache})); + } sub request { *************** *** 81,92 **** $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; --- 139,144 ---- *************** *** 112,117 **** --- 164,176 ---- $hhost =~ s/^([^\@]*)\@//; # get rid of potential "user:pass@" $h->header('Host' => $hhost) unless defined $h->header('Host'); + # If we're caching connections, ask the server not to shut + # down the connection. + if ($self->connection_cache_active()) + { + $h->header('Connection','Keep-Alive'); + } + # add authorization header if we need them. HTTP URLs do # not really support specification of user and password, but # we allow it. *************** *** 119,251 **** $h->authorization_basic(split(":", $1)); } ! 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+(.*)/) { ! unless ($key) { ! $response->header("Client-Warning" => ! => "Illegal continuation header"); ! $buf = "$save$buf"; ! last; } ! $val .= " $1"; ! } else { ! $response->header("Client-Warning" => ! "Illegal header '$line'"); ! $buf = "$save$buf"; last; ! } } - $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); 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; } --- 178,382 ---- $h->authorization_basic(split(":", $1)); } ! # connect to remote site ! my($socket,$sel,$buf); my $n; # used for return value from syswrite/sysread ! my $response; ! SENDREQ: { ! eval { ! $socket = $self->_new_socket($host, $port, $timeout); ! $self->_check_sock($request, $socket); ! ! $sel = IO::Select->new($socket) if $timeout; ! ! $buf = $request_line . $h->as_string($CRLF) . $CRLF; ! 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'); ! $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). ! ! # Now we've written a line, and read a line; ! # we're pretty sure the connection is up. ! # Disable the special-case for cached connections. ! # --sg ! if (defined($self->{socket_from_cache})) ! { ! delete $self->{socket_from_cache}; } ! ! 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+(.*)/) { ! unless ($key) { ! $response->header("Client-Warning" => ! "Illegal continuation header"); ! $buf = "$save$buf"; ! last; ! } ! $val .= " $1"; ! } else { ! $response->header("Client-Warning" => ! "Illegal header '$line'"); ! $buf = "$save$buf"; ! last; ! } ! } ! $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"); ! } ! }; ! }; # end eval ! if ($@) ! { ! if (defined($self->{socket_from_cache})) ! { ! LWP::Debug::debug("Error on cached connection: '$@'. Trying again with new connection."); ! undef $socket; ! $self->connection_cache_del($host,$port); ! redo SENDREQ; ! } ! else ! { ! die $@; } } ! } # end SENDREQ block ! $response->request($request); $self->_get_sock_info($response, $socket); my $usebuf = length($buf) > 0; + my $clen=0; + if ($self->connection_cache_active()) + { + $clen=$response->header("Content-Length"); + } + my $curlen=0; + + if ($response->header("Connection") !~ /\bkeep-alive\b/i) + { + LWP::Debug::debug("Server requested connection be closed"); + if ($self->connection_cache_get($host,$port)) + { + $self->connection_cache_delete($host,$port); + } + $clen=0; + } + + if ($clen) + { + LWP::Debug::debug("Content-Length is $clen bytes"); + } $response = $self->collect($arg, $response, sub { if ($usebuf) { $usebuf = 0; + $curlen += length($buf); return \$buf; } + if ($clen) + { + if (($curlen == $clen)) + { + return undef; + } + } die "read timeout" if $timeout && !$sel->can_read($timeout); my $n = $socket->sysread($buf, $size); die $! unless defined($n); + $curlen += $n; #LWP::Debug::conns($buf); return \$buf; } ); ! # Don't close it -- just let it go out of scope. If it's being ! # cached, it will be referenced elsewhere, so won't be destroyed. ! ! # --sg ! # $socket->close; $response; } *** /usr/lib/perl5/site_perl/5.005/LWP/UserAgent.pm Mon Aug 2 18:57:09 1999 --- LWP/UserAgent.pm Tue Nov 2 01:40:36 1999 *************** *** 131,136 **** --- 131,137 ---- 'parse_head' => 1, 'max_size' => undef, 'no_proxy' => [], + 'connection_cache' => undef, }, $class; } } *************** *** 172,178 **** LWP::Debug::trace("$method $url"); ! # Locate protocol to use my $scheme = ''; my $proxy = $self->_need_proxy($url); --- 173,179 ---- LWP::Debug::trace("$method $url"); ! # Locate protocol to use my $scheme = ''; my $proxy = $self->_need_proxy($url); *************** *** 189,194 **** --- 190,197 ---- $@ =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//; # remove file/line number return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, $@) } + + LWP::Debug::debug("Got protocol object at $protocol"); # Extract fields that will be used below my ($agent, $from, $timeout, $cookie_jar, *************** *** 206,211 **** --- 209,226 ---- $protocol->parse_head($parse_head); $protocol->max_size($max_size); + if (defined($self->{connection_cache})) + { + eval { + $protocol->connection_cache($self->{connection_cache}); + }; + if ($@) + { + warn("Tried to use connection caching with protocol that does not support it.\n"); + } + LWP::Debug::debug("Configured connection_cache for protocol"); + } + my $response; if ($use_eval) { # we eval, and turn dies into responses below *************** *** 231,236 **** --- 246,264 ---- return $response; } + # Debugging function. + sub dump_connection_cache + { + my ($self)=@_; + + my $i; + + print "Dumping connection cache (=$self->{connection_cache})\n"; + foreach $i (keys %{$self->{connection_cache}}) + { + print "Have connection to $i\n"; + } + } =item $ua->request($request, $arg [, $size]) *************** *** 468,473 **** --- 496,531 ---- sub parse_head { shift->_elem('parse_head',@_); } sub max_size { shift->_elem('max_size', @_); } + =item $ua->connection_cache([$boolean]) + + Get/set a value indicating whether we should try to cache connections + between requests. If this is activated, HTTP sockets won't be closed + after a request is completed, but will be stored as part of the + UserAgent. If, later on, we try to connect to the same host and port, + this connection will be reused. + + If you pass a value to this function, all open connections will be + closed. + + =cut + + sub connection_cache { + my($self,$setting)=@_; + + if (defined($setting)) + { + if ($setting) + { + $self->{connection_cache} = {}; + } + else + { + $self->{connection_cache} = undef; + } + } + return defined($self->{connection_cache}); + } + # depreciated sub use_eval { shift->_elem('use_eval', @_); } sub use_alarm