From: knutroy <knutroy@d4fa192b-c00b-0410-8231-f00ffab90ce4>
Date: Fri, 16 Feb 2007 13:26:52 +0000 (+0000)
Subject: Updated regression test framework so that it runs "test1" sample code.
X-Git-Url: https://err.no/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=6a8a701fc3dccc8f882cf4d278ca351a775c2da8;p=varnish

Updated regression test framework so that it runs "test1" sample code.
See TODO-file for a (non-exhaustive) list of what remains to be done.


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

diff --git a/varnish-tools/regress/README b/varnish-tools/regress/README
new file mode 100644
index 00000000..5e5ebfe6
--- /dev/null
+++ b/varnish-tools/regress/README
@@ -0,0 +1,60 @@
+VARNISH REGRESSION TEST FRAMEWORK
+
+This is a regression test framework written in Perl. It is being
+tailored to the needs of the Varnish HTTP accelerator.
+
+The framework is based on interpreting a mini-language designed for
+this specific purpose. The mini-language expresses test case setups
+and conditions to be tested.
+
+The Perl-based interpreter sets up the run-time environment and
+executes a "program" written in this mini-language.
+
+The mini-language's grammar can be found in lib/Varnish/Test/Parser.pm
+which utilizes the Parse::RecDescent CPAN-module.
+
+The interpreter creates a run-time environment consisting of simulated
+clients and servers which live in the main process. In addition, it
+forks off a Varnish sub-process through which the clients and servers
+send HTTP-traffic. The main process uses a global select(2)-based loop
+(using IO::Multiplex) to which all the simulated clients and servers
+must relate. Hence, no threading is needed, but disciplined use
+sockets (to avoid blocking and other trouble) is required.
+
+When the mini-language is parsed, a tree of Perl-objects is created.
+There are classes representing:
+
+  * a server (Varnish::Test::Server)
+  * a client (Varnish::Test::Client)
+  * an accelerator/Varnish instance (Varnish::Test::Accelerator)
+  * a test-case (Varnish::Test::Case)
+  * a statement (Varnish::Test::Statement)
+  * an expression (Varnish::Test::Expression)
+  * a function invocation (Varnish::Test::Invocation)
+
+These classes share some properties which are found
+Varnish::Test::Object, most notably the ability to be "executed" and
+temporarily paused when the IO::Multiplex-loop needs to transfers
+control to another object.
+
+To keep track of execution, all objects have an attribute, "finished",
+which tells its parent whether execution has already terminated. In
+addition an attribute "return" is used to hold any return value should
+the object have a sensible return value to offer (which is the true
+for statements, expressions, and function invocations). Before
+"finished" is set to true, "return" has no meaning.
+
+The parent will execute its children sequentially, in the same order
+as they are defined in the source code.
+
+However, some objects get control back after they are "finished". This
+is the case for server objects when they serve requests, which happens
+asynchronously to ordinary execution and is orchestrated by the
+IO::Multiplex-loop. When the server object has handled the request,
+control returns to the original point of execution. Finding that point
+is done by skipping past all objects whose "finished"-attribute is
+true.
+
+Finally, the notion of scope and variables is taken care of by
+functionality provided in the super-class Varnish::Test::Context from
+which Varnish::Test::Object inherits.
diff --git a/varnish-tools/regress/TODO b/varnish-tools/regress/TODO
new file mode 100644
index 00000000..3f6e4bf1
--- /dev/null
+++ b/varnish-tools/regress/TODO
@@ -0,0 +1,23 @@
+* Revise class hierarchy, possibly switching around
+  Varnish::Test::Context and Varnish::Test::Object since we might like
+  to inherit the properties of Object without getting the properties
+  of Context, in classes like Varnish::Test::Statement,
+  Varnish::Test::Expression, and Varnish::Test::Invocation.
+
+* Actually handle HTTP by utilizing Varnish::Test::Message (and
+  the sub-classes Varnish::Test::Request and Varnish::Test::Response)
+  as variables that live inside server and client objects.
+
+* Extend the language (syntax and semantics), to make it more
+  expressive and useful.
+
+* POD-ify Perl-code.
+
+* Fix IO::Multiplex-related warnings:
+
+  · Use of uninitialized value in unpack at /usr/share/perl5/IO/Multiplex.pm line 351.
+    Use of uninitialized value in numeric eq (==) at /usr/share/perl5/IO/Multiplex.pm line 351.
+
+  · Use of freed value in iteration at /usr/share/perl5/IO/Multiplex.pm line 721.
+
+  (Is this IO::Multiplex' or our fault?)
diff --git a/varnish-tools/regress/lib/Varnish/Test.pm b/varnish-tools/regress/lib/Varnish/Test.pm
index 680d56de..c01dc248 100644
--- a/varnish-tools/regress/lib/Varnish/Test.pm
+++ b/varnish-tools/regress/lib/Varnish/Test.pm
@@ -77,9 +77,9 @@ sub parse($$) {
 	die("Parsing error.");
     }
 
-    print "###### SYNTAX TREE BEGIN ######\n";
-    print Dumper $tree if defined($tree->{'body'});
-    print "###### SYNTAX TREE END ######\n";
+    print STDERR "###### SYNTAX TREE BEGIN ######\n";
+    print STDERR Dumper $tree if defined($tree->{'body'});
+    print STDERR "###### SYNTAX TREE END ######\n";
 
     $self->{'objects'} = [];
 
@@ -99,11 +99,11 @@ sub main($) {
 
     while (!$self->{'finished'}) {
 	&Varnish::Test::Object::run($self);
-	print "Entering IO::Multiplex loop.\n";
+	print STDERR "Entering IO::Multiplex loop.\n";
 	$self->{'mux'}->loop;
     }
 
-    print "DONE.\n";
+    print STDERR "DONE.\n";
 }
 
 sub run($) {
diff --git a/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm b/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm
index 380ec239..42fabc59 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm
@@ -32,16 +32,21 @@ package Varnish::Test::Accelerator;
 
 use strict;
 use base 'Varnish::Test::Object';
+use IO::Pipe;
 use POSIX;
 
 sub _init($) {
     my $self = shift;
 
+    &Varnish::Test::Object::_init($self);
+
     # Default address / port
     $self->vars->{'address'} = 'localhost';
     $self->vars->{'port'} = '8001';
 }
 
+use Data::Dumper;
+
 sub start($) {
     my $self = shift;
 
@@ -50,59 +55,129 @@ sub start($) {
      $backend->isa('Varnish::Test::Server'))
 	or die("invalid server\n");
 
-    my ($stdinx, $stdin) = POSIX::pipe()
-	or die("pipe(): $!\n");
-    my ($stdout, $stdoutx) = POSIX::pipe()
-	or die("pipe(): $!\n");
-    my ($stderr, $stderrx) = POSIX::pipe()
-	or die("pipe(): $!\n");
+    my $stdin = new IO::Pipe;
+    my $stdout = new IO::Pipe;
+    my $stderr = new IO::Pipe;
     my $pid = fork();
     if (!defined($pid)) {
 	# fail
 	die("fork(): $!\n");
     } elsif ($pid == 0) {
 	# child
-	POSIX::dup2($stdinx, 0);
-	POSIX::close($stdin);
-	POSIX::close($stdinx);
-	POSIX::dup2($stdoutx, 1);
-	POSIX::close($stdout);
-	POSIX::close($stdoutx);
-	POSIX::dup2($stderrx, 2);
-	POSIX::close($stderr);
-	POSIX::close($stderrx);
+	$stdin->reader;
+	$stdout->writer;
+	$stderr->writer;
+
+	POSIX::dup2($stdin->fileno, 0);
+	$stdin->close;
+	POSIX::dup2($stdout->fileno, 1);
+	$stdout->close;
+	POSIX::dup2($stderr->fileno, 2);
+	$stderr->close;
 	# XXX must be in path
+	$ENV{'PATH'} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin';
 	exec('varnishd',
 	     '-d', '-d',
+	     '-a', $self->get('address') . ":" . $self->get('port'),
 	     '-b', $backend->get('address') . ":" . $backend->get('port'));
 	exit(1);
     }
     # parent
+
+    $stdin->writer;
+    $stdout->reader;
+    $stderr->reader;
+
     $self->{'pid'} = $pid;
     $self->{'stdin'} = $stdin;
-    POSIX::close($stdinx);
     $self->{'stdout'} = $stdout;
-    POSIX::close($stdoutx);
     $self->{'stderr'} = $stderr;
-    POSIX::close($stderrx);
+
+    # IO::Multiplex is going to issue some warnings here, because it
+    # does not handle non-socket file descriptors gently.
+
+    my $mux = $self->get_mux;
+    $mux->add($stdin);
+    $mux->set_callback_object($self, $stdin);
+    $mux->add($stdout);
+    $mux->set_callback_object($self, $stdout);
+    $mux->add($stderr);
+    $mux->set_callback_object($self, $stderr);
+
+    if ($self->has('vcl')) {
+	my $vcl = $self->get('vcl');
+	$vcl =~ s/\n/ /g;
+	$mux->write($stdin, "vcl.inline main " . $vcl . "\n");
+    }
 }
 
 sub stop($) {
     my $self = shift;
 
-    POSIX::close($self->{'stdin'})
-	if ($self->{'stdin'});
-    POSIX::close($self->{'stdout'})
-	if ($self->{'stdout'});
-    POSIX::close($self->{'stderr'})
-	if ($self->{'stderr'});
+    my $mux = $self->get_mux;
+
+    foreach my $k ('stdin', 'stdout', 'stderr') {
+	if (defined($self->{$k})) {
+	    $mux->close($self->{$k});
+	    delete $self->{$k};
+	}
+    }
     sleep(1);
     kill(15, $self->{'pid'})
 	if ($self->{'pid'});
-    delete($self->{'stdin'});
-    delete($self->{'stdout'});
-    delete($self->{'stderr'});
     delete($self->{'pid'});
 }
 
+sub run($) {
+    my $self = shift;
+
+    return if $self->{'finished'} or defined($self->{'pid'});
+
+    &Varnish::Test::Object::run($self);
+
+    $self->start;
+    $self->{'finished'} = 0;
+}
+
+sub shutdown($) {
+    my $self = shift;
+
+    $self->stop;
+}
+
+sub mux_input($$$$) {
+    my $self = shift;
+    my $mux = shift;
+    my $fh = shift;
+    my $data = shift;
+
+    print STDERR $$data;
+
+    if ($$data =~ /vcl.inline/) {
+	$mux->write($self->{'stdin'}, "start\n");
+    }
+
+    my $started = ($$data =~ /Child starts/);
+    $$data = '';
+
+    if ($started) {
+	$self->{'finished'} = 1;
+	$self->super_run;
+    }
+}
+
+sub mux_eof($$$$) {
+    my $self = shift;
+    my $mux = shift;
+    my $fh = shift;
+    my $data = shift;
+
+    $mux->close($fh);
+    foreach my $k ('stdin', 'stdout', 'stderr') {
+	if (defined($self->{$k}) && $self->{$k} == $fh) {
+	    delete $self->{$k};
+	}
+    }
+}
+
 1;
diff --git a/varnish-tools/regress/lib/Varnish/Test/Case.pm b/varnish-tools/regress/lib/Varnish/Test/Case.pm
index 9c5f5df5..473bf5ee 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Case.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Case.pm
@@ -33,12 +33,43 @@ package Varnish::Test::Case;
 use strict;
 use base 'Varnish::Test::Object';
 
+sub _init($) {
+    my $self = shift;
+
+    &Varnish::Test::Object::_init($self);
+
+    $self->set('assert', \&assert);
+}
+
 sub run($) {
     my $self = shift;
 
-    print "Running case \"$self->{name}\"...\n";
+    if (!defined($self->{'started'})) {
+	print "Start of CASE \"$self->{name}\"...\n";
+	$self->{'started'} = 1;
+    }
 
     &Varnish::Test::Object::run($self);
+
+    if ($self->{'finished'}) {
+	print "End of CASE \"$self->{name}\".\n";
+    }
+}
+
+sub assert($$) {
+    my $self = shift;
+    my $invocation = shift;
+
+    my $bool = $invocation->{'args'}[0]->{'return'};
+
+    if (!$bool) {
+	print "  ASSERTION DOES NOT HOLD.\n";
+    }
+    else {
+	print "  Assertion holds.\n";
+    }
+
+    $invocation->{'finished'} = 1;
 }
 
 1;
diff --git a/varnish-tools/regress/lib/Varnish/Test/Client.pm b/varnish-tools/regress/lib/Varnish/Test/Client.pm
index 9b4d0de4..42b20382 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Client.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Client.pm
@@ -38,6 +38,8 @@ use URI;
 sub _init($) {
     my $self = shift;
 
+    &Varnish::Test::Object::_init($self);
+
     $self->set('protocol', '1.1');
     $self->set('request', \&request);
 }
@@ -66,8 +68,7 @@ sub request($$) {
     $mux->add($fh);
     $mux->set_callback_object($self, $fh);
 
-    $mux->write($fh, "Hello\r\n");
-    print "Client sent: Hello\n";
+    $mux->write($fh, "GET / HTTP/" . eval($self->get('protocol')) . "\r\n\r\n");
 
     $self->{'request'} = $invocation;
 }
@@ -77,9 +78,16 @@ sub mux_input($$$$) {
     my $mux = shift;
     my $fh = shift;
     my $data = shift;
+    my $response = new Varnish::Test::Context('response', $self);
 
     $self->{'request'}->{'return'} = $$data;
-    print "Client got: $$data";
+    if ($$data =~ 'HTTP/1.1') {
+	$response->set('protocol', '1.1');
+    }
+    else {
+	$response->set('protocol', '1.0');
+    }
+    print STDERR "Client got: $$data";
     $$data = "";
     $self->{'request'}->{'finished'} = 1;
     delete $self->{'request'};
diff --git a/varnish-tools/regress/lib/Varnish/Test/Expression.pm b/varnish-tools/regress/lib/Varnish/Test/Expression.pm
index 4296ac9c..c436e956 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Expression.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Expression.pm
@@ -73,9 +73,11 @@ sub run($) {
 
     &Varnish::Test::Object::run($self);
 
+    my $expr = '';
+    my $seen_string = 0;
+    my $relational = 0;
+
     if ($self->{'finished'} && defined($self->{'terms'})) {
-	my $expr = '';
-	my $return_as_string = 0;
 
 	foreach my $term (@{$self->{'terms'}}) {
 	    my $term_value;
@@ -89,6 +91,20 @@ sub run($) {
 		}
 	    }
 	    else {
+		if ($term eq '==' || $term eq '!='
+		    || $term eq '<=' || $term eq '>='
+		    || $term eq '<' || $term eq '>') {
+		    $relational = 1;
+
+		    if ($seen_string) {
+			if ($term eq '==') {
+			    $term = 'eq';
+			}
+			elsif ($term eq '!=') {
+			    $term = 'ne';
+			}
+		    }
+		}
 		$term_value = $term;
 	    }
 
@@ -98,12 +114,12 @@ sub run($) {
 		    return;
 		}
 		else {
-		    die "Found object/context reference in complex expression.";
+		    $term_value = '"' . $term_value . '"';
 		}
 	    }
 
 	    if ($term_value =~ /^".*"$/s) {
-		$return_as_string = 1;
+		$seen_string = 1;
 	    }
 
 	    $expr .= $term_value;
@@ -111,9 +127,11 @@ sub run($) {
 
 	($expr) = $expr =~ /(.*)/s;
 
+	# print STDERR "Evaling: $expr\n";
+
 	$expr = eval $expr;
 
-	if ($return_as_string) {
+	if ($seen_string && !$relational) {
 	    $expr = '"' . $expr . '"';
 	}
 
diff --git a/varnish-tools/regress/lib/Varnish/Test/Invocation.pm b/varnish-tools/regress/lib/Varnish/Test/Invocation.pm
index 450c4fd2..cde72f2a 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Invocation.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Invocation.pm
@@ -60,7 +60,7 @@ sub run($) {
 	if (!$self->{'in_call'}) {
 	    $self->{'in_call'} = 1;
 	    my ($func_ptr, $func_context) = $self->{'func_id'}->get_function($self);
-	    print "Calling " . $self->{'func_id'}->as_string, "\n";
+	    # print STDERR "Calling " . $self->{'func_id'}->as_string, "\n";
 	    &$func_ptr($func_context, $self);
 	}
     }
diff --git a/varnish-tools/regress/lib/Varnish/Test/Server.pm b/varnish-tools/regress/lib/Varnish/Test/Server.pm
index 28a98a01..d52517b2 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Server.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Server.pm
@@ -37,6 +37,8 @@ use IO::Socket;
 sub _init($) {
     my $self = shift;
 
+    &Varnish::Test::Object::_init($self);
+
     $self->set('address', 'localhost');
     $self->set('port', '9001');
 }
@@ -81,10 +83,14 @@ sub mux_input($$$$) {
     my $fh = shift;
     my $data = shift;
 
-    print "Server got: $$data";
-    $$data = "";
-    $mux->write($fh, "HTTP/1.1 200 OK\r\n");
-    print "Server sent: HTTP/1.1 200 OK\n";
+    $$data = ""; # Pretend we read the data.
+
+    my $response = "HTTP/" . eval($self->get('protocol')) . " 200 OK\r\n"
+	. "Content-Type: text/plain; charset=utf-8\r\n\r\n"
+	. eval($self->get('data')) . "\n";
+
+    $mux->write($fh, $response);
+    print STDERR "Server sent: " . $response;
     $mux->shutdown($fh, 1);
 }
 
diff --git a/varnish-tools/regress/lib/Varnish/Test/Statement.pm b/varnish-tools/regress/lib/Varnish/Test/Statement.pm
index 8d3976a5..15cfe54d 100644
--- a/varnish-tools/regress/lib/Varnish/Test/Statement.pm
+++ b/varnish-tools/regress/lib/Varnish/Test/Statement.pm
@@ -53,6 +53,8 @@ sub new($$) {
     }
 }
 
+use Data::Dumper;
+
 sub run($$) {
     my $self = shift;
 
@@ -61,7 +63,7 @@ sub run($$) {
     &Varnish::Test::Object::run($self);
 
     if ($self->{'finished'}) {
-	$self->{'lhs'}->set_value($self, $self->{'return'});
+	$self->{'lhs'}->set_value($self->{'parent'}, $self->{'return'});
     }
 }
 
diff --git a/varnish-tools/regress/test1 b/varnish-tools/regress/test1
index 00470286..7c6935e1 100644
--- a/varnish-tools/regress/test1
+++ b/varnish-tools/regress/test1
@@ -21,8 +21,31 @@ sub vcl_recv {
 	comment = "client 1.0, server 1.0";
 	c1.protocol = "1.0";
 	s1.protocol = "1.0";
-	c1.request(s1, "http://www.example.com/");
-	c1.request(s1, "http://www.example.com/");
-	c1.request(s1, "http://www.example.com/");
+	c1.request(a1, "http://www.example.com/");
+	assert(c1.response.protocol == "1.0");
+    }
+
+    case c10_s11 {
+	comment = "client 1.0, server 1.1";
+	c1.protocol = "1.0";
+	s1.protocol = "1.1";
+	c1.request(a1, "http://www.example.com/");
+	assert(c1.response.protocol == "1.0");
+    }
+
+    case c11_s10 {
+	comment = "client 1.1, server 1.0";
+	c1.protocol = "1.1";
+	s1.protocol = "1.0";
+	c1.request(a1, "http://www.example.com/");
+	assert(c1.response.protocol == "1.1");
+    }
+
+    case c11_s11 {
+	comment = "client 1.1, server 1.1";
+	c1.protocol = "1.1";
+	s1.protocol = "1.1";
+	c1.request(a1, "http://www.example.com/");
+	assert(c1.response.protocol == "1.1");
     }
 }