r1603 - trunk/varnish-tools/regress/lib/Varnish/Test/Case

[des at projects.linpro.no]

Author: des
Date: 2007-06-29 16:05:49 +0200 (Fri, 29 Jun 2007)
New Revision: 1603

Modified:
   trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
Log:
Greatly improve this test; see $DESCR + comments for details.


Modified: trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm	2007-06-29 14:05:21 UTC (rev 1602)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm	2007-06-29 14:05:49 UTC (rev 1603)
@@ -33,18 +33,24 @@
 use strict;
 use base 'Varnish::Test::Case';
 
-use Data::Dumper;
+our $prefix = __PACKAGE__;
 
 # Number of repetitions; total size of data set will be approximately
 # (25 * $repeat * $repeat), and needs to be larger than the size of
 # the storage file for the test to be meaningful.
 our $repeat = 256;
 
+our $DESCR = "Tests the LRU code by running more data through Varnish" .
+    " than the cache can hold, while simultaneously repeatedly requesting" .
+    " one particular object, which should remain in cache throughout.  The" .
+    " total amount of space consumed is approximately $repeat * round(" .
+    ((length(__PACKAGE__) + 5) * $repeat) . ", PAGE_SIZE).";
+
 sub _testLRU($$) {
     my ($self, $n) = @_;
 
     my $client = $self->new_client();
-    my $uri = "/Varnish/Test/Case/LRU/$n";
+    my $uri = __PACKAGE__ . "::$n";
     my $request = HTTP::Request->new('GET', $uri);
     $request->protocol('HTTP/1.1');
     $client->send_request($request, 2);
@@ -65,21 +71,36 @@
 sub testLRU($) {
     my ($self) = @_;
 
+    my $response = $self->_testLRU(0);
+    die "Invalid X-Varnish in response"
+	unless $response->header("X-Varnish") =~ m/^(\d+)$/;
+    my $xid0 = $1;
+
     # Send $repeat requests in an attempt to eat through the entire
-    # storage file.
+    # storage file.  Keep one object hot throughout.
     #
-    # XXX We should check to see if the child dies while we do this.
-    # XXX Currently, we will most likely get a client_timeout when
-    # XXX testing a pre-LRU version of Varnish.
-    for (my $n = 0; $n < $repeat; ++$n) {
+    #XXX We should check to see if the child dies while we do this.
+    #XXX Currently, when testing a pre-LRU version of Varnish, we will
+    #XXX most likely get a client timeout and the test framework will
+    #XXX get stuck.
+    for (my $n = 1; $n < $repeat; ++$n) {
+	# cold object
 	$self->_testLRU($n);
+
+	# Slow down!  If we run through the cache faster than the
+	# hysteresis in the LRU code, the hot object will be evicted.
+	$self->usleep(100000);
+
+	# hot object
+	$response = $self->_testLRU(0);
+	die "Cache miss on hot object"
+	    unless $response->header("X-Varnish") =~ m/^(\d+)\s+($xid0)$/o;
     }
 
-    # Redo the first request; if we get a cached response (indicated
-    # by a second XID in X-Varnish), the test is inconclusive and
-    # needs to be re-run with either a smaller storage file or a
-    # larger value for $repeat.
-    my $response = $self->_testLRU(0);
+    # Re-request an object which should have been evicted.  If we get
+    # a cache hit, the test is inconclusive and needs to be re-run
+    # with a smaller storage file or a larger value of $repeat.
+    $response = $self->_testLRU(1);
     die "Inconclusive test\n"
 	unless $response->header("X-Varnish") =~ m/^(\d+)$/;
 
@@ -92,7 +113,8 @@
     my $body = $request->uri() x $repeat;
     my $response = HTTP::Response->new(200, undef,
 				       [ 'Content-Type', 'text/plain',
-					 'Content-Length', length($body) ],
+					 'Content-Length', length($body),
+					 'Cache-Control', 'max-age=3600', ],
 				       $body);
     $response->protocol('HTTP/1.1');
     $connection->send_response($response);