]> err.no Git - varnish/commitdiff
Add a slew of utilities to simplify the writing of test cases. Rewrite the
authordes <des@d4fa192b-c00b-0410-8231-f00ffab90ce4>
Sat, 28 Jul 2007 15:29:31 +0000 (15:29 +0000)
committerdes <des@d4fa192b-c00b-0410-8231-f00ffab90ce4>
Sat, 28 Jul 2007 15:29:31 +0000 (15:29 +0000)
existing test cases to take advantage of these utilities.

git-svn-id: svn+ssh://projects.linpro.no/svn/varnish/trunk@1782 d4fa192b-c00b-0410-8231-f00ffab90ce4

varnish-tools/regress/lib/Varnish/Test/Case.pm
varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm
varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm
varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm
varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm
varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm

index 3fdd25460107bdfec1a3e8e7ed16310d09f2a9ae..1293b792cbdae4d3766d58d01dc03d38f59f535f 100644 (file)
@@ -51,6 +51,7 @@ use strict;
 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 @@ sub results($) {
     };
 }
 
+#
+# Default event handlers
+#
+
 sub ev_client_response($$$) {
     my ($self, $client, $response) = @_;
 
@@ -188,6 +193,159 @@ sub ev_client_timeout($$) {
     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) = @_;
 
index 3b6abc45fd7ba49fd65f1cc8fa15f6d3068fe4a8..6491a081dde57a6da8547ee7a5c08adb8c68a65e 100644 (file)
@@ -51,19 +51,8 @@ sub _testLRU($$) {
 
     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 @@ sub testLRU($) {
     return 'OK';
 }
 
-sub ev_server_request($$$$) {
-    my ($self, $server, $connection, $request) = @_;
-
-    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);
+sub server($$$) {
+    my ($self, $request, $response) = @_;
+
+    $response->content($request->uri() x $repeat);
+    $response->header('Cache-Control' => 'max-age=3600');
 }
 
 1;
index d07a3517bc2eeb44bb4e97975361b22b629bce62..bdf6d78ba59a6e19d8238a546f86dcada4dc7395 100644 (file)
@@ -33,7 +33,10 @@ package Varnish::Test::Case::RePurge;
 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 $KEEP_URL = '/will-be-kept';
 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();
 
index 8a2d6d5107535e4dbf3959cfd2d8db47215d3eae..17ee3c23471de1bd67ba975e913f17e29f4c674a 100644 (file)
@@ -33,6 +33,9 @@ package Varnish::Test::Case::Ticket056;
 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 @@ sub testVersionMatch($) {
     $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 @@ sub run($) {
     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;
index e023d7bcb35fd4765c81a66c03d4721c127a0074..03851f1770f9323b45590cb019b425bff30d5f9d 100644 (file)
@@ -33,6 +33,9 @@ package Varnish::Test::Case::Ticket102;
 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 @@ sub vcl_recv {
 }
 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();
+
+    $self->post($client, '/');
+    $self->assert_body($BODY);
+    $self->assert_cached();
 
-       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->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;
index 71a25290c2d53dc86e34788f0a09979b541ddddf..54dd3be2943c45998eb6120369699dfc9b7cf4d7 100644 (file)
@@ -33,6 +33,8 @@ package Varnish::Test::Case::Ticket128;
 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 @@ sub testSyntheticError($) {
     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';
index 72179a4a2c7e64bada28ed51a3c2d0cc96e4ba8a..d24fd110042521265d960b108ccc1df5f16282d4 100644 (file)
@@ -33,6 +33,10 @@ package Varnish::Test::Case::Vary;
 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 @@ our %languages = (
 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;