Mailing List Archive

Author: des
Date: 2007-07-28 17:29:31 +0200 (Sat, 28 Jul 2007)
New Revision: 1782

Modified:
trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm
Log:
Add a slew of utilities to simplify the writing of test cases. Rewrite the
existing test cases to take advantage of these utilities.


Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -51,19 +51,8 @@

my $client = $self->new_client();
my $uri = __PACKAGE__ . "::$n";
- my $request = HTTP::Request->new('GET', $uri);
- $request->protocol('HTTP/1.1');
- $client->send_request($request, 2);
- my ($event, $response) =
- $self->run_loop('ev_client_response', 'ev_client_timeout');
- die "Timed out\n"
- if ($event eq 'ev_client_timeout');
- die "No (complete) response received\n"
- unless defined($response);
- die "Empty body\n"
- if $response->content() eq '';
- die "Incorrect body\n"
- if $response->content() !~ m/^(?:\Q$uri\E){$repeat}$/;
+ my $response = $self->get($client, $uri);
+ $self->assert_body(qr/^(?:\Q$uri\E){$repeat}$/);
$client->shutdown();
return $response;
}
@@ -107,17 +96,11 @@
return 'OK';
}

-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
+sub server($$$) {
+ my ($self, $request, $response) = @_;

- my $body = $request->uri() x $repeat;
- my $response = HTTP::Response->new(200, undef,
- [ 'Content-Type', 'text/plain',
- 'Content-Length', length($body),
- 'Cache-Control', 'max-age=3600', ],
- $body);
- $response->protocol('HTTP/1.1');
- $connection->send_response($response);
+ $response->content($request->uri() x $repeat);
+ $response->header('Cache-Control' => 'max-age=3600');
}

1;

Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -33,7 +33,10 @@
use strict;
use base 'Varnish::Test::Case';

-use Data::Dumper;
+our $DESCR = "Tests the VCL purge() function by warming up the cache," .
+ " then submitting a request that causes part of it to be purged," .
+ " before finally verifying that the objects that should have been" .
+ " purged were and those that shouldn't weren't.";

