22

✏️ Editing: cache-timeouts.t

use strict;
use warnings;
use Test::More;

use FindBin qw( $Bin );
use HTTP::Request ();
use LWP::UserAgent ();
use LWP::ConnCache ();

if (!-e "$Bin/config.pl") {
    plan skip_all => 'no net config file';
    exit 0;
}

require "$Bin/config.pl";

my $cache   = LWP::ConnCache->new( total_capacity => 4 );
my $ua      = LWP::UserAgent->new( conn_cache => $cache );
my $ua2     = LWP::UserAgent->new( conn_cache => $cache );

no warnings 'once';
my $netloc  = $net::httpserver || '';
my $script  = ($net::cgidir || '') . "/test";
my $timeout_script = ($net::cgidir || '') . '/timeout';

note 'This script tests whether the timeout used for cached connections';
note 'respects the timeout of the user agent.';
note '';
note 'Case one: Does timeout get set?';
note 'Case two: User agent changes its timeout';
note 'Case three: Multiple user agents share the same cache';
note 'Case four: Check that timeout was applied';

my $request = HTTP::Request->new('GET', "http://$netloc$script", [ 'Connection' => 'Keep-Alive' ]);

$ua->timeout(10);
$ua2->timeout(12);

# First we have to do a test hit.
my $response = $ua->request($request);
if (! $response->is_success) {
    plan skip_all => "Target webserver http://$netloc is down";
    exit 0;
}
elsif ($response->header('Connection') !~ m/keep-alive/i) {
    plan skip_all => 'To run this test, the target webserver must support persistent connections.';
    exit 0;
}

plan tests => 8;

note 'Case one: Does timeout get set?';
my @connections = $cache->get_connections();
is(scalar @connections, 1, "One connection cached");
ok( $connections[0] && $connections[0]->timeout() == 10,
    "After first request, the cached connection has timeout = 10");

note 'Case two: User agent changes its timeout';
note 'Setting user agent timeout to 8 seconds';
$ua->timeout(8);
$response = $ua->request($request);

@connections = $cache->get_connections();
is(scalar @connections, 1, "Still one connection cached");
ok( $connections[0] && $connections[0]->timeout() == 8,
    "Cached connection now has timeout = 8");

note 'Case three: Multiple user agents share the same cache';
note 'Using alternate user agent with timeout = 12 seconds';
$response = $ua2->request($request);
@connections = $cache->get_connections();
is(scalar @connections, 1, "Still one connection cached");
ok( $connections[0] && $connections[0]->timeout() == 12,
    "Cached connection now has timeout = 12");

note 'Case four: Check that timeout was applied';
note 'Setting user agent timeout to 2 seconds';
$ua->timeout(2);

$request = HTTP::Request->new('GET', "http://$netloc$timeout_script", [ 'Connection' => 'Keep-Alive' ]);

# Because the cached connection will be dropped due to the timeout, we have to
# check the actual duration.

my $start_time = time;
$response = $ua->request($request);
my $duration = time - $start_time;

@connections = $cache->get_connections();
is(scalar @connections, 0, "No cached connections remaining");
ok( $duration >= 2 && $duration <= 3, "Timeout applied was 2 seconds");

MR SKB