From 141ec760dd26e7602b24189b367488a89880cf38 Mon Sep 17 00:00:00 2001 From: knutroy Date: Tue, 12 Jun 2007 12:26:03 +0000 Subject: [PATCH] Rewrote much of regression test framework. Test-cases for tickets #56 and #102 are included. Test-case for #102 breaks on r1506 (onwards). git-svn-id: svn+ssh://projects.linpro.no/svn/varnish/trunk@1510 d4fa192b-c00b-0410-8231-f00ffab90ce4 --- varnish-tools/regress/README | 56 ----- varnish-tools/regress/TODO | 26 +-- varnish-tools/regress/lib/Varnish/Test.pm | 141 ++++++------ .../regress/lib/Varnish/Test/Accelerator.pm | 183 ---------------- .../regress/lib/Varnish/Test/Case.pm | 90 +++++--- .../Test/{Response.pm => Case/LoadVCL.pm} | 22 +- .../Test/{Request.pm => Case/StartChild.pm} | 20 +- .../Test/{Message.pm => Case/StopChild.pm} | 20 +- .../lib/Varnish/Test/Case/Ticket056.pm | 98 +++++++++ .../Test/{Invocation.pm => Case/Ticket102.pm} | 58 ++--- .../regress/lib/Varnish/Test/Client.pm | 136 +++++++----- .../regress/lib/Varnish/Test/Context.pm | 143 ------------- .../regress/lib/Varnish/Test/Engine.pm | 131 ++++++++++++ .../regress/lib/Varnish/Test/Expression.pm | 142 ------------- .../Varnish/Test/{Statement.pm => Logger.pm} | 41 ++-- .../regress/lib/Varnish/Test/Object.pm | 98 --------- .../regress/lib/Varnish/Test/Parser.pm | 133 ------------ .../regress/lib/Varnish/Test/Reference.pm | 105 --------- .../regress/lib/Varnish/Test/Server.pm | 147 +++++++++---- .../regress/lib/Varnish/Test/Varnish.pm | 201 ++++++++++++++++++ varnish-tools/regress/test1 | 51 ----- varnish-tools/regress/varnish-regress.pl | 71 ++++++- 22 files changed, 933 insertions(+), 1180 deletions(-) delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Accelerator.pm rename varnish-tools/regress/lib/Varnish/Test/{Response.pm => Case/LoadVCL.pm} (78%) rename varnish-tools/regress/lib/Varnish/Test/{Request.pm => Case/StartChild.pm} (79%) rename varnish-tools/regress/lib/Varnish/Test/{Message.pm => Case/StopChild.pm} (79%) create mode 100644 varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm rename varnish-tools/regress/lib/Varnish/Test/{Invocation.pm => Case/Ticket102.pm} (55%) delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Context.pm create mode 100644 varnish-tools/regress/lib/Varnish/Test/Engine.pm delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Expression.pm rename varnish-tools/regress/lib/Varnish/Test/{Statement.pm => Logger.pm} (70%) delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Object.pm delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Parser.pm delete mode 100644 varnish-tools/regress/lib/Varnish/Test/Reference.pm create mode 100644 varnish-tools/regress/lib/Varnish/Test/Varnish.pm delete mode 100644 varnish-tools/regress/test1 diff --git a/varnish-tools/regress/README b/varnish-tools/regress/README index 5e5ebfe6..e39a404f 100644 --- a/varnish-tools/regress/README +++ b/varnish-tools/regress/README @@ -2,59 +2,3 @@ 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 index 3f6e4bf1..b18e677d 100644 --- a/varnish-tools/regress/TODO +++ b/varnish-tools/regress/TODO @@ -1,23 +1,3 @@ -* 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. diff --git a/varnish-tools/regress/lib/Varnish/Test.pm b/varnish-tools/regress/lib/Varnish/Test.pm index c01dc248..3fb590f2 100644 --- a/varnish-tools/regress/lib/Varnish/Test.pm +++ b/varnish-tools/regress/lib/Varnish/Test.pm @@ -28,92 +28,97 @@ # $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 = ; - 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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm b/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm deleted file mode 100644 index 42fabc59..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Accelerator.pm +++ /dev/null @@ -1,183 +0,0 @@ -#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Case.pm b/varnish-tools/regress/lib/Varnish/Test/Case.pm index 473bf5ee..c4d188e7 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Case.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Case.pm @@ -31,45 +31,85 @@ 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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Response.pm b/varnish-tools/regress/lib/Varnish/Test/Case/LoadVCL.pm similarity index 78% rename from varnish-tools/regress/lib/Varnish/Test/Response.pm rename to varnish-tools/regress/lib/Varnish/Test/Case/LoadVCL.pm index 60f72ada..0ddcd6e2 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Response.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Case/LoadVCL.pm @@ -28,9 +28,27 @@ # $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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Request.pm b/varnish-tools/regress/lib/Varnish/Test/Case/StartChild.pm similarity index 79% rename from varnish-tools/regress/lib/Varnish/Test/Request.pm rename to varnish-tools/regress/lib/Varnish/Test/Case/StartChild.pm index d872dc3b..66896d80 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Request.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Case/StartChild.pm @@ -28,9 +28,25 @@ # $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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Message.pm b/varnish-tools/regress/lib/Varnish/Test/Case/StopChild.pm similarity index 79% rename from varnish-tools/regress/lib/Varnish/Test/Message.pm rename to varnish-tools/regress/lib/Varnish/Test/Case/StopChild.pm index ad58e722..32efca88 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Message.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Case/StopChild.pm @@ -28,9 +28,25 @@ # $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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm b/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm new file mode 100644 index 00000000..b3360dad --- /dev/null +++ b/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm @@ -0,0 +1,98 @@ +#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Invocation.pm b/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm similarity index 55% rename from varnish-tools/regress/lib/Varnish/Test/Invocation.pm rename to varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm index cde72f2a..0d738e4f 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Invocation.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm @@ -28,42 +28,52 @@ # $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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Client.pm b/varnish-tools/regress/lib/Varnish/Test/Client.pm index 42b20382..a549a10e 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Client.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Client.pm @@ -31,76 +31,110 @@ 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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Context.pm b/varnish-tools/regress/lib/Varnish/Test/Context.pm deleted file mode 100644 index 9c02d4c7..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Context.pm +++ /dev/null @@ -1,143 +0,0 @@ -#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Engine.pm b/varnish-tools/regress/lib/Varnish/Test/Engine.pm new file mode 100644 index 00000000..0d6952ac --- /dev/null +++ b/varnish-tools/regress/lib/Varnish/Test/Engine.pm @@ -0,0 +1,131 @@ +#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Expression.pm b/varnish-tools/regress/lib/Varnish/Test/Expression.pm deleted file mode 100644 index c436e956..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Expression.pm +++ /dev/null @@ -1,142 +0,0 @@ -#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Statement.pm b/varnish-tools/regress/lib/Varnish/Test/Logger.pm similarity index 70% rename from varnish-tools/regress/lib/Varnish/Test/Statement.pm rename to varnish-tools/regress/lib/Varnish/Test/Logger.pm index 15cfe54d..664b10e9 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Statement.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Logger.pm @@ -28,43 +28,28 @@ # $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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Object.pm b/varnish-tools/regress/lib/Varnish/Test/Object.pm deleted file mode 100644 index 5c1a8124..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Object.pm +++ /dev/null @@ -1,98 +0,0 @@ -#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Parser.pm b/varnish-tools/regress/lib/Varnish/Test/Parser.pm deleted file mode 100644 index f2f21dcb..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Parser.pm +++ /dev/null @@ -1,133 +0,0 @@ -#!/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: - - { new Varnish::Test::Reference($item[1]) } - -argument_list: - - -call: - reference '(' argument_list(?) ')' - { new Varnish::Test::Expression([$item[1], (@{$item[3]}) ? $item[3][0] : []]) } - | - -primary_expression: - call - | reference - | STRING_LITERAL - | CONSTANT - | '(' expression ')' - { $item[2] } - -mul_op: - '*' | '/' | '%' - -multiplicative_expression: - - { new Varnish::Test::Expression($item[1]) } - -add_op: - '+' | '-' | '.' - -additive_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) } - | - -statement: - reference '=' expression - { new Varnish::Test::Statement([@item[1..3]]) } - | call - { new Varnish::Test::Statement([$item[1]]) } - -block: - '{' statement(s? /;/) (';')(?) '}' - { $item[2] } - | - -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]) } - | - -module: - 'test' STRING_LITERAL(?) '{' object(s?) '}' /^\Z/ - { { 'id' => (@{$item[2]}) ? $item[2][0] : undef, - 'body' => $item[4] } } - | - -EOG -} - -1; diff --git a/varnish-tools/regress/lib/Varnish/Test/Reference.pm b/varnish-tools/regress/lib/Varnish/Test/Reference.pm deleted file mode 100644 index 29f20bd1..00000000 --- a/varnish-tools/regress/lib/Varnish/Test/Reference.pm +++ /dev/null @@ -1,105 +0,0 @@ -#!/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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Server.pm b/varnish-tools/regress/lib/Varnish/Test/Server.pm index d52517b2..d85a53ff 100644 --- a/varnish-tools/regress/lib/Varnish/Test/Server.pm +++ b/varnish-tools/regress/lib/Varnish/Test/Server.pm @@ -31,67 +31,136 @@ 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; diff --git a/varnish-tools/regress/lib/Varnish/Test/Varnish.pm b/varnish-tools/regress/lib/Varnish/Test/Varnish.pm new file mode 100644 index 00000000..8873f6aa --- /dev/null +++ b/varnish-tools/regress/lib/Varnish/Test/Varnish.pm @@ -0,0 +1,201 @@ +#!/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; diff --git a/varnish-tools/regress/test1 b/varnish-tools/regress/test1 deleted file mode 100644 index 7c6935e1..00000000 --- a/varnish-tools/regress/test1 +++ /dev/null @@ -1,51 +0,0 @@ -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"); - } -} diff --git a/varnish-tools/regress/varnish-regress.pl b/varnish-tools/regress/varnish-regress.pl index c82d2495..81e512e4 100755 --- a/varnish-tools/regress/varnish-regress.pl +++ b/varnish-tools/regress/varnish-regress.pl @@ -29,12 +29,73 @@ # 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'}); + } } -- 2.39.5