our $VCL = <<EOVCL;
sub vcl_recv {
@@ -48,69 +51,35 @@
our $PURGE_URL = '/will-be-purged';
our $PURGE_RE = 'purge';

-sub get($$$) {
- my ($self, $client, $url) = @_;
-
- my $req = HTTP::Request->new('GET', $url);
- $req->protocol('HTTP/1.1');
- $client->send_request($req, 2);
- my ($ev, $resp) =
- $self->run_loop('ev_client_response', 'ev_client_timeout');
- die "Client time-out before receiving a (complete) response\n"
- if $ev eq 'ev_client_timeout';
- die "Request failed\n"
- unless $resp->code == 200;
- return $resp;
-}
-
-sub get_cached($$$) {
- my ($self, $client, $url) = @_;
-
- my $resp = $self->get($client, $url);
- die "$url should be cached but isn't\n"
- unless $resp->header('x-varnish') =~ /^\d+ \d+$/;
-}
-
-sub get_uncached($$$) {
- my ($self, $client, $url) = @_;
-
- my $resp = $self->get($client, $url);
- die "$url shouldn't be cached but is\n"
- if $resp->header('x-varnish') =~ /^\d+ \d+$/;
-}
-
-sub purge($$$) {
- my ($self, $client, $re) = @_;
-
- my $req = HTTP::Request->new('REPURGE', $re);
- $req->protocol('HTTP/1.1');
- $client->send_request($req, 2);
- my ($ev, $resp) =
- $self->run_loop('ev_client_response', 'ev_client_timeout');
- die "Client time-out before receiving a (complete) response\n"
- if $ev eq 'ev_client_timeout';
-}
-
sub testPagePurged($) {
my ($self) = @_;

my $client = $self->new_client;
- my $resp;

# Warm up the cache
$self->get($client, $KEEP_URL);
+ $self->assert_ok();
$self->get($client, $PURGE_URL);
+ $self->assert_ok();

# Verify the state of the cache
- $self->get_cached($client, $KEEP_URL);
- $self->get_cached($client, $PURGE_URL);
+ $self->get($client, $KEEP_URL);
+ $self->assert_ok();
+ $self->assert_cached();
+ $self->get($client, $PURGE_URL);
+ $self->assert_ok();
+ $self->assert_cached();

# Send the purge request
- $self->purge($client, $PURGE_RE);
+ $self->request($client, 'REPURGE', $PURGE_RE);

# Verify the state of the cache
- $self->get_cached($client, $KEEP_URL);
- $self->get_uncached($client, $PURGE_URL);
+ $self->get($client, $KEEP_URL);
+ $self->assert_ok();
+ $self->assert_cached();
+ $self->get($client, $PURGE_URL);
+ $self->assert_ok();
+ $self->assert_uncached();

$client->shutdown();


Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -33,6 +33,9 @@
use strict;
use base 'Varnish::Test::Case';

+our $DESCR = "Checks that Varnish passes the correct HTTP version" .
+ " to both server and client in pass mode.";
+
our $VCL = "
sub vcl_recv {
pass;
@@ -53,7 +56,8 @@
$request->protocol($cv);
$client->send_request($request, 2);

- my ($event, $response) = $self->run_loop('ev_client_response', 'ev_client_timeout');
+ my ($event, $response) =
+ $self->run_loop('ev_client_response', 'ev_client_timeout');

die "Client time-out before receiving a (complete) response\n"
if $event eq 'ev_client_timeout';
@@ -82,14 +86,12 @@
delete $self->{'cv', 'sv'};
}

-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
+sub server($$$) {
+ my ($self, $request, $response) = @_;

- my $response = HTTP::Response->new(404, undef, undef,
- sprintf ("%s not found\n", $request->uri));
+ $response->code(404);
+ $response->content(sprintf("%s not found\n", $request->uri));
$response->protocol($self->{'sv'});
- $connection->send_response($response);
- $connection->shutdown;
}

1;

Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -33,6 +33,9 @@
use strict;
use base 'Varnish::Test::Case';

+our $DESCR = "Checks that Varnish includes the response body when" .
+ " handling GET and POST, but not when handling HEAD.";
+
our $VCL = <<EOVCL;
sub vcl_recv {
if (req.request == "POST" &&
@@ -42,41 +45,34 @@
}
EOVCL

-our $body = "Hello World!\n";
+our $BODY = "Hello World!\n";

sub testBodyInCachedPOST($) {
my ($self) = @_;

my $client = $self->new_client;
- for (my $i = 0; $i < 2; $i++) {
- my $request = HTTP::Request->new('POST', '/');
- $request->protocol('HTTP/1.1');
- $client->send_request($request, 2);

- my ($event, $response) = $self->run_loop('ev_client_response', 'ev_client_timeout');
+ $self->get($client, '/');
+ $self->assert_body($BODY);
+ $self->assert_uncached();

- die "Client time-out before receiving a (complete) response\n"
- if $event eq 'ev_client_timeout';
- die "Empty body\n"
- if $response->content eq '';
- die "Incorrect body\n"
- if $response->content ne $body;
- }
+ $self->post($client, '/');
+ $self->assert_body($BODY);
+ $self->assert_cached();

+ $self->head($client, '/');
+ $self->assert_no_body();
+ $self->assert_cached();
+
$client->shutdown();

return 'OK';
}

-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
+sub server($$$) {
+ my ($self, $request, $response) = @_;

- my $response = HTTP::Response->new(200, undef,
- [ 'Content-Length', length($body),
- 'Connection', 'Keep-Alive' ],
- $body);
- $response->protocol('HTTP/1.1');
- $connection->send_response($response);
+ $response->content($BODY);
}

1;

Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -33,6 +33,8 @@
use strict;
use base 'Varnish::Test::Case';

+our $DESCR = "Tests the synthetic error response code.";
+
our $CODE = 400;
our $MESSAGE = "These are not the droids you are looking for";

@@ -46,19 +48,9 @@
my ($self) = @_;

my $client = $self->new_client;
- my $request = HTTP::Request->new('GET', '/');
- $request->protocol('HTTP/1.0');
- $client->send_request($request, 2);
-
- my ($event, $response) = $self->run_loop('ev_client_response', 'ev_client_timeout');
-
- die "Client time-out before receiving a (complete) response\n"
- if $event eq 'ev_client_timeout';
- die "Incorrect response code\n"
- if $response->code != $CODE;
- die "Incorrect response message\n"
- unless $response->content =~ m/\Q$MESSAGE\E/o;
-
+ $self->get($client, '/');
+ $self->assert_code($CODE);
+ $self->assert_body(qr/\Q$MESSAGE\E/);
$client->shutdown();

return 'OK';

Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -33,6 +33,10 @@
use strict;
use base 'Varnish::Test::Case';

+our $DESCR = "Tests Vary: support by requesting the same document" .
+ " in different languages and verifying that the correct version" .
+ " is returned and cached.";
+
our %languages = (
'en' => "Hello World!\n",
'no' => "Hallo Verden!\n",
@@ -41,48 +45,36 @@
sub testVary($) {
my ($self) = @_;

- my $client = $self->new_client;
- my $request = HTTP::Request->new('GET', '/');
+ my $client = $self->new_client();

foreach my $lang (keys %languages) {
- $request->header('Accept-Language', $lang);
- $request->protocol('HTTP/1.1');
- $client->send_request($request, 2);
- my ($event, $response) =
- $self->run_loop('ev_client_response', 'ev_client_timeout');
- die "No (complete) response received\n"
- unless defined($response);
- die "Empty body\n"
- if $response->content() eq '';
- die "Incorrect body\n"
- if $response->content() ne $languages{$lang};
+ $self->get($client, '/', [ 'Accept-Language', $lang]);
+ # $self->assert_uncached();
+ $self->assert_header('Language', $lang);
+ $self->assert_body($languages{$lang});
}
+ foreach my $lang (keys %languages) {
+ $self->get($client, '/', [ 'Accept-Language', $lang]);
+ $self->assert_cached();
+ $self->assert_body($languages{$lang});
+ }

$client->shutdown();
return 'OK';
}

-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
+sub server($$$) {
+ my ($self, $request, $response) = @_;

- my $body;
- my @headers;
if (my $lang = $request->header("Accept-Language")) {
$lang = 'en'
unless ($lang && $languages{$lang});
- $body = $languages{$lang};
- push(@headers, ('Language', $lang));
+ $response->content($languages{$lang});
+ $response->header('Language' => $lang);
+ $response->header('Vary' => 'Accept-Language');
} else {
die 'Not ready for this!';
}
-
- my $response = HTTP::Response->new(200, undef,
- [ 'Content-Length', length($body),
- 'Vary', 'Accept-Language',
- @headers ],
- $body);
- $response->protocol('HTTP/1.1');
- $connection->send_response($response);
}

1;

Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm 2007-07-28 11:41:35 UTC (rev 1781)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm 2007-07-28 15:29:31 UTC (rev 1782)
@@ -51,6 +51,7 @@
use Varnish::Test::Client;
use HTTP::Request;
use HTTP::Response;
+use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday tv_interval);

sub new($$) {
@@ -175,6 +176,10 @@
};
}

+#
+# Default event handlers
+#
+
sub ev_client_response($$$) {
my ($self, $client, $response) = @_;

@@ -188,6 +193,159 @@
return $client;
}

+sub ev_server_request($$$$) {
+ my ($self, $server, $connection, $request) = @_;
+
+ no strict 'refs';
+ my $method = $request->method();
+ my $handler;
+ if ($self->can("server_$method")) {
+ $handler = ref($self) . "::server_$method";
+ } elsif ($self->can("server")) {
+ $handler = ref($self) . "::server";
+ } else {
+ die "No server callback defined\n";
+ }
+
+ my $response = HTTP::Response->new();
+ $response->code(200);
+ $response->header('Date' =>
+ strftime("%a, %d %b %Y %T GMT", gmtime(time())));
+ $response->header('Server' => ref($self));
+ $response->header('Connection' => 'keep-alive');
+ $response->content('');
+ $response->protocol('HTTP/1.1');
+ $self->$handler($request, $response);
+ $response->header('Content-Length' =>
+ length($response->content()));
+ $connection->send_response($response);
+}
+
+#
+# Client utilities
+#
+
+sub request($$$$;$$) {
+ my ($self, $client, $method, $uri, $header, $content) = @_;
+
+ my $req = HTTP::Request->new($method, $uri, $header, $content);
+ $req->protocol('HTTP/1.1');
+ $client->send_request($req, 2);
+ my ($ev, $resp) =
+ $self->run_loop('ev_client_response', 'ev_client_timeout');
+ die "Internal error\n"
+ unless $resp && ref($resp) && $resp->isa('HTTP::Response');
+ die "Client time-out before receiving a (complete) response\n"
+ if $ev eq 'ev_client_timeout';
+ die "No X-Varnish header\n"
+ unless $resp->header('X-Varnish');
+ $resp->request($req);
+ return $self->{'cached_response'} = $resp;
+}
+
+sub head($$$;$) {
+ my ($self, $client, $uri, $header) = @_;
+
+ return $self->request($client, 'HEAD', $uri, $header);
+}
+
+sub get($$$;$) {
+ my ($self, $client, $uri, $header) = @_;
+
+ return $self->request($client, 'GET', $uri, $header);
+}
+
+sub post($$$;$$) {
+ my ($self, $client, $uri, $header, $body) = @_;
+
+ $header = []
+ unless defined($header);
+ push(@{$header}, 'content-length', length($body))
+ if defined($body);
+ return $self->request($client, 'POST', $uri, $header, $body);
+}
+
+sub assert_code($$;$) {
+ my ($self, $code, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+ die "Expected $code, got @{[$resp->code]}\n"
+ unless $resp->code == $code;
+}
+
+sub assert_ok($;$) {
+ my ($self, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+
+ $self->assert_code(200, $resp);
+}
+
+sub assert_cached($;$) {
+ my ($self, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+
+ my $uri = $resp->request->uri;
+ die "$uri should be cached but isn't\n"
+ unless $resp->header('X-Varnish') =~ /^\d+ \d+$/;
+}
+
+sub assert_uncached($;$) {
+ my ($self, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+
+ my $uri = $resp->request->uri;
+ die "$uri shouldn't be cached but is\n"
+ if $resp->header('X-Varnish') =~ /^\d+ \d+$/;
+}
+
+sub assert_header($$;$$) {
+ my ($self, $header, $re, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+
+ die "$header: header missing\n"
+ unless defined($resp->header($header));
+ if (defined($re)) {
+ die "$header: header does not match\n"
+ unless $resp->header($header) =~ m/$re/;
+ }
+}
+
+sub assert_body($;$$) {
+ my ($self, $re, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+
+ die "Response has no body\n"
+ unless defined($resp->content());
+ if (defined($re)) {
+ die "Response body does not match\n"
+ unless $resp->content() =~ m/$re/;
+ }
+}
+
+sub assert_no_body($;$) {
+ my ($self, $resp) = @_;
+
+ $resp = $self->{'cached_response'}
+ unless defined($resp);
+ die "Response shouldn't have a body, but does\n"
+ if defined($resp->content()) && length($resp->content());
+}
+
+#
+# Miscellaneous
+#
+
sub usleep($$) {
my ($self, $usec) = @_;