See attached MyHTTP.pm implementation & HTTP_response.pl for an (incomplete) example of how to retrieve the response time values it captures.
On 19 Sep 2003 06:40:18 -0700, Gisle Aas wrote:
>
> Simon Wistow <[EMAIL PROTECTED]> writes:
>
> > Is there an easy way to get the time taken to
connect
> and the time taken
> > to respond to an HTTP request or am I going to have
> to go in and hack
> > around?
>
> There is no direct way to do it currently. You might
> be able to just
> make your own subclass of LWP::Protocol::http that
does
> what you want.
> You then need to register it as the HTTP handler
module
> with:
>
> LWP::Protocol::implementor('http', 'MyHTTP');
>
> given that you called your LWP::Protocol::http
subclass
> MyHTTP.
>
> Regards,
> Gisle
HTTP_response.pl
Description: Binary data
# $Id: http.pm,v 1.64 2002/09/20 14:53:30 gisle Exp $
#
package LWP::Protocol::http;
use strict;
require LWP::Debug;
require HTTP::Response;
require HTTP::Status;
require Net::HTTP;
use Time::HiRes qw(gettimeofday tv_interval);
use vars qw(@ISA @EXTRA_SOCK_OPTS);
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
my $CRLF = "\015\012";
sub _new_socket
{
my($self, $host, $port, $timeout) = @_;
my $conn_cache = $self->{ua}{conn_cache};
if ($conn_cache) {
if (my $sock = $conn_cache->withdraw("http", "$host:$port")) {
return $sock if $sock && !$sock->can_read(0);
# if the socket is readable, then either the peer has closed the
# connection or there are some garbage bytes on it. In either
# case we abandon it.
$sock->close;
}
}
local($^W) = 0; # IO::Socket::INET can be noisy
my $sock = $self->socket_class->new(PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
Timeout => $timeout,
KeepAlive => !!$conn_cache,
SendTE => 1,
$self->_extra_sock_opts($host, $port),
);
unless ($sock) {
# IO::Socket::INET leaves additional error messages in $@
$@ =~ s/^.*?: //;
die "Can't connect to $host:$port ($@)";
}
# perl 5.005's IO::Socket does not have the blocking method.
eval { $sock->blocking(0); };
$sock;
}
sub socket_class
{
my $self = shift;
(ref($self) || $self) . "::Socket";
}
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, $proxy) = @_;
# Extract 'Host' header
my $hhost = $url->authority;
$hhost =~ s/^([EMAIL PROTECTED])\@//; # get rid of potential "user:pass@"
$h->init_header('Host' => $hhost);
# 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, 2));
}
if ($proxy) {
# Check the proxy URI's userinfo() for proxy credentials
# export http_proxy="http://proxyuser:[EMAIL PROTECTED]:port"
my $p_auth = $proxy->userinfo();
if(defined $p_auth) {
require URI::Escape;
$h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
split(":", $p_auth, 2))
}
}
}
sub hlist_remove {
my($hlist, $k) = @_;
$k = lc $k;
for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
next unless lc($hlist->[$i]) eq $k;
splice(@$hlist, $i, 2);
}
}
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;
}
my $prev_time = [gettimeofday];
my $this_time;
# connect to remote site
my $socket = $self->_new_socket($host, $port, $timeout);
$self->_check_sock($request, $socket);
$this_time = [gettimeofday];
my @h;
my $request_headers = $request->headers->clone;
$self->_fixup_header($request_headers, $url, $proxy);
$request_headers->scan(sub {
my($k, $v) = @_;
$v =~ s/\n/ /g;
push(@h, $k, $v);
});
my $content_ref = $request->content_ref;
$content_ref = $$content_ref if ref($$content_ref);
my $chunked;
my $has_content;
if (ref($content_ref) eq 'CODE') {
my $clen = $request_headers->header('Content-Length');
$has_content++ if $clen;
unless (defined $clen) {
push(@h, "Transfer-Encoding" => "chunked");
$has_content++;
$chunked++;
}
} else {
# Set (or override) Content-Length header
my $clen = $request_headers->header('Content-Length');
if (defined($$content_ref) && length($$content_ref)) {
$has_content++;
if (!defined($clen) || $clen ne length($$content_ref)) {
if (defined $clen) {
warn "Content-Length header value was wrong, fixed";
hlist_remove([EMAIL PROTECTED], 'Content-Length');
}
push(@h, 'Content-Length' => length($$content_ref));
}
}
elsif ($clen) {
warn "Content-Length set when there is not content, fixed";
hlist_remove([EMAIL PROTECTED], 'Content-Length');
}
}
my $req_buf = $socket->format_request($method, $fullpath, @h);
#print "------\n$req_buf\n------\n";
# XXX need to watch out for write timeouts
{
my $n = $socket->syswrite($req_buf, length($req_buf));
die $! unless defined($n);
die "short write" unless $n == length($req_buf);
#LWP::Debug::conns($req_buf);
}
my($code, $mess, @junk);
my $drop_connection;
if ($has_content) {
my $write_wait = 0;
$write_wait = 2
if ($request_headers->header("Expect") || "") =~ /100-continue/;
my $eof;
my $wbuf;
my $woffset = 0;
if (ref($content_ref) eq 'CODE') {
my $buf = &$content_ref();
$buf = "" unless defined($buf);
$buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
if $chunked;
$wbuf = \$buf;
}
else {
$wbuf = $content_ref;
$eof = 1;
}
my $fbits = '';
vec($fbits, fileno($socket), 1) = 1;
while ($woffset < length($$wbuf)) {
my $time_before;
my $sel_timeout = $timeout;
if ($write_wait) {
$time_before = time;
$sel_timeout = $write_wait if $write_wait < $sel_timeout;
}
my $rbits = $fbits;
my $wbits = $write_wait ? undef : $fbits;
my $nfound = select($rbits, $wbits, undef, $sel_timeout);
unless (defined $nfound) {
die "select failed: $!";
}
if ($write_wait) {
$write_wait -= time - $time_before;
$write_wait = 0 if $write_wait < 0;
}
if (defined($rbits) && $rbits =~ /[^\0]/) {
# readable
my $buf = $socket->_rbuf;
my $n = $socket->sysread($buf, 1024, length($buf));
unless ($n) {
die "EOF";
}
$socket->_rbuf($buf);
if ($buf =~ /\015?\012\015?\012/) {
# a whole response present
($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
junk_out =>
[EMAIL PROTECTED],
);
if ($code eq "100") {
$write_wait = 0;
undef($code);
}
else {
$drop_connection++;
last;
# XXX should perhaps try to abort write in a nice way too
}
}
}
if (defined($wbits) && $wbits =~ /[^\0]/) {
my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
unless ($n) {
die "syswrite: $!" unless defined $n;
die "syswrite: no bytes written";
}
$woffset += $n;
if (!$eof && $woffset >= length($$wbuf)) {
# need to refill buffer from $content_ref code
my $buf = &$content_ref();
$buf = "" unless defined($buf);
$eof++ unless length($buf);
$buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
if $chunked;
$wbuf = \$buf;
$woffset = 0;
}
}
}
}
($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => [EMAIL
PROTECTED])
unless $code;
($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => [EMAIL
PROTECTED])
if $code eq "100";
my $response = HTTP::Response->new($code, $mess);
my $peer_http_version = $socket->peer_http_version;
$response->protocol("HTTP/$peer_http_version");
while (@h) {
my($k, $v) = splice(@h, 0, 2);
$response->push_header($k, $v);
}
$response->push_header("Client-Junk" => [EMAIL PROTECTED]) if @junk;
# store the leftover info from the connect (had to wait until we had a response. .
.)
$response->push_header('X-Request-Connect-Time', tv_interval($prev_time,
$this_time));
$prev_time = $this_time;
$this_time = [gettimeofday];
$response->push_header('X-Request-Transmit-Time', tv_interval($prev_time,
$this_time));
$prev_time = $this_time;
$response->request($request);
$self->_get_sock_info($response, $socket);
if ($method eq "CONNECT") {
$response->{client_socket} = $socket; # so it can be picked up
return $response;
}
if (my @te = $response->remove_header('Transfer-Encoding')) {
$response->push_header('Client-Transfer-Encoding', [EMAIL PROTECTED]);
}
$response->push_header('Client-Response-Num', $socket->increment_response_count);
my $server_time;
my $complete;
$response = $self->collect($arg, $response, sub {
my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
my $n;
READ:
{
$n = $socket->read_entity_body($buf, $size);
die "Can't read entity body: $!" unless defined $n;
if (! $response->header('X-Response-Server-Time') ) {
$this_time = [gettimeofday];
$response->push_header('X-Response-Server-Time',
tv_interval($prev_time, $this_time));
$prev_time = $this_time;
}
redo READ if $n == -1;
}
$complete++ if !$n;
return \$buf;
} );
$this_time = [gettimeofday];
$response->push_header('X-Response-Receive-Time', tv_interval($prev_time,
$this_time));
#$prev_time = $this_time;
$drop_connection++ unless $complete;
@h = $socket->get_trailers;
while (@h) {
my($k, $v) = splice(@h, 0, 2);
$response->push_header($k, $v);
}
# keep-alive support
unless ($drop_connection) {
if (my $conn_cache = $self->{ua}{conn_cache}) {
my %connection = map { (lc($_) => 1) }
split(/\s*,\s*/, ($response->header("Connection") || ""));
if (($peer_http_version eq "1.1" && !$connection{close}) ||
$connection{"keep-alive"})
{
LWP::Debug::debug("Keep the http connection to $host:$port");
$conn_cache->deposit("http", "$host:$port", $socket);
}
}
}
$response;
}
#-----------------------------------------------------------
package LWP::Protocol::http::SocketMethods;
sub sysread {
my $self = shift;
if (my $timeout = ${*$self}{io_socket_timeout}) {
die "read timeout" unless $self->can_read($timeout);
}
else {
# since we have made the socket non-blocking we
# use select to wait for some data to arrive
$self->can_read(undef) || die "Assert";
}
sysread($self, $_[0], $_[1], $_[2] || 0);
}
sub can_read {
my($self, $timeout) = @_;
my $fbits = '';
vec($fbits, fileno($self), 1) = 1;
my $nfound = select($fbits, undef, undef, $timeout);
die "select failed: $!" unless defined $nfound;
return $nfound > 0;
}
sub ping {
my $self = shift;
!$self->can_read(0);
}
sub increment_response_count {
my $self = shift;
return ++${*$self}{'myhttp_response_count'};
}
#-----------------------------------------------------------
package LWP::Protocol::http::Socket;
use vars qw(@ISA);
@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
1;
