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.
-* 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?)
+* Ticket 55.
+* Completely POD-ify Perl-code.
+* Detect and act upon unexpected death of Varnish grandchild process.
# $Id$
#
+=head1 NAME
+
+Varnish::Test - Regression test framework for Varnish
+
+=head1 DESCRIPTION
+
+The varnish regression test framework works by starting up a Varnish
+process and then communicating with this process as both client and
+server.
+
+=head1 STRUCTURE
+
+When regressions tests start, an instance of Varnish is forked off as
+a child process, and its I/O channels (std{in,out,err}) are controlled
+by the parent process which also performs the test by playing the role
+of both HTTP client and server.
+
+A single select(2)-driven loop is used to handle all activity on both
+server and client side, as well on Varnish's I/O-channels. This is
+done using IO::Multiplex.
+
+As a result of using a select-loop, the framework has an event-driven
+design in order to cope with unpredictable sequence of processing on
+either server og client side. To drive a test-case forward, the
+select-loop is paused when certain events occur, and control returns
+to the "main program" which can then inspect the situation. This
+results in certain structural constraints. It is essential to be aware
+of whether a piece of code is going to run inside or outside the
+select-loop.
+
+The framework uses Perl objects to represent instances of servers and
+clients as well as the Varnish instance itself. In addition, there is
+an "engine" object which propagates events and controls the program
+flow related to the select-loop.
+
+=cut
+
package Varnish::Test;
-use strict;
-use base 'Varnish::Test::Object';
-use Varnish::Test::Accelerator;
-use Varnish::Test::Case;
-use Varnish::Test::Client;
-use Varnish::Test::Server;
-use Varnish::Test::Parser;
-use IO::Multiplex;
+use Carp 'croak';
-use Data::Dumper;
+use Varnish::Test::Engine;
+use Varnish::Test::Case::LoadVCL;
+use Varnish::Test::Case::StartChild;
+use Varnish::Test::Case::StopChild;
-sub new($;$) {
- my $this = shift;
+sub new($) {
+ my ($this) = @_;
my $class = ref($this) || $this;
- my $fn = shift;
-
- my $self = new Varnish::Test::Object;
- bless($self, $class);
- $self->{'mux'} = new IO::Multiplex;
+ return bless({ 'cases' => [] }, $class);
+}
- if ($fn) {
- $self->parse($fn);
- }
+sub start_engine($;@) {
+ my ($self, @args) = @_;
- return $self;
+ return if defined $self->{'engine'};
+ $self->{'engine'} = Varnish::Test::Engine->new(@args);
+ $self->{'engine'}->run_loop;
}
-sub parse($$) {
- my $self = shift;
- my $fn = shift;
-
- local $/;
- open(SRC, "<", $fn) or die("$fn: $!\n");
- my $src = <SRC>;
- close(SRC);
-
- $::RD_HINT = 1;
- my $parser = new Varnish::Test::Parser;
- if (!defined($parser)) {
- die("Error generating parser.");
- }
- my $tree = $parser->module($src);
- if (!defined($tree)) {
- die("Parsing error.");
- }
-
- print STDERR "###### SYNTAX TREE BEGIN ######\n";
- print STDERR Dumper $tree if defined($tree->{'body'});
- print STDERR "###### SYNTAX TREE END ######\n";
-
- $self->{'objects'} = [];
-
- foreach my $object (@{$tree->{'body'}}) {
- if (ref($object) eq 'ARRAY') {
- $self->{$$object[0]} = $$object[1];
- }
- elsif (ref($object)) {
- push(@{$self->{'children'}}, $object);
- $object->set_parent($self);
- }
- }
+sub stop_engine($;$) {
+ my ($self) = @_;
+
+ (delete $self->{'engine'})->shutdown if defined $self->{'engine'};
}
-sub main($) {
- my $self = shift;
+sub run_case($$) {
+ my ($self, $name) = @_;
- while (!$self->{'finished'}) {
- &Varnish::Test::Object::run($self);
- print STDERR "Entering IO::Multiplex loop.\n";
- $self->{'mux'}->loop;
- }
+ my $module = 'Varnish::Test::Case::' . $name;
- print STDERR "DONE.\n";
-}
+ eval 'use ' . $module;
+ croak $@ if $@;
+
+ $self->start_engine;
+
+ my $case = $module->new($self->{'engine'});
+
+ push(@{$self->{'cases'}}, $case);
+
+ Varnish::Test::Case::LoadVCL->new($self->{'engine'})->run($case->vcl)
+ if $case->can('vcl');
-sub run($) {
- my $self = shift;
+ Varnish::Test::Case::StartChild->new($self->{'engine'})->run;
- return if $self->{'finished'};
+ $case->run;
- &Varnish::Test::Object::run($self);
+ Varnish::Test::Case::StopChild->new($self->{'engine'})->run;
- $self->shutdown if $self->{'finished'};
+ $self->stop_engine;
}
1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-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;
-
- my $backend = $self->vars->{'backend'};
- (defined($backend) &&
- $backend->isa('Varnish::Test::Server'))
- or die("invalid server\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
- $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;
- $self->{'stdout'} = $stdout;
- $self->{'stderr'} = $stderr;
-
- # 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;
-
- 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->{'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;
package Varnish::Test::Case;
use strict;
-use base 'Varnish::Test::Object';
+use Carp 'croak';
-sub _init($) {
- my $self = shift;
+use Varnish::Test::Logger;
- &Varnish::Test::Object::_init($self);
+use HTTP::Request;
+use HTTP::Response;
- $self->set('assert', \&assert);
+sub new($$) {
+ my ($this, $engine) = @_;
+ my $class = ref($this) || $this;
+
+ my $self = bless({ 'engine' => $engine,
+ 'count' => 0,
+ 'successful' => 0,
+ 'failed' => 0 }, $class);
}
-sub run($) {
- my $self = shift;
+sub log($$) {
+ my ($self, $str) = @_;
- if (!defined($self->{'started'})) {
- print "Start of CASE \"$self->{name}\"...\n";
- $self->{'started'} = 1;
- }
+ $self->{'engine'}->log($self, 'CAS: ', $str);
+}
+
+sub run($;@) {
+ my ($self, @args) = @_;
+
+ $self->{'engine'}->{'case'} = $self;
- &Varnish::Test::Object::run($self);
+ $self->log('Starting ' . ref($self));
- if ($self->{'finished'}) {
- print "End of CASE \"$self->{name}\".\n";
+ no strict 'refs';
+ foreach my $method (keys %{ref($self) . '::'}) {
+ next unless $method =~ m/^test([A-Z]\w+)/;
+ eval {
+ $self->{'count'} += 1;
+ my $result = $self->$method(@args);
+ $self->{'successful'} += 1;
+ $self->log(sprintf("%d: PASS: %s: %s\n",
+ $self->{'count'}, $method, $result || ''));
+ };
+ if ($@) {
+ $self->{'failed'} += 1;
+ $self->log(sprintf("%d: FAIL: %s: %s",
+ $self->{'count'}, $method, $@));
+ }
}
+
+ delete $self->{'engine'}->{'case'};
}
-sub assert($$) {
- my $self = shift;
- my $invocation = shift;
+sub run_loop($) {
+ my ($self) = @_;
- my $bool = $invocation->{'args'}[0]->{'return'};
+ $self->{'engine'}->run_loop;
+}
- if (!$bool) {
- print " ASSERTION DOES NOT HOLD.\n";
- }
- else {
- print " Assertion holds.\n";
- }
+sub pause_loop($;@) {
+ my ($self, @args) = @_;
+
+ $self->{'engine'}->pause_loop(@args);
+}
+
+sub new_client($) {
+ my ($self) = @_;
+
+ return Varnish::Test::Client->new($self->{'engine'});
+}
+
+sub ev_client_response($$$) {
+ my ($self, $client, $response) = @_;
+
+ $self->{'engine'}->pause_loop($response);
+}
+
+sub ev_client_timeout($$) {
+ my ($self, $client) = @_;
- $invocation->{'finished'} = 1;
+ $client->shutdown(2);
+ $self->{'engine'}->pause_loop;
}
1;
# $Id$
#
-package Varnish::Test::Response;
+package Varnish::Test::Case::LoadVCL;
use strict;
-use base 'Varnish::Test::Message';
+use base 'Varnish::Test::Case';
+
+use Carp 'croak';
+
+sub testLoadVCL($$) {
+ my ($self, $vcl) = @_;
+
+ $self->{'engine'}->{'varnish'}->send_vcl('main', $vcl);
+ $self->run_loop;
+
+ $self->{'engine'}->{'varnish'}->send_command('vcl.use main');
+ $self->run_loop;
+}
+
+sub ev_varnish_command_ok($) {
+ my ($self) = @_;
+
+ $self->pause_loop;
+}
1;
# $Id$
#
-package Varnish::Test::Request;
+package Varnish::Test::Case::StartChild;
use strict;
-use base 'Varnish::Test::Message';
+use base 'Varnish::Test::Case';
+
+use Carp 'croak';
+
+sub testStartChild($$) {
+ my ($self, $vcl) = @_;
+
+ $self->{'engine'}->{'varnish'}->start_child;
+ croak 'Inappropriate event' if $self->run_loop ne 'Started';
+ return 'OK';
+}
+
+sub ev_varnish_child_started($) {
+ my ($self) = @_;
+
+ $self->pause_loop('Started');
+}
1;
# $Id$
#
-package Varnish::Test::Message;
+package Varnish::Test::Case::StopChild;
use strict;
-use base 'Varnish::Test::Object';
+use base 'Varnish::Test::Case';
+
+use Carp 'croak';
+
+sub testStopChild($$) {
+ my ($self, $vcl) = @_;
+
+ $self->{'engine'}->{'varnish'}->stop_child;
+ croak 'Inappropriate event' if $self->run_loop ne 'Stopped';
+ return 'OK';
+}
+
+sub ev_varnish_child_stopped($) {
+ my ($self) = @_;
+
+ $self->pause_loop('Stopped');
+}
1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Case::Ticket056;
+
+use strict;
+use base 'Varnish::Test::Case';
+
+use Carp 'croak';
+
+sub testVersionMatch($) {
+ my ($self) = @_;
+
+ my $cv = $self->{'cv'};
+ my $sv = $self->{'sv'};
+
+ my $requests = $self->{'engine'}->{'server'}->{'requests'};
+
+ my $client = $self->new_client;
+
+ my $request = HTTP::Request->new('GET', '/');
+ $request->protocol($cv);
+ $client->send_request($request, 2);
+
+ my $response = $self->run_loop;
+
+ croak 'No (complete) response received' unless defined($response);
+ croak 'Server was not contacted by Varnish'
+ if $self->{'engine'}->{'server'}->{'requests'} != $requests + 1;
+ croak sprintf('Protocol version mismatch: got: %s expected: %s',
+ $response->protocol, $sv)
+ if $response->protocol ne $sv;
+
+ return sprintf("Client: %s Server: %s", $cv, $sv);
+}
+
+sub run($) {
+ my ($self) = @_;
+
+ foreach my $cv ('HTTP/1.0', 'HTTP/1.1') {
+ foreach my $sv ('HTTP/1.0', 'HTTP/1.1') {
+ $self->{'cv'} = $cv;
+ $self->{'sv'} = $sv;
+ $self->SUPER::run;
+ }
+ }
+
+ delete $self->{'cv', 'sv'};
+}
+
+sub ev_server_request($$$$) {
+ my ($self, $server, $connection, $request) = @_;
+
+ my $response = HTTP::Response->new(404, undef, undef,
+ sprintf ("%s not found\n", $request->uri));
+ $response->protocol($self->{'sv'});
+ $connection->send_response($response);
+ $connection->shutdown;
+}
+
+sub vcl($) {
+ my ($self) = @_;
+
+ return $self->{'engine'}->{'varnish'}->backend_block('main') . <<'EOVCL'
+sub vcl_recv {
+ pass;
+}
+EOVCL
+}
+
+1;
# $Id$
#
-package Varnish::Test::Invocation;
+package Varnish::Test::Case::Ticket102;
use strict;
-use base 'Varnish::Test::Object';
+use base 'Varnish::Test::Case';
-sub new($$$) {
- my $this = shift;
- my $class = ref($this) || $this;
- my $func_id = shift;
- my $args = shift;
+use Carp 'croak';
- my $self = new Varnish::Test::Object(undef, $args);
- bless($self, $class);
+our $body = "Hello World!\n";
- $self->{'func_id'} = $func_id;
- $self->{'args'} = $args;
+sub testBodyInCachedPOST($) {
+ my ($self) = @_;
- return $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 $response = $self->run_loop;
+ croak 'No (complete) response received' unless defined($response);
+ croak 'Empty body' if $response->content eq '';
+ croak 'Incorrect body' if $response->content ne $body;
+ }
}
-sub run($) {
- my $self = shift;
+sub ev_server_request($$$$) {
+ my ($self, $server, $connection, $request) = @_;
- return if $self->{'finished'};
+ my $response = HTTP::Response->new(200, undef,
+ [ 'Content-Length', length($body),
+ 'Connection', 'Keep-Alive' ],
+ $body);
+ $response->protocol('HTTP/1.1');
+ $connection->send_response($response);
+}
- &Varnish::Test::Object::run($self) unless $self->{'in_call'};
+sub vcl($) {
+ my ($self) = @_;
- if ($self->{'finished'}) {
- $self->{'finished'} = 0;
- if (!$self->{'in_call'}) {
- $self->{'in_call'} = 1;
- my ($func_ptr, $func_context) = $self->{'func_id'}->get_function($self);
- # print STDERR "Calling " . $self->{'func_id'}->as_string, "\n";
- &$func_ptr($func_context, $self);
+ return $self->{'engine'}->{'varnish'}->backend_block('main') . <<'EOVCL'
+sub vcl_recv {
+ if (req.request == "POST" &&
+ (!req.http.content-length || req.http.content-length == "0")) {
+ lookup;
}
- }
+}
+EOVCL
}
1;
package Varnish::Test::Client;
use strict;
-use base 'Varnish::Test::Object';
-use IO::Socket;
-use URI;
+use Carp 'croak';
-sub _init($) {
- my $self = shift;
+use IO::Socket::INET;
- &Varnish::Test::Object::_init($self);
+sub new($$) {
+ my ($this, $engine, $attrs) = @_;
+ my $class = ref($this) || $this;
- $self->set('protocol', '1.1');
- $self->set('request', \&request);
-}
+ my $self = bless({ 'engine' => $engine,
+ 'mux' => $engine->{'mux'},
+ 'requests' => 0,
+ 'responses' => 0 }, $class);
-sub request($$) {
- my $self = shift;
- my $invocation = shift;
+ return $self;
+}
- my $server = $invocation->{'args'}[0]->{'return'};
- my $uri = $invocation->{'args'}[1]->{'return'};
+sub log($$;$) {
+ my ($self, $str, $extra_prefix) = @_;
- (defined($server) &&
- ($server->isa('Varnish::Test::Accelerator') ||
- $server->isa('Varnish::Test::Server')))
- or die("invalid server\n");
+ $self->{'engine'}->log($self, 'CLI: ' . ($extra_prefix || ''), $str);
+}
- $uri = new URI($uri)
- or die("invalid URI\n");
+sub send_request($$;$) {
+ my ($self, $request, $timeout) = @_;
+
+ my $fh = IO::Socket::INET->new('Proto' => 'tcp',
+ 'PeerAddr' => 'localhost',
+ 'PeerPort' => '8080')
+ or croak "socket: $@";
+
+ $self->{'fh'} = $fh;
+ $self->{'mux'}->add($fh);
+ $self->{'mux'}->set_timeout($fh, $timeout) if defined($timeout);
+ $self->{'mux'}->set_callback_object($self, $fh);
+ $self->{'mux'}->write($fh, $request->as_string);
+ $self->{'requests'} += 1;
+ $self->log($request->as_string, 'Tx| ');
+}
- my $fh = new IO::Socket::INET(Proto => 'tcp',
- PeerAddr => $server->get('address'),
- PeerPort => $server->get('port'))
- or die "socket: $@";
+sub got_response($$) {
+ my ($self, $response) = @_;
- my $mux = $self->get_mux;
- $mux->add($fh);
- $mux->set_callback_object($self, $fh);
+ $self->{'responses'} += 1;
+ $self->log($response->as_string, 'Rx| ');
+ $self->{'engine'}->ev_client_response($self, $response);
+}
- $mux->write($fh, "GET / HTTP/" . eval($self->get('protocol')) . "\r\n\r\n");
+sub shutdown($) {
+ my ($self) = @_;
- $self->{'request'} = $invocation;
+ $self->{'mux'}->shutdown($self->{'fh'}, 1);
}
sub mux_input($$$$) {
- my $self = shift;
- my $mux = shift;
- my $fh = shift;
- my $data = shift;
- my $response = new Varnish::Test::Context('response', $self);
-
- $self->{'request'}->{'return'} = $$data;
- if ($$data =~ 'HTTP/1.1') {
- $response->set('protocol', '1.1');
- }
- else {
- $response->set('protocol', '1.0');
+ my ($self, $mux, $fh, $data) = @_;
+
+ while ($$data =~ /\n\r?\n/) {
+ my $response = HTTP::Response->parse($$data);
+ my $content_length = $response->content_length;
+
+ if (defined($content_length)) {
+ my $content_ref = $response->content_ref;
+ my $data_length = length($$content_ref);
+ if ($data_length == $content_length) {
+ $$data = '';
+ $self->got_response($response);
+ }
+ elsif ($data_length < $content_length) {
+ last;
+ }
+ else {
+ $$data = substr($$content_ref, $content_length,
+ $data_length - $content_length, '');
+ $self->got_response($response);
+ }
+ }
+ else {
+ last;
+ }
}
- print STDERR "Client got: $$data";
- $$data = "";
- $self->{'request'}->{'finished'} = 1;
- delete $self->{'request'};
- $self->super_run;
}
sub mux_eof($$$$) {
- my $self = shift;
- my $mux = shift;
- my $fh = shift;
- my $data = shift;
+ my ($self, $mux, $fh, $data) = @_;
+
+ if ($$data ne '') {
+ croak 'Junk or incomplete response' unless $$data =~ "\n\r?\n";
+
+ my $response = HTTP::Response->parse($$data);
+ $$data = '';
+ $self->got_response($response);
+ }
+}
+
+sub mux_timeout($$$) {
+ my ($self, $mux, $fh) = @_;
+
+ $self->{'engine'}->ev_client_timeout($self);
+}
+
+sub mux_close($$) {
+ my ($self, $mux, $fh) = @_;
- $mux->close($fh);
+ delete $self->{'fh'};
}
1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Context;
-
-use strict;
-
-#
-# A Context is an object that has a name, a type, and a set of named
-# variables and procedures associated with it. A context may have a
-# parent, from which it inherits variables and procedures.
-#
-
-sub new($$;$) {
- my $this = shift;
- my $class = ref($this) || $this;
- my $name = shift;
- my $parent = shift;
-
- my $self = {
- 'name' => $name,
- 'vars' => { },
- };
- bless($self, $class);
-
- $self->set_parent($parent);
-
- return $self;
-}
-
-sub set_parent($$) {
- my $self = shift;
- my $parent = shift;
-
- if (defined($self->{'name'})) {
- if (defined($self->{'parent'})) {
- # Unlink from old parent.
- $self->{'parent'}->unset($self->{'name'});
- }
- if (defined($parent)) {
- # Link to new parent.
- $parent->set($self->{'name'}, $self);
- }
- }
-
- $self->{'parent'} = $parent;
-}
-
-sub parent($) {
- my $self = shift;
-
- return $self->{'parent'};
-}
-
-sub vars($) {
- my $self = shift;
-
- return $self->{'vars'};
-}
-
-sub set($$$) {
- my $self = shift;
- my $key = shift;
- my $value = shift;
-
- if (!exists($self->vars->{$key}) &&
- $self->parent && $self->parent->has($key)) {
- $self->parent->set($key, $value);
- } else {
- $self->vars->{$key} = $value;
- }
- return $value;
-}
-
-sub unset($$) {
- my $self = shift;
- my $key = shift;
-
- delete $self->vars->{$key} if exists($self->vars->{$key});
-}
-
-sub has($$) {
- my $self = shift;
- my $key = shift;
-
- return exists($self->{'vars'}->{$key}) ||
- $self->parent && $self->parent->has($key);
-}
-
-sub get($$) {
- my $self = shift;
- my $key = shift;
-
- return exists($self->vars->{$key}) ? $self->vars->{$key} :
- ($self->parent && $self->parent->get($key));
-}
-
-sub type($) {
- my $self = shift;
-
- if (!defined($self->{'type'})) {
- ($self->{'type'} = ref($self)) =~ s/^(\w+::)*(\w+)$/$2/;
- print STDERR "$self->{'type'}\n";
- }
- return $self->{'type'};
-}
-
-sub name($;$) {
- my $self = shift;
-
- $self->{'name'} = shift
- if (@_);
- return $self->{'name'};
-}
-
-1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Engine;
+
+use strict;
+use Carp 'croak';
+
+use Varnish::Test::Server;
+use Varnish::Test::Varnish;
+use Varnish::Test::Client;
+use IO::Multiplex;
+
+sub new($$;%) {
+ my ($this, $controller, %config) = @_;
+ my $class = ref($this) || $this;
+
+ %config = ('server_address' => 'localhost:8081',
+ 'varnish_address' => 'localhost:8080',
+ %config);
+
+ my $self = bless({ 'mux' => IO::Multiplex->new,
+ 'controller' => $controller,
+ 'config' => \%config }, $class);
+
+ $self->{'server'} = Varnish::Test::Server->new($self);
+ $self->{'varnish'} = Varnish::Test::Varnish->new($self);
+
+ return $self;
+}
+
+sub log($$$) {
+ my ($self, $object, $prefix, $str) = @_;
+
+ $str =~ s/^/$prefix/gm;
+ $str =~ s/\n?$/\n/;
+
+ print STDERR $str;
+}
+
+sub run_loop($) {
+ my ($self) = @_;
+
+ croak 'Engine::run: Already inside select-loop. Your code is buggy.'
+ if exists($self->{'in_loop'});
+
+ $self->{'in_loop'} = 1;
+ $self->{'mux'}->loop;
+ delete $self->{'in_loop'};
+
+ return delete $self->{'return'} if exists $self->{'return'};
+ return undef;
+}
+
+sub pause_loop($;$) {
+ my ($self, $return) = @_;
+
+ croak 'Engine::pause: Not inside select-loop. Your code is buggy.'
+ unless exists($self->{'in_loop'});
+
+ $self->{'return'} = $return if defined($return);
+ $self->{'mux'}->endloop;
+}
+
+sub shutdown($) {
+ my ($self) = @_;
+
+ $self->{'varnish'}->shutdown if defined $self->{'varnish'};
+ $self->{'server'}->shutdown if defined $self->{'server'};
+ foreach my $fh ($self->{'mux'}->handles) {
+ $self->{'mux'}->close($fh);
+ }
+}
+
+sub ev_varnish_started($) {
+ my ($self) = @_;
+
+ $self->pause_loop;
+}
+
+sub AUTOLOAD ($;@) {
+ my ($self, @args) = @_;
+
+ (my $event_handler = our $AUTOLOAD) =~ s/.*://;
+
+ return if $event_handler eq 'DESTROY';
+
+ croak sprintf('received event (%s) while not running a case', $event_handler)
+ unless defined $self->{'case'};
+
+ croak sprintf('Unknown method "%s"', $event_handler)
+ unless $event_handler =~ /^ev_(.*)$/;
+
+ if ($self->{'case'}->can($event_handler)) {
+ $self->log($self, 'ENG: ', sprintf('EVENT "%s"', $1));
+ return $self->{'case'}->$event_handler(@args);
+ }
+ else {
+ $self->log($self, 'ENG: ', sprintf('EVENT "%s" IGNORED', $1));
+ return undef;
+ }
+}
+
+1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Expression;
-
-use strict;
-use base 'Varnish::Test::Object';
-use Varnish::Test::Invocation;
-
-sub new($$;$) {
- my $this = shift;
- my $class = ref($this) || $this;
- my $terms = shift;
- my $force_create = shift;
-
- if (@$terms == 1 && (!$force_create || ref($$terms[0]) eq $class)) {
- return $$terms[0];
- }
-
- my $children = [];
-
- if (@$terms == 2
- && ref($$terms[0]) eq 'Varnish::Test::Reference'
- && ref($$terms[1]) eq 'ARRAY') {
- my $invocation = new Varnish::Test::Invocation($$terms[0], $$terms[1]);
- push (@$children, $invocation);
- undef $terms;
- }
- else {
- foreach my $term (@$terms) {
- push (@$children, $term) if ref($term) eq 'Varnish::Test::Expression';
- }
- }
-
- my $self = new Varnish::Test::Object(undef, $children);
- bless($self, $class);
- $self->{'terms'} = $terms;
-
- return $self;
-}
-
-sub run($) {
- my $self = shift;
-
- return if $self->{'finished'};
-
- &Varnish::Test::Object::run($self);
-
- my $expr = '';
- my $seen_string = 0;
- my $relational = 0;
-
- if ($self->{'finished'} && defined($self->{'terms'})) {
-
- foreach my $term (@{$self->{'terms'}}) {
- my $term_value;
- if (ref($term) eq 'Varnish::Test::Expression') {
- $term_value = $term->{'return'};
- }
- elsif (ref($term) eq 'Varnish::Test::Reference') {
- $term_value = $term->get_value($self);
- if (!defined($term_value)) {
- die '"' . $term->as_string . '"' . " not defined";
- }
- }
- 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;
- }
-
- if (ref(\$term_value) eq 'REF') {
- if (@{$self->{'terms'}} == 1) {
- $self->{'return'} = $term_value;
- return;
- }
- else {
- $term_value = '"' . $term_value . '"';
- }
- }
-
- if ($term_value =~ /^".*"$/s) {
- $seen_string = 1;
- }
-
- $expr .= $term_value;
- }
-
- ($expr) = $expr =~ /(.*)/s;
-
- # print STDERR "Evaling: $expr\n";
-
- $expr = eval $expr;
-
- if ($seen_string && !$relational) {
- $expr = '"' . $expr . '"';
- }
-
- $self->{'return'} = $expr;
- }
-}
-
-1;
# $Id$
#
-package Varnish::Test::Statement;
+package Varnish::Test::Logger;
-use strict;
-use base 'Varnish::Test::Object';
-
-sub new($$) {
- my $this = shift;
+sub new($;$) {
+ my ($this, $prefix) = @_;
my $class = ref($this) || $this;
- my $args = shift;
-
- my $children = [];
-
- if (@$args > 1 && $$args[1] eq '=') {
- my $self = new Varnish::Test::Object(undef, [$$args[2]]);
- bless($self, $class);
-
- $self->{'lhs'} = $$args[0];
- return $self;
- }
- else {
- return $$args[0];
- }
+ my $self = bless({ 'prefix' => $prefix || '' }, $class);
}
-use Data::Dumper;
+sub write($$;$) {
+ my ($self, $data, $extra_prefix) = @_;
-sub run($$) {
- my $self = shift;
+ my $prefix = $self->{'prefix'};
+ $prefix .= ': ' . $extra_prefix if defined($extra_prefix);
- return if $self->{'finished'};
+ if ($prefix) {
+ $data =~ s/^/$prefix: /gm;
+ }
- &Varnish::Test::Object::run($self);
+ $data =~ s/\n?$/\n/;
- if ($self->{'finished'}) {
- $self->{'lhs'}->set_value($self->{'parent'}, $self->{'return'});
- }
+ print STDERR $data;
}
1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Object;
-
-use strict;
-use base 'Varnish::Test::Context';
-
-sub new($$$;$) {
- my $this = shift;
- my $class = ref($this) || $this;
- my $name = shift;
- my $children = shift;
- my $parent = shift;
-
- my $self = new Varnish::Test::Context($name, $parent);
- bless($self, $class);
-
- for my $child (@$children) {
- $child->set_parent($self);
- }
-
- $self->{'children'} = $children;
- $self->{'finished'} = 0;
- $self->{'return'} = undef;
- $self->_init;
-
- return $self;
-}
-
-sub _init($) {
-}
-
-sub run($) {
- my $self = shift;
-
- return if $self->{'finished'};
-
- foreach my $child (@{$self->{'children'}}) {
- $child->run($self) unless $child->{'finished'};
- return unless $child->{'finished'};
- $self->{'return'} = $child->{'return'};
- }
-
- $self->{'finished'} = 1;
-}
-
-sub shutdown($) {
- my $self = shift;
-
- foreach my $child (@{$self->{'children'}}) {
- $child->shutdown;
- }
-}
-
-sub get_mux($) {
- my $self = shift;
- return $self->{'mux'} || $self->{'parent'} && $self->{'parent'}->get_mux;
-}
-
-sub super_run($) {
- my $self = shift;
- if (defined($self->{'parent'})) {
- $self->{'parent'}->super_run;
- }
- else {
- $self->run;
- }
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2007 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Parser;
-
-use strict;
-
-use Parse::RecDescent;
-use Varnish::Test::Reference;
-use Varnish::Test::Expression;
-use Varnish::Test::Statement;
-use Varnish::Test::Client;
-use Varnish::Test::Server;
-use Varnish::Test::Accelerator;
-use Varnish::Test::Case;
-
-sub new {
- return new Parse::RecDescent(<<'EOG');
-
-STRING_LITERAL:
- { extract_delimited($text, '"') }
-
-IDENTIFIER:
- /[a-z]\w*/i
-
-CONSTANT:
- /[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
-
-reference:
- <leftop: IDENTIFIER '.' IDENTIFIER>
- { new Varnish::Test::Reference($item[1]) }
-
-argument_list:
- <leftop: expression ',' expression>
-
-call:
- reference '(' argument_list(?) ')'
- { new Varnish::Test::Expression([$item[1], (@{$item[3]}) ? $item[3][0] : []]) }
- | <error>
-
-primary_expression:
- call
- | reference
- | STRING_LITERAL
- | CONSTANT
- | '(' expression ')'
- { $item[2] }
-
-mul_op:
- '*' | '/' | '%'
-
-multiplicative_expression:
- <leftop: primary_expression mul_op primary_expression>
- { new Varnish::Test::Expression($item[1]) }
-
-add_op:
- '+' | '-' | '.'
-
-additive_expression:
- <leftop: multiplicative_expression add_op multiplicative_expression>
- { new Varnish::Test::Expression($item[1]) }
-
-rel_op:
- '==' | '!=' | '<=' | '>=' | '<' | '>'
-
-expression:
- additive_expression rel_op additive_expression
- { new Varnish::Test::Expression([@item[1..$#item]], 1) }
- | additive_expression
- { new Varnish::Test::Expression([$item[1]], 1) }
- | <error>
-
-statement:
- reference '=' expression
- { new Varnish::Test::Statement([@item[1..3]]) }
- | call
- { new Varnish::Test::Statement([$item[1]]) }
-
-block:
- '{' statement(s? /;/) (';')(?) '}'
- { $item[2] }
- | <error>
-
-object:
- 'ticket' CONSTANT ';'
- { [@item[1,2]] }
- | 'client' IDENTIFIER block
- { new Varnish::Test::Client(@item[2,3]) }
- | 'server' IDENTIFIER block
- { new Varnish::Test::Server(@item[2,3]) }
- | 'accelerator' IDENTIFIER block
- { new Varnish::Test::Accelerator(@item[2,3]) }
- | 'case' IDENTIFIER block
- { new Varnish::Test::Case(@item[2,3]) }
- | <error>
-
-module:
- 'test' STRING_LITERAL(?) '{' object(s?) '}' /^\Z/
- { { 'id' => (@{$item[2]}) ? $item[2][0] : undef,
- 'body' => $item[4] } }
- | <error>
-
-EOG
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Reference;
-
-use strict;
-
-sub new($$) {
- my $this = shift;
- my $class = ref($this) || $this;
- my $symbols = shift;
-
- my $self = {
- 'symbols' => $symbols,
- };
- bless($self, $class);
-
- return $self;
-}
-
-sub as_string($) {
- my $self = shift;
- return join('.', @{$self->{'symbols'}});
-}
-
-sub _find_context($$) {
- my $self = shift;
- my $context = shift;
-
- foreach my $symbol (@{$self->{'symbols'}}[0..$#{$self->{'symbols'}}-1]) {
- $context = $context->get($symbol);
- if (!(ref($context) =~ /^Varnish::Test::\w+$/
- && $context->isa('Varnish::Test::Context'))) {
- return undef;
- }
- }
-
- return $context;
-}
-
-sub get_value($$) {
- my $self = shift;
- my $context = shift;
-
- $context = $self->_find_context($context);
- if (defined($context)) {
- return $context->get($self->{'symbols'}[$#{$self->{'symbols'}}]);
- }
- else {
- return undef;
- }
-}
-
-sub set_value($$) {
- my $self = shift;
- my $context = shift;
- my $value = shift;
-
- $context = $self->_find_context($context);
- if (defined($context)) {
- $context->set($self->{'symbols'}[$#{$self->{'symbols'}}], $value);
- }
- else {
- die "Cannot find containing context for ", join('.', @{$self->{'symbols'}}), ".\n";
- }
-}
-
-sub get_function($$) {
- my $self = shift;
- my $context = shift;
-
- $context = $self->_find_context($context);
- if (defined($context)) {
- return ($context->get($self->{'symbols'}[$#{$self->{'symbols'}}]), $context);
- }
-}
-
-1;
package Varnish::Test::Server;
use strict;
-use base 'Varnish::Test::Object';
-use IO::Socket;
+use Carp 'croak';
-sub _init($) {
- my $self = shift;
+use IO::Socket::INET;
- &Varnish::Test::Object::_init($self);
+sub new($$) {
+ my ($this, $engine, $attrs) = @_;
+ my $class = ref($this) || $this;
- $self->set('address', 'localhost');
- $self->set('port', '9001');
-}
+ my ($host, $port) = split(':', $engine->{'config'}->{'server_address'});
-sub run($) {
- my $self = shift;
+ my $socket = IO::Socket::INET->new('Proto' => 'tcp',
+ 'LocalAddr' => $host,
+ 'LocalPort' => $port,
+ 'Listen' => 4,
+ 'ReuseAddr' => 1)
+ or croak "socket: $@";
- return if $self->{'finished'};
+ my $self = bless({ 'engine' => $engine,
+ 'mux' => $engine->{'mux'},
+ 'socket' => $socket,
+ 'requests' => 0,
+ 'responses' => 0 }, $class);
- &Varnish::Test::Object::run($self);
+ $self->{'mux'}->listen($socket);
+ $self->{'mux'}->set_callback_object($self, $socket);
- my $fh = new IO::Socket::INET(Proto => 'tcp',
- LocalAddr => $self->get('address'),
- LocalPort => $self->get('port'),
- Listen => 4)
- or die "socket: $@";
+ return $self;
+}
- $self->{'fh'} = $fh;
+sub log($$;$) {
+ my ($self, $str, $extra_prefix) = @_;
- my $mux = $self->get_mux;
- $mux->listen($fh);
- $mux->set_callback_object($self, $fh);
+ $self->{'engine'}->log($self, 'SRV: ' . ($extra_prefix || ''), $str);
}
sub shutdown($) {
- my $self = shift;
+ my ($self) = @_;
- $self->get_mux->close($self->{'fh'});
+ $self->{'mux'}->close($self->{'socket'});
+ delete $self->{'socket'};
}
sub mux_connection($$$) {
- my $self = shift;
- my $mux = shift;
- my $fh = shift;
+ my ($self, $mux, $fh) = @_;
- $mux->set_callback_object($self, $fh);
+ $self->log('CONNECT');
+ my $connection = Varnish::Test::Server::Connection->new($self, $fh);
}
-sub mux_input($$$$) {
- my $self = shift;
- my $mux = shift;
- my $fh = shift;
- my $data = shift;
+sub mux_close($$) {
+ my ($self, $mux, $fh) = @_;
+
+ $self->log('CLOSE');
+ delete $self->{'socket'} if $fh == $self->{'socket'};
+}
+
+sub got_request($$) {
+ my ($self, $connection, $request) = @_;
- $$data = ""; # Pretend we read the data.
+ $self->{'requests'} += 1;
+ $self->log($request->as_string, 'Rx| ');
+ $self->{'engine'}->ev_server_request($self, $connection, $request);
+}
+
+package Varnish::Test::Server::Connection;
+
+use strict;
+use Carp 'croak';
+
+sub new($$) {
+ my ($this, $server, $fh) = @_;
+ my $class = ref($this) || $this;
+
+ my $self = bless({ 'server' => $server,
+ 'fh' => $fh,
+ 'mux' => $server->{'mux'},
+ 'data' => '' }, $class);
+ $self->{'mux'}->set_callback_object($self, $fh);
+ return $self;
+}
+
+sub send_response($$) {
+ my ($self, $response) = @_;
+
+ $self->{'mux'}->write($self->{'fh'}, $response->as_string);
+ $self->{'server'}->{'responses'} += 1;
+ $self->{'server'}->log($response->as_string, 'Tx| ');
+}
+
+sub shutdown($) {
+ my ($self) = @_;
+
+ $self->{'mux'}->shutdown($self->{'fh'}, 1);
+}
+
+sub mux_input($$$$) {
+ my ($self, $mux, $fh, $data) = @_;
+
+ while ($$data =~ /\n\r?\n/) {
+ my $request = HTTP::Request->parse($$data);
+ my $content_ref = $request->content_ref;
+ my $content_length = $request->content_length;
+
+ if (defined($content_length)) {
+ my $data_length = length($$content_ref);
+ if ($data_length == $content_length) {
+ $$data = '';
+ $self->{'server'}->got_request($self, $request);
+ }
+ elsif ($data_length < $content_length) {
+ last;
+ }
+ else {
+ $$data = substr($$content_ref, $content_length,
+ $data_length - $content_length, '');
+ $self->{'server'}->got_request($self, $request);
+ }
+ }
+ else {
+ $$data = $$content_ref;
+ $$content_ref = '';
+ $self->{'server'}->got_request($self, $request);
+ }
+ }
+}
- 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";
+sub mux_eof($$$$) {
+ my ($self, $mux, $fh, $data) = @_;
- $mux->write($fh, $response);
- print STDERR "Server sent: " . $response;
- $mux->shutdown($fh, 1);
+ croak 'Junk or incomplete request' unless $$data eq '';
}
1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Varnish;
+
+use strict;
+use Carp 'croak';
+
+use Socket;
+
+use Varnish::Test::Logger;
+
+sub new($$;$) {
+ my ($this, $engine, $attrs) = @_;
+ my $class = ref($this) || $this;
+
+ my $self = bless({ 'engine' => $engine,
+ 'mux' => $engine->{'mux'},
+ 'state' => 'init' }, $class);
+
+ socketpair(STDIN_READ, STDIN_WRITE, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+ shutdown(STDIN_READ, 1);
+ shutdown(STDIN_WRITE, 0);
+ socketpair(STDOUT_READ, STDOUT_WRITE, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+ shutdown(STDOUT_READ, 1);
+ shutdown(STDOUT_WRITE, 0);
+ socketpair(STDERR_READ, STDERR_WRITE, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+ shutdown(STDERR_READ, 1);
+ shutdown(STDERR_WRITE, 0);
+
+ delete $SIG{CHLD};
+
+ my $pid = fork;
+ croak "fork(): $@\n" unless defined($pid);
+
+ if ($pid == 0) {
+ # Child
+
+ close STDIN_WRITE;
+ close STDOUT_READ;
+ close STDERR_READ;
+
+ open STDIN, '<&', \*STDIN_READ;
+ close STDIN_READ;
+ open STDOUT, '>&', \*STDOUT_WRITE;
+ close STDOUT_WRITE;
+ open STDERR, '>&', \*STDERR_WRITE;
+ close STDERR_WRITE;
+
+ my @opts = ('-d', '-d',
+ '-a', $engine->{'config'}->{'varnish_address'},
+ '-b', $engine->{'config'}->{'server_address'});
+
+ print STDERR sprintf("Starting Varnish with options: %s\n", join(' ', @opts));
+
+ $ENV{'PATH'} = '/opt/varnish/sbin:/bin:/usr/bin';
+ exec('varnishd', @opts);
+ exit(1);
+ }
+ else {
+ # Parent
+
+ $SIG{CHLD} = 'IGNORE';
+
+ $self->log('PID: ' . $pid);
+
+ close STDIN_READ;
+ close STDOUT_WRITE;
+ close STDERR_WRITE;
+
+ $self->{'pid'} = $pid;
+ $self->{'stdin'} = \*STDIN_WRITE;
+ $self->{'stdout'} = \*STDOUT_READ;
+ $self->{'stderr'} = \*STDERR_READ;
+
+ $self->{'mux'}->add($self->{'stdin'});
+ $self->{'mux'}->set_callback_object($self, $self->{'stdin'});
+ $self->{'mux'}->add($self->{'stdout'});
+ $self->{'mux'}->set_callback_object($self, $self->{'stdout'});
+ $self->{'mux'}->add($self->{'stderr'});
+ $self->{'mux'}->set_callback_object($self, $self->{'stderr'});
+ }
+
+ return $self;
+}
+
+sub log($$) {
+ my ($self, $str) = @_;
+
+ $self->{'engine'}->log($self, 'VAR: ', $str);
+}
+
+sub backend_block($$) {
+ my ($self, $name) = @_;
+
+ return sprintf("backend %s {\n set backend.host = \"%s\";\n set backend.port = \"%s\";\n}\n",
+ $name, split(':', $self->{'engine'}->{'config'}->{'server_address'}));
+}
+
+sub send_command($$) {
+ my ($self, $command) = @_;
+ croak 'not ready' if $self->{'state'} eq 'init';
+ croak sprintf('busy awaiting earlier command (%s)', $self->{'pending'})
+ if defined $self->{'pending'};
+
+ $self->{'mux'}->write($self->{'stdin'}, $command . "\n");
+ $self->{'pending'} = $command;
+}
+
+sub send_vcl($$$) {
+ my ($self, $config, $vcl) = @_;
+
+ $vcl =~ s/\n/ /g;
+ $vcl =~ s/"/\\"/g;
+
+ $self->send_command(sprintf('vcl.inline %s "%s"', $config, $vcl));
+}
+
+sub start_child($) {
+ my ($self) = @_;
+ croak 'not ready' if $self->{'state'} eq 'init';
+ croak 'already started' if $self->{'state'} eq 'started';
+
+ $self->send_command("start");
+}
+
+sub stop_child($) {
+ my ($self) = @_;
+ croak 'not ready' if $self->{'state'} eq 'init';
+ croak 'already stopped' if $self->{'state'} eq 'stopped';
+
+ $self->send_command("stop");
+}
+
+sub shutdown($) {
+ my ($self) = @_;
+
+ $self->{'mux'}->shutdown(delete $self->{'stdin'}, 1);
+}
+
+sub kill($;$) {
+ my ($self, $signal) = @_;
+
+ $signal ||= 15;
+ croak 'Not running' unless defined($self->{'pid'});
+ kill($signal, $self->{'pid'});
+ delete $self->{'pid'};
+}
+
+sub mux_input($$$$) {
+ my ($self, $mux, $fh, $data) = @_;
+
+ $self->log($$data);
+
+ if ($$data =~ /rolling\(2\)\.\.\./) {
+ $self->{'state'} = 'stopped';
+ $self->{'engine'}->ev_varnish_started;
+ }
+ if ($$data =~ /Child starts/) {
+ $self->{'state'} = 'started';
+ $self->{'engine'}->ev_varnish_child_started;
+ }
+ if ($$data =~ /Child dies/) {
+ $self->{'state'} = 'stopped';
+ $self->{'engine'}->ev_varnish_child_stopped;
+ }
+
+ $self->{'engine'}->ev_varnish_command_ok(delete $self->{'pending'})
+ if ($$data =~ /^200 0/ and $self->{'pending'});
+
+ $$data = '';
+}
+
+1;
+++ /dev/null
-test "Preserve HTTP protocol version in PASS mode" {
- ticket 56;
-
- client c1 {
- }
-
- server s1 {
- data = "This is a test.";
- }
-
- accelerator a1 {
- backend = s1;
- vcl = "
-sub vcl_recv {
- pass;
-}
-";
- }
-
- case c10_s10 {
- comment = "client 1.0, server 1.0";
- c1.protocol = "1.0";
- s1.protocol = "1.0";
- 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");
- }
-}
#
use strict;
-use lib './lib';
+
+use FindBin;
+
+BEGIN {
+ $FindBin::Bin =~ /^(.*)$/;
+ $FindBin::Bin = $1;
+}
+
+use lib "$FindBin::Bin/lib";
+
+use Getopt::Long;
use Varnish::Test;
-use Data::Dumper;
+
+my $verbose = 0;
+my $help = 0;
+
+my $usage = <<"EOU";
+USAGE:
+
+ $0 CASE1 [ CASE2 ... ]
+
+ where CASEn is either a full case name or a ticket number
+
+Examples:
+
+ $0 Ticket102
+ $0 102
+
+EOU
MAIN:{
- my $test = new Varnish::Test($ARGV[0]);
- #print STDERR Dumper($test);
- $test->main;
+ $help = 1 unless GetOptions('help|h!' => \$help);
+
+ if (!$help and @ARGV == 0) {
+ print STDERR "ERROR: Need at least one case name (or ticket number)\n\n";
+ $help = 1;
+ }
+
+ if ($help) {
+ print STDERR $usage;
+ exit 1;
+ }
+
+ my @casenames = ();
+
+ foreach my $arg (@ARGV) {
+ my $case;
+
+ if ($arg =~ /^(\d+)$/) {
+ push(@casenames, sprintf('Ticket%03d', $1));
+ }
+ else {
+ $arg =~ /^(.*)$/;
+ push(@casenames, $1);
+ }
+ }
+
+ my $controller = Varnish::Test->new;
+
+ foreach my $casename (@casenames) {
+ $controller->run_case($casename);
+ }
+
+ foreach my $case (@{$controller->{'cases'}}) {
+ (my $name = ref($case)) =~ s/.*://;
+
+ print sprintf("%s: Successful: %d Failed: %d\n",
+ $name, $case->{'successful'}, $case->{'failed'});
+ }
}
projects / varnish / commitdiff