r4051 - in trunk/varnish-tools/regress: . bin doc lib/Varnish lib/Varnish/Test lib/Varnish/Test/Case lib/Varnish/Test/Report lib/Varnish/Test/Server
tfheen at projects.linpro.no
tfheen at projects.linpro.no
Mon May 4 22:22:41 CEST 2009
Author: tfheen
Date: 2009-05-04 22:22:41 +0200 (Mon, 04 May 2009)
New Revision: 4051
Removed:
trunk/varnish-tools/regress/MANIFEST
trunk/varnish-tools/regress/Makefile.PL
trunk/varnish-tools/regress/README
trunk/varnish-tools/regress/bin/varnish-regress.pl
trunk/varnish-tools/regress/doc/README
trunk/varnish-tools/regress/doc/structure.dia
trunk/varnish-tools/regress/lib/Varnish/Test.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/POST.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Pipeline.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket164.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Client.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Engine.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Report.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Report/HTML.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Report/report.html
trunk/varnish-tools/regress/lib/Varnish/Test/Server.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Server/Connection.pm
trunk/varnish-tools/regress/lib/Varnish/Test/Varnish.pm
Log:
Get rid of old regress suite
The old regress suite has been superseded by varnishtest, so nuke
this.
Fixes #493
Deleted: trunk/varnish-tools/regress/MANIFEST
===================================================================
--- trunk/varnish-tools/regress/MANIFEST 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/MANIFEST 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,23 +0,0 @@
-bin/varnish-regress.pl
-doc/README
-doc/structure.dia
-lib/Varnish/Test.pm
-lib/Varnish/Test/Case.pm
-lib/Varnish/Test/Case/LRU.pm
-lib/Varnish/Test/Case/POST.pm
-lib/Varnish/Test/Case/RePurge.pm
-lib/Varnish/Test/Case/Ticket056.pm
-lib/Varnish/Test/Case/Ticket102.pm
-lib/Varnish/Test/Case/Ticket128.pm
-lib/Varnish/Test/Case/Vary.pm
-lib/Varnish/Test/Client.pm
-lib/Varnish/Test/Engine.pm
-lib/Varnish/Test/Report.pm
-lib/Varnish/Test/Report/HTML.pm
-lib/Varnish/Test/Report/report.html
-lib/Varnish/Test/Server.pm
-lib/Varnish/Test/Server/Connection.pm
-lib/Varnish/Test/Varnish.pm
-Makefile.PL
-MANIFEST
-README
Deleted: trunk/varnish-tools/regress/Makefile.PL
===================================================================
--- trunk/varnish-tools/regress/Makefile.PL 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/Makefile.PL 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,6 +0,0 @@
-# $Id$
-
-use ExtUtils::MakeMaker;
-
-WriteMakefile(NAME => 'Varnish::Test',
- EXE_FILES => ['bin/varnish-regress.pl']);
Deleted: trunk/varnish-tools/regress/README
===================================================================
--- trunk/varnish-tools/regress/README 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/README 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,7 +0,0 @@
-You will need the following Perl modules to run the test framework:
-
-Perl module Debian package FreeBSD port
-============================================================================
-LWP::UserAgent libwww-perl www/p5-libwww
-IO::Multiplex libio-multiplex-perl devel/p5-IO-Multiplex
-Template libtemplate-perl www/p5-Template-Toolkit
Deleted: trunk/varnish-tools/regress/bin/varnish-regress.pl
===================================================================
--- trunk/varnish-tools/regress/bin/varnish-regress.pl 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/bin/varnish-regress.pl 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,122 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-varnish-regress.pl - run Varnish regression tests
-
-=head1 DESCRIPTION
-
-This program is a thin wrapper around the L<Varnish::Test> regression
-test framework library. Using this library, regression tests are
-performed on Varnish.
-
-The Varnish daemon (L<varnishd>) must be available in one of the
-directories given by the "PATH" environment variable.
-
-By default, this program will run all test-cases available in the
-regression test framework library, or the test-cases selected by name
-as arguments on the command line.
-
-=head1 OUTPUT
-
-STDERR is used to continually report progress during testing.
-
-STDOUT is used to output a HTML-formatted report at the end of the
-run, provided that execution does not abort prematurely for any
-reason.
-
-=cut
-
-use strict;
-
-eval { require Varnish::Test };
-if ($@) {
- use FindBin;
- use lib "$FindBin::Bin/../lib";
-}
-
-use Getopt::Long;
-use Varnish::Test;
-use Varnish::Test::Report::HTML;
-
-sub usage() {
- print STDERR <<EOU;
-USAGE:
-
- $0 [CASE ...]
-
- where CASE is either a full case name or a ticket number. By
- default, all available test cases will be run.
-
-Examples:
-
- $0
- $0 Ticket102
- $0 102
-
-EOU
- exit 1;
-}
-
-MAIN:{
- GetOptions('help|h!' => \&usage)
- or usage();
-
- my $controller = new Varnish::Test;
- my @all_cases = $controller->cases();
-
- if (@ARGV == 1 && $ARGV[0] eq 'list') {
- print join(' ', @all_cases), "\n";
- exit 0;
- }
-
- if (!@ARGV) {
- @ARGV = @all_cases;
- } else {
- map { s/^(\d+)$/sprintf('Ticket%03d', $1)/e } @ARGV;
- }
-
- $controller->start_engine();
- foreach my $casename (@ARGV) {
- $controller->run_case($casename);
- }
- $controller->stop_engine();
-
- my $report = new Varnish::Test::Report::HTML;
- $report->run($controller->results());
-}
-
-=head1 SEE ALSO
-
-L<Varnish::Test>
-L<Varnish::Test::Report>
-
-=cut
Deleted: trunk/varnish-tools/regress/doc/README
===================================================================
--- trunk/varnish-tools/regress/doc/README 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/doc/README 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,4 +0,0 @@
-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.
Deleted: trunk/varnish-tools/regress/doc/structure.dia
===================================================================
(Binary files differ)
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/LRU.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,107 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::LRU;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $prefix = __PACKAGE__;
-
-# Number of repetitions; total size of data set will be approximately
-# (25 * $repeat * $repeat), and needs to be larger than the size of
-# the storage file for the test to be meaningful.
-our $repeat = 256;
-
-our $DESCR = "Tests the LRU code by running more data through Varnish" .
- " than the cache can hold, while simultaneously repeatedly requesting" .
- " one particular object, which should remain in cache throughout. The" .
- " total amount of space consumed is approximately $repeat * round(" .
- ((length(__PACKAGE__) + 5) * $repeat) . ", PAGE_SIZE).";
-
-sub _testLRU($$) {
- my ($self, $n) = @_;
-
- my $client = $self->new_client();
- my $uri = __PACKAGE__ . "::$n";
- my $request = $self->get($client, $uri);
- my $response = $self->wait();
- $self->assert_body(qr/^(?:\Q$uri\E){$repeat}$/);
- $client->shutdown();
- return $response;
-}
-
-sub testLRU($) {
- my ($self) = @_;
-
- my $response = $self->_testLRU(0);
- die "Invalid X-Varnish in response"
- unless $response->header("X-Varnish") =~ m/^(\d+)$/;
- my $xid0 = $1;
-
- # Send $repeat requests in an attempt to eat through the entire
- # storage file. Keep one object hot throughout.
- #
- #XXX We should check to see if the child dies while we do this.
- #XXX Currently, when testing a pre-LRU version of Varnish, we will
- #XXX most likely get a client timeout and the test framework will
- #XXX get stuck.
- for (my $n = 1; $n < $repeat; ++$n) {
- # cold object
- $self->_testLRU($n);
-
- # Slow down! If we run through the cache faster than the
- # hysteresis in the LRU code, the hot object will be evicted.
- $self->usleep(100000);
-
- # hot object
- $response = $self->_testLRU(0);
- die "Cache miss on hot object"
- unless $response->header("X-Varnish") =~ m/^(\d+)\s+($xid0)$/o;
- }
-
- # Re-request an object which should have been evicted. If we get
- # a cache hit, the test is inconclusive and needs to be re-run
- # with a smaller storage file or a larger value of $repeat.
- $response = $self->_testLRU(1);
- die "Inconclusive test\n"
- unless $response->header("X-Varnish") =~ m/^(\d+)$/;
-
- return 'OK';
-}
-
-sub server($$$) {
- my ($self, $request, $response) = @_;
-
- $response->content($request->uri() x $repeat);
- $response->header('Cache-Control' => 'max-age=3600');
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/POST.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/POST.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/POST.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,125 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::POST;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Tests Varnish's ability to correctly pass POST requests" .
- " to the backend, and their replies back to the client.";
-our $NOTES = "1.1.2 is expected to fail one of three subtests.";
-
-our $VCL = <<EOVCL;
-sub vcl_recv {
- if (req.request == "POST") {
- if (!req.http.content-length || req.http.content-length == "0") {
- lookup;
- }
- if (req.url ~ "pass") {
- pass;
- }
- pipe;
- }
-}
-EOVCL
-
-our $MAGIC_WORDS = "Squeamish Ossifrage";
-our $NOTHING_HAPPENS = "Nothing happens.";
-
-sub testPassPOST($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
- $self->post($client, "/pass_me", [], $MAGIC_WORDS);
- $self->wait();
- $self->assert_ok();
- $self->assert_xid();
- $self->assert_body(qr/\Q$MAGIC_WORDS\E/);
-
- return 'OK';
-}
-
-sub testPipePOST($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
- $self->post($client, "/pipe_me", [], $MAGIC_WORDS);
- $self->wait();
- $self->assert_ok();
- $self->assert_no_xid();
- $self->assert_body(qr/\Q$MAGIC_WORDS\E/);
-
- return 'OK';
-}
-
-sub testCachePOST($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- # Warm up the cache
- $self->post($client, "/cache_me");
- $self->wait();
- $self->assert_ok();
- $self->assert_uncached();
- $self->assert_body(qr/\Q$NOTHING_HAPPENS\E/);
-
- # Verify that the request was cached
- $self->post($client, "/cache_me");
- $self->wait();
- $self->assert_ok();
- $self->assert_cached();
- $self->assert_body(qr/\Q$NOTHING_HAPPENS\E/);
-
- return 'OK';
-}
-
-sub server_get($$$) {
- my ($self, $request, $response) = @_;
-
- # Varnish will always use GET when fetching a presumably cacheable
- # object from the backend. This is not a bug.
- goto &server_post
- if ($request->uri =~ m/cache_me/);
- die "Got GET request instead of POST\n";
-}
-
-sub server_post($$$) {
- my ($self, $request, $response) = @_;
-
- if ($request->content()) {
- $response->content("The Magic Words are " . $request->content());
- } else {
- $response->content($NOTHING_HAPPENS);
- }
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Pipeline.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Pipeline.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Pipeline.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,105 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Pipeline;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Tests Varnish's ability to handle pipelined requests.";
-our $NOTES = "1.1.2 is expected to fail one of two subtests.";
-
-our %CONTENT = (
- 'Gibson' => "The sky above the port was the color of television, tuned to a dead channel.",
- 'Tolkien' => "In a hole in the ground there lived a hobbit.",
- 'Williams' => "I have always depended upon the kindness of strangers.",
-);
-
-our $REPS = 4096;
-
-our $VCL = <<EOVCL;
-sub vcl_recv {
- if (req.request == "POST") {
- pass;
- }
-}
-EOVCL
-
-sub testPipelineGet($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
- foreach my $author (sort keys %CONTENT) {
- $self->get($client, "/$author");
- }
- foreach my $author (sort keys %CONTENT) {
- $self->wait();
- $self->assert_ok();
- $self->assert_xid();
- $self->assert_body(qr/\Q$CONTENT{$author}\E/);
- }
-
- return 'OK'
-}
-
-sub testPipelinePost($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
- foreach my $author (sort keys %CONTENT) {
- $self->post($client, "/$author", [], $CONTENT{$author} x $REPS);
- }
- foreach my $author (sort keys %CONTENT) {
- $self->wait();
- $self->assert_ok();
- $self->assert_xid();
- $self->assert_body(qr/\Q$CONTENT{$author}\E/);
- }
-
- return 'OK'
-}
-
-sub server($$$) {
- my ($self, $request, $response) = @_;
-
- my ($author) = ($request->uri =~ m/(\w+)$/);
- if ($CONTENT{$author}) {
- if ($request->method eq 'POST') {
- die "Not the content I expected\n"
- unless $request->content eq $CONTENT{$author} x $REPS;
- }
- $response->content($CONTENT{$author});
- } else {
- $response->code(404);
- $response->content("Unknown author.\n");
- }
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/RePurge.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,108 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::RePurge;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Tests the VCL purge() function by warming up the cache," .
- " then submitting a request that causes part of it to be purged," .
- " before finally verifying that the objects that should have been" .
- " purged were and those that shouldn't weren't.";
-
-our $VCL = <<EOVCL;
-sub vcl_recv {
- if (req.request == "REPURGE") {
- purge_url(req.url);
- error 404 "Purged";
- }
-}
-EOVCL
-
-our $KEEP_URL = '/will-be-kept';
-our $PURGE_URL = '/will-be-purged';
-our $PURGE_RE = 'purge';
-
-sub testPagePurged($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- # Warm up the cache
- $self->get($client, $KEEP_URL);
- $self->wait();
- $self->assert_ok();
- $self->get($client, $PURGE_URL);
- $self->wait();
- $self->assert_ok();
-
- # Verify the state of the cache
- $self->get($client, $KEEP_URL);
- $self->wait();
- $self->assert_ok();
- $self->assert_cached();
- $self->get($client, $PURGE_URL);
- $self->wait();
- $self->assert_ok();
- $self->assert_cached();
-
- # Send the purge request
- $self->request($client, 'REPURGE', $PURGE_RE);
- $self->wait();
-
- # Verify the state of the cache
- $self->get($client, $KEEP_URL);
- $self->wait();
- $self->assert_ok();
- $self->assert_cached();
- $self->get($client, $PURGE_URL);
- $self->wait();
- $self->assert_ok();
- $self->assert_uncached();
-
- $client->shutdown();
-
- return 'OK';
-}
-
-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
-
- my $body = $request->url;
- my $response = HTTP::Response->new(200, undef,
- [ 'Content-Length', length($body),
- 'Connection', 'Keep-Alive' ],
- $body);
- $response->protocol('HTTP/1.1');
- $connection->send_response($response);
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket056.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,97 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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';
-
-our $DESCR = "Checks that Varnish passes the correct HTTP version" .
- " to both server and client in pass mode.";
-
-our $VCL = "
-sub vcl_recv {
- pass;
-}
-";
-
-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 ($event, $response) =
- $self->run_loop('ev_client_response', 'ev_client_timeout');
-
- die "Client time-out before receiving a (complete) response\n"
- if $event eq 'ev_client_timeout';
- die "Server was not contacted by Varnish\n"
- if $self->{'engine'}->{'server'}->{'requests'} != $requests + 1;
- die sprintf("Protocol version mismatch: got: %s expected: %s\n",
- $response->protocol, $sv)
- if $response->protocol ne $sv;
-
- $client->shutdown();
-
- 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 server($$$) {
- my ($self, $request, $response) = @_;
-
- $response->code(404);
- $response->content(sprintf("%s not found\n", $request->uri));
- $response->protocol($self->{'sv'});
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket102.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,81 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Ticket102;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Checks that Varnish includes the response body when" .
- " handling GET and POST, but not when handling HEAD.";
-
-our $VCL = <<EOVCL;
-sub vcl_recv {
- if (req.request == "POST" &&
- (!req.http.content-length || req.http.content-length == "0")) {
- lookup;
- }
-}
-EOVCL
-
-our $BODY = "Hello World!\n";
-
-sub testBodyInCachedPOST($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- $self->get($client, '/');
- $self->wait();
- $self->assert_body($BODY);
- $self->assert_uncached();
-
- $self->post($client, '/');
- $self->wait();
- $self->assert_body($BODY);
- $self->assert_cached();
-
- $self->head($client, '/');
- $self->wait();
- $self->assert_no_body();
- $self->assert_cached();
-
- $client->shutdown();
-
- return 'OK';
-}
-
-sub server($$$) {
- my ($self, $request, $response) = @_;
-
- $response->content($BODY);
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket128.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,60 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Ticket128;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Tests the synthetic error response code.";
-
-our $CODE = 400;
-our $MESSAGE = "These are not the droids you are looking for";
-
-our $VCL = <<EOVCL;
-sub vcl_recv {
- error $CODE "$MESSAGE";
-}
-EOVCL
-
-sub testSyntheticError($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
- $self->get($client, '/');
- $self->wait();
- $self->assert_code($CODE);
- $self->assert_body(qr/\Q$MESSAGE\E/);
- $client->shutdown();
-
- return 'OK';
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket164.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket164.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Ticket164.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,89 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Ticket164;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Exercises a bug in the backend HTTP path.";
-
-sub testGarbledResponse($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- $self->get($client, '/garbled');
- $self->wait();
- $self->assert_code(503);
- $client->shutdown();
-
- return 'OK';
-}
-
-sub testPartialResponse($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- $self->get($client, '/partial');
- $self->wait();
- $self->assert_code(503);
- $client->shutdown();
-
- return 'OK';
-}
-
-sub testNoResponse($) {
- my ($self) = @_;
-
- my $client = $self->new_client;
-
- $self->get($client, '/none');
- $self->wait();
- $self->assert_code(503);
- $client->shutdown();
-
- return 'OK';
-}
-
-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
-
- if ($request->uri =~ m/garbled/) {
- $connection->write("Garbled response\r\n");
- } elsif ($request->uri =~ m/partial/) {
- $connection->write("HTTP/1.1 200 OK\r\n");
- $connection->write("Oops: incomplete response\r\n");
- }
- $connection->shutdown();
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case/Vary.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,82 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Vary;
-
-use strict;
-use base 'Varnish::Test::Case';
-
-our $DESCR = "Tests Vary: support by requesting the same document" .
- " in different languages and verifying that the correct version" .
- " is returned and cached.";
-
-our %languages = (
- 'en' => "Hello World!\n",
- 'no' => "Hallo Verden!\n",
-);
-
-sub testVary($) {
- my ($self) = @_;
-
- my $client = $self->new_client();
-
- foreach my $lang (keys %languages) {
- $self->get($client, '/', [ 'Accept-Language', $lang]);
- $self->wait();
- # $self->assert_uncached();
- $self->assert_header('Language', $lang);
- $self->assert_body($languages{$lang});
- }
- foreach my $lang (keys %languages) {
- $self->get($client, '/', [ 'Accept-Language', $lang]);
- $self->wait();
- $self->assert_cached();
- $self->assert_body($languages{$lang});
- }
-
- $client->shutdown();
- return 'OK';
-}
-
-sub server($$$) {
- my ($self, $request, $response) = @_;
-
- if (my $lang = $request->header("Accept-Language")) {
- $lang = 'en'
- unless ($lang && $languages{$lang});
- $response->content($languages{$lang});
- $response->header('Language' => $lang);
- $response->header('Vary' => 'Accept-Language');
- } else {
- die 'Not ready for this!';
- }
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Case.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,605 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Case - test-case superclass
-
-=head1 DESCRIPTION
-
-Varnish::Test::Case is the superclass of test-case clases. It provides
-functionality to run a number of tests defined in methods whose names
-start with "test", as well as keeping track of the number of
-successful or failed tests.
-
-It also provides default event handlers for "ev_client_response" and
-"ev_client_timeout", which are standard for most test-cases.
-
-=head1 METHODS
-
-=cut
-
-package Varnish::Test::Case;
-
-use strict;
-
-use Varnish::Test::Client;
-use HTTP::Request;
-use HTTP::Response;
-use POSIX qw(strftime);
-use Time::HiRes qw(gettimeofday tv_interval);
-
-=head2 new
-
-Create a new Case object.
-
-=cut
-
-sub new($$) {
- my ($this, $engine) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({ 'engine' => $engine,
- 'count' => 0,
- 'successful' => 0,
- 'failed' => 0 }, $class);
-}
-
-=head2 log
-
-Logging facility.
-
-=cut
-
-sub log($$) {
- my ($self, $str) = @_;
-
- $self->{'engine'}->log($self, 'CAS: ', $str);
-}
-
-=head2 init
-
-Test-case initialization which loads specified VCL into Varnish and
-starts the Varnish daemon's child.
-
-=cut
-
-sub init($) {
- my ($self) = @_;
- my ($code, $text);
-
- $self->{'engine'}->{'case'} = $self;
-
- my $varnish = $self->{'engine'}->{'varnish'};
-
- # Load VCL script if we have one
- no strict 'refs';
- if (${ref($self)."::VCL"}) {
- my $vcl = $varnish->backend_block('main') . ${ref($self)."::VCL"};
-
- ($code, $text) = $varnish->send_vcl(ref($self), $vcl);
- if ($code != 200) {
- $self->{'failed'} += 1;
- die "Unable to load VCL\n";
- }
- ($code, $text) = $varnish->use_vcl(ref($self));
- if ($code != 200) {
- $self->{'failed'} += 1;
- die "Unable to load VCL\n";
- }
- }
-
- $varnish->set_param('vcl_trace' => 'on');
-
- # Start the child
- ($code, $text) = $varnish->start_child();
- if ($code != 200) {
- $self->{'failed'} += 1;
- die "Unable to start child\n";
- }
-}
-
-=head2 fini
-
-Does the reverse of "init" by stopping the Varnish child and reverting
-to a default VCL definition.
-
-=cut
-
-sub fini($) {
- my ($self) = @_;
-
- my $varnish = $self->{'engine'}->{'varnish'};
-
- # Stop the worker process
- $varnish->stop_child();
-
- # Revert to initial VCL script
- no strict 'refs';
- if (${ref($self)."::VCL"}) {
- $varnish->use_vcl('boot');
- }
-
- delete $self->{'engine'}->{'case'};
-
- if ($self->{'failed'}) {
- die sprintf("%d out of %d tests failed\n",
- $self->{'failed'}, $self->{'count'});
- }
-}
-
-=head2 run
-
-Run test-case proper when everything is set up right.
-
-=cut
-
-sub run($;@) {
- my ($self, @args) = @_;
-
- $self->log('Starting ' . ref($self));
-
- no strict 'refs';
- my @tests = @{ref($self)."::TESTS"};
- @tests = sort grep {/^test(\w+)/} (keys %{ref($self) . '::'})
- unless @tests;
- $self->{'start'} = [gettimeofday()];
- foreach my $method (@tests) {
- eval {
- $self->{'count'} += 1;
- $self->log(sprintf("%d: TRY: %s",
- $self->{'count'}, $method));
- my $result = $self->$method(@args);
- $self->{'successful'} += 1;
- $self->log(sprintf("%d: PASS: %s: %s\n",
- $self->{'count'}, $method, $result || 'OK'));
- };
- if ($@) {
- $self->{'failed'} += 1;
- $self->log(sprintf("%d: FAIL: %s: %s",
- $self->{'count'}, $method, $@));
- }
- # Make sure all clients have closed their connections.
- foreach my $client (@{$self->{'engine'}->{'clients'}}) {
- $client->shutdown;
- }
- @{$self->{'engine'}->{'clients'}} = ();
- }
- $self->{'stop'} = [gettimeofday()];
-}
-
-=head2 run_loop
-
-Proxy for Varnish::Test::Engine::run_loop.
-
-=cut
-
-sub run_loop($@) {
- my ($self, @wait_for) = @_;
-
- return $self->{'engine'}->run_loop(@wait_for);
-}
-
-=head2 new_client
-
-Creates a new Client object.
-
-=cut
-
-sub new_client($) {
- my ($self) = @_;
-
- return Varnish::Test::Client->new($self->{'engine'});
-}
-
-=head2 results
-
-Report test-case results as a hashref suitable for Template
-processing.
-
-=cut
-
-sub results($) {
- my ($self) = @_;
-
- no strict 'refs';
- my $name = ${ref($self)."::NAME"} || (split('::', ref($self)))[-1];
- my $descr = ${ref($self)."::DESCR"} || "N/A";
- my $notes = ${ref($self)."::NOTES"} || "N/A";
- return {
- 'name' => $name,
- 'descr' => $descr,
- 'notes' => $notes,
- 'count' => $self->{'count'},
- 'pass' => $self->{'successful'},
- 'fail' => $self->{'failed'},
- 'time' => ((defined($self->{'start'}) and defined($self->{'stop'}))
- ? tv_interval($self->{'start'}, $self->{'stop'})
- : 0),
- };
-}
-
-#
-# Default event handlers
-#
-
-=head1 DEFAULT EVENT HANDLER METHODS
-
-=head2 ev_client_response
-
-=cut
-
-sub ev_client_response($$$) {
- my ($self, $client, $response) = @_;
-
- return $response;
-}
-
-=head2 ev_client_timeout
-
-=cut
-
-sub ev_client_timeout($$) {
- my ($self, $client) = @_;
-
- $client->shutdown();
- return $client;
-}
-
-=head2 ev_server_request
-
-=cut
-
-sub ev_server_request($$$$) {
- my ($self, $server, $connection, $request) = @_;
-
- no strict 'refs';
- my $method = lc($request->method());
- my $handler;
- if ($self->can("server_$method")) {
- $handler = ref($self) . "::server_$method";
- } elsif ($self->can("server")) {
- $handler = ref($self) . "::server";
- } else {
- die "No server callback defined\n";
- }
-
- my $response = HTTP::Response->new();
- $response->code(200);
- $response->header('Date' =>
- strftime("%a, %d %b %Y %T GMT", gmtime(time())));
- $response->header('Server' => ref($self));
- $response->header('Connection' => 'keep-alive');
- $response->content('');
- $response->protocol('HTTP/1.1');
- $self->$handler($request, $response);
- $response->header('Content-Length' =>
- length($response->content()));
- $connection->send_response($response);
-}
-
-=head2 ev_server_timeout
-
-=cut
-
-sub ev_server_timeout($$) {
- my ($self, $srvconn) = @_;
-
- $srvconn->shutdown();
- return $srvconn;
-}
-
-#
-# Client utilities
-#
-
-=head1 CLIENT UTILITY METHODS
-
-=head2 request
-
-Prepare and send an HTTP request using Client object given as
-argument. Also, HTTP method, URI, HTTP headers and content are given
-as argument. HTTP headers and content is optional.
-
-=cut
-
-sub request($$$$;$$) {
- my ($self, $client, $method, $uri, $header, $content) = @_;
-
- my $req = HTTP::Request->new($method, $uri, $header);
- $req->protocol('HTTP/1.1');
- $req->header('Host' => 'varnish.example.com')
- unless $req->header('Host');
- $req->header('User-Agent' => ref($self))
- unless $req->header('User-Agent');
- if (defined($content)) {
- $req->header('Content-Type' => 'text/plain')
- unless ($req->header('Content-Type'));
- $req->header('Content-Length' => length($content))
- unless ($req->header('Content-Length'));
- $req->content($content);
- }
- $client->send_request($req, 4);
- return $req;
-}
-
-=head2 wait
-
-Wait for a response to a previously sent request.
-
-=cut
-
-sub wait($) {
- my ($self) = @_;
-
- my ($ev, $resp) =
- $self->run_loop('ev_server_timeout',
- 'ev_client_timeout',
- 'ev_client_response');
- die "Server timed out before receiving a complete request\n"
- if $ev eq 'ev_server_timeout';
- die "Client timed out before receiving a complete response\n"
- if $ev eq 'ev_client_timeout';
- die "Internal error\n"
- unless $resp && ref($resp) && $resp->isa('HTTP::Response');
- return $self->{'cached_response'} = $resp;
-}
-
-=head2 head
-
-Send "HEAD" request using "request" method above. Client object, URI,
-and HTTP headers (optional) are given as arguments.
-
-=cut
-
-sub head($$$;$) {
- my ($self, $client, $uri, $header) = @_;
-
- return $self->request($client, 'HEAD', $uri, $header);
-}
-
-=head2 get
-
-Send "GET" request using "request" method above. Client object, URI,
-and HTTP headers (optional) are given as arguments.
-
-=cut
-
-sub get($$$;$) {
- my ($self, $client, $uri, $header) = @_;
-
- return $self->request($client, 'GET', $uri, $header);
-}
-
-=head2 post
-
-Send "POST" request using "request" method above. Client object, URI,
-and HTTP headers (optional) and body (optional) are given as
-arguments.
-
-=cut
-
-sub post($$$;$$) {
- my ($self, $client, $uri, $header, $body) = @_;
-
- $header = []
- unless defined($header);
- return $self->request($client, 'POST', $uri, $header, $body);
-}
-
-=head1 ASSERT METHODS
-
-The following assert methods take an optional response object is their
-last argument. When this argument is not used, response object is
-looked up in $self->{'cached_response'}.
-
-=head2 assert_code
-
-Assert a certain HTTP status code.
-
-=cut
-
-sub assert_code($$;$) {
- my ($self, $code, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
- die "Expected $code, got @{[$resp->code]}\n"
- unless $resp->code == $code;
-}
-
-=head2 assert_ok
-
-Assert status "200 OK" using "assert_code" method above.
-
-=cut
-
-sub assert_ok($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- $self->assert_code(200, $resp);
-}
-
-=head2 assert_xid
-
-Assert a certain XID in "X-Varnish" header.
-
-=cut
-
-sub assert_xid($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- die "No X-Varnish header\n"
- unless (defined($resp->header('X-Varnish')));
- die "Invalid X-Varnish header\n"
- unless ($resp->header('X-Varnish') =~ m/^\d+(?: \d+)?$/);
-}
-
-=head2 assert_no_xid
-
-Assert absence of "X-Varnish" header.
-
-=cut
-
-sub assert_no_xid($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- die "X-Varnish header present where none expected\n"
- if (defined($resp->header('X-Varnish')));
-}
-
-=head2 assert_cached
-
-Assert that "X-Varnish" header indicates that the response was cached.
-
-=cut
-
-sub assert_cached($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- my $uri = $resp->request->uri;
- die "$uri should be cached but isn't\n"
- unless $resp->header('X-Varnish') =~ /^\d+ \d+$/;
-}
-
-=head2 assert_uncached
-
-Assert that "X-Varnish" header indicates that the response was NOT
-cached.
-
-=cut
-
-sub assert_uncached($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- my $uri = $resp->request->uri;
- die "$uri shouldn't be cached but is\n"
- if $resp->header('X-Varnish') =~ /^\d+ \d+$/;
-}
-
-=head2 assert_header
-
-Assert that a certain header (named by an argument) is present, and
-optionally matches a given regular expression.
-
-=cut
-
-sub assert_header($$;$$) {
- my ($self, $header, $re, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- die "$header: header missing\n"
- unless defined($resp->header($header));
- if (defined($re)) {
- die "$header: header does not match\n"
- unless $resp->header($header) =~ m/$re/;
- }
-}
-
-=head2 assert_body
-
-Assert presence of a HTTP body, optionally matching given regular
-expression.
-
-=cut
-
-sub assert_body($;$$) {
- my ($self, $re, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
-
- die "Response has no body\n"
- unless defined($resp->content());
- if (defined($re)) {
- die "Response body does not match\n"
- unless $resp->content() =~ m/$re/;
- }
-}
-
-=head2 assert_no_body
-
-Assert absence of HTTP body.
-
-=cut
-
-sub assert_no_body($;$) {
- my ($self, $resp) = @_;
-
- $resp = $self->{'cached_response'}
- unless defined($resp);
- die "Response shouldn't have a body, but does\n"
- if defined($resp->content()) && length($resp->content());
-}
-
-#
-# Miscellaneous
-#
-
-=head1 MISCELLANEOUS METHODS
-
-=head2 usleep
-
-Sleep for a given number of microseconds.
-
-=cut
-
-sub usleep($$) {
- my ($self, $usec) = @_;
-
- select(undef, undef, undef, $usec / 1000000.0);
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Varnish::Test::Client>
-L<HTTP::Request>
-L<HTTP::Response>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Client.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Client.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Client.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,323 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Client - HTTP-client emulator
-
-=head1 DESCRIPTION
-
-Varnish::Test::Client objects have the capability of establishing HTTP
-connections, sending requests and receiving responses.
-
-=cut
-
-package Varnish::Test::Client;
-
-use strict;
-
-use IO::Socket::INET;
-use HTTP::Response;
-
-our $id_seq = 1;
-
-=head2 new
-
-Called by test-cases to create a new Client object to be used to send
-HTTP-requests.
-
-=cut
-
-sub new($$) {
- my ($this, $engine, $attrs) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({ 'engine' => $engine,
- 'mux' => $engine->{'mux'},
- 'id' => $id_seq++,
- 'pending' => [],
- 'requests' => 0,
- 'responses' => 0 }, $class);
-
- push(@{$self->{'engine'}->{'clients'}}, $self);
-
- return $self;
-}
-
-=head2 log
-
-Logging facility.
-
-=cut
-
-sub log($$;$) {
- my ($self, $str, $extra_prefix) = @_;
-
- $self->{'engine'}->log($self, sprintf('CLI[%d]: ', $self->{'id'}) . ($extra_prefix || ''), $str);
-}
-
-=head2 logf
-
-Logging facility using a formatting string as first argument.
-
-=cut
-
-sub logf($$;@) {
- my ($self, $fmt, @args) = @_;
-
- $self->{'engine'}->log($self, sprintf('CLI[%d]: ', $self->{'id'}), sprintf($fmt, @args));
-}
-
-=head2 send_request
-
-Called by test-cases to send HTTP requests out on a connection.
-
-=cut
-
-sub send_request($$;$) {
- my ($self, $request, $timeout) = @_;
-
- if (!defined($self->{'fh'})) {
- my $fh = IO::Socket::INET->new('Proto' => 'tcp',
- 'PeerAddr' => 'localhost',
- 'PeerPort' => '8080')
- or die "socket(): $!\n";
- $self->{'fh'} = $fh;
- $self->{'mux'}->add($fh);
- $self->{'mux'}->set_callback_object($self, $fh);
- }
- $self->{'timeout'} = $timeout;
- $self->{'mux'}->set_timeout($self->{'fh'}, $timeout);
- $self->{'mux'}->write($self->{'fh'}, $request->as_string("\r\n"));
- $self->{'requests'} += 1;
- $self->logf("%s %s %s", $request->method(), $request->uri(), $request->protocol());
- push(@{$self->{'pending'}}, $request);
-}
-
-=head2 got_response
-
-Called by mux_input and mux_eof to dispatch event related to received
-HTTP response.
-
-=cut
-
-sub got_response($$) {
- my ($self, $response) = @_;
-
- $self->{'responses'} += 1;
- $self->logf("%s %s", $response->code(), $response->message());
-
- # Associate the response with what we hope is the correct request
- my $request = shift(@{$self->{'pending'}})
- or die "received response while no request pending\n";
- $response->request($request);
-
- $self->{'engine'}->ev_client_response($self, $response);
-}
-
-=head2 shutdown
-
-Called by test-cases to shutdown client including termination of HTTP
-connection.
-
-=cut
-
-sub shutdown($) {
- my ($self) = @_;
-
- if (defined($self->{'fh'})) {
- my $inbuffer = $self->{'mux'}->inbuffer($self->{'fh'});
-
- if (defined($inbuffer) and $inbuffer ne '') {
- use Data::Dumper;
-
- $self->log('Discarding: ' . Dumper(\$inbuffer));
- $self->{'mux'}->inbuffer($self->{'fh'}, '');
- }
-
- $self->{'mux'}->close($self->{'fh'});
- $self->{'fh'} = undef;
- }
-}
-
-=head1 IO::MULTIPLEX CALLBACKS
-
-=head2 mux_input
-
-Called by L<IO::Multiplex> when new input is received on an associated
-file-handle. Complete HTTP messages are extracted from the input
-buffer, while any incomplete message is left in the buffer, awaiting
-more input (mux_input) or EOF (mux_eof).
-
-=cut
-
-sub mux_input($$$$) {
- my ($self, $mux, $fh, $data) = @_;
-
- $mux->set_timeout($fh, undef);
-
- # Iterate through the input buffer ($$data) and identify HTTP
- # messages, one per iteration. Break out of the loop when there
- # are no complete HTTP messages left in the buffer, and let
- # whatever data remains stay in the buffer, as we will get a new
- # chance to parse it next time we get more data ("mux_input") or
- # if connection is closed ("mux_eof").
-
- while ($$data =~ /\n\r?\n/) {
- die "Received HTTP-data without awaiting any response\n"
- unless @{$self->{'pending'}};
-
- # If we find a double (CR)LF in the input data, we have at
- # least a complete header section of a message, so look for
- # content-length and decide what to do.
-
- my $response = HTTP::Response->parse($$data);
- my $content_length = $response->content_length;
-
- if (${$self->{'pending'}}[0]->method eq 'HEAD') {
- # This is the response of a HEAD request, so we don't
- # expect or want any content. Any remaining input data
- # should be the start of another HTTP-message.
-
- $$data = $response->content;
- $response->content('');
-
- # Send response to event handling.
- $self->got_response($response);
- }
- elsif (defined($content_length)) {
- my $content_ref = $response->content_ref;
- my $data_length = length($$content_ref);
- if ($data_length == $content_length) {
- # We found exactly content-length amount of data, so
- # empty input buffer and send response to event
- # handling.
- $$data = '';
- $self->got_response($response);
- }
- elsif ($data_length < $content_length) {
- # We only received the first part of an HTTP message,
- # so break out of loop and wait for more.
- $self->log("Partial body received" .
- " ($data_length of $content_length bytes)");
- $mux->set_timeout($fh, $self->{'timeout'});
- last;
- }
- else {
- # We have more than content-length data, which means
- # more than just one HTTP message. The extra data
- # (beyond content-length) is now at the end of
- # $$content_ref, so move it back to the input buffer
- # so we can parse it on the next iteration. Note that
- # this "substr" also removes this data from
- # $$content_ref (the message body of $response
- # itself).
- $$data = substr($$content_ref, $content_length,
- $data_length - $content_length, '');
-
- # Send response to event handling.
- $self->got_response($response);
- }
- }
- else {
- # There is no content-length among the headers, so break
- # out of loop and wait for EOF, in which case mux_eof will
- # reparse the input buffer as a HTTP message and send it
- # to event handling from there.
- $self->log("Partial response. Content-Length unknown." .
- " Expecting CLOSE as end-of-response.");
- $mux->set_timeout($fh, $self->{'timeout'});
- last;
- }
- }
-
- # At this point, what remains in the input buffer is either
- # nothing at all or a partial HTTP message.
-}
-
-=head2 mux_eof
-
-Called by L<IO::Multiplex> when connection is being shutdown by
-foreign host.
-
-=cut
-
-sub mux_eof($$$$) {
- my ($self, $mux, $fh, $data) = @_;
-
- if ($$data ne '') {
- die "Received HTTP-data without awaiting any response\n"
- unless @{$self->{'pending'}};
- die "Received incomplete response headers and connection is closing\n"
- unless $$data =~ "\n\r?\n";
-
- my $response = HTTP::Response->parse($$data);
- $$data = '';
- $self->got_response($response);
- }
- $self->logf("%d pending request(s) never received a response\n", @{$self->{'pending'}})
- if @{$self->{'pending'}};
-}
-
-=head2 mux_timeout
-
-Called by L<IO::Multiplex> when a specified timeout has been reached
-on an associated file-handle.
-
-=cut
-
-sub mux_timeout($$$) {
- my ($self, $mux, $fh) = @_;
-
- $self->{'mux'}->set_timeout($fh, undef);
- $self->{'engine'}->ev_client_timeout($self);
-}
-
-=head2 mux_close
-
-Called by L<IO::Multiplex> when an associated file-handle has been
-closed.
-
-=cut
-
-sub mux_close($$) {
- my ($self, $mux, $fh) = @_;
-
- $self->{'fh'} = undef;
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<HTTP::Response>
-L<HTTP::Request>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Engine.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Engine.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Engine.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,260 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Engine - select-loop wrapper and event dispatcher
-
-=head1 DESCRIPTION
-
-An L<Engine|Varnish::Test::Engine> object is primarily a wrapper
-around a L<select(2)>-based L<IO::Multiplex> object which monitors
-activity on relevant sockets and file handles.
-
-Additionally, an Engine object performs event dispatching and queuing,
-which are handled by an AUTOLOAD method.
-
-=head1 METHODS
-
-=cut
-
-package Varnish::Test::Engine;
-
-use strict;
-
-use Varnish::Test::Server;
-use Varnish::Test::Varnish;
-use IO::Multiplex;
-
-=head2 new
-
-Used by main program to create a new Varnish::Test::Engine object
-which starts up a L<Varnish::Test::Server> and
-L<Varnish::Test::Varnish> object, so test-cases are ready to be run.
-Also an <IO::Multiplex> object is started to handle the central
-select(2) mechanism.
-
-=cut
-
-sub new($$;%) {
- my ($this, $controller, %config) = @_;
- my $class = ref($this) || $this;
-
- %config = ('varnish_address' => 'localhost:8080',
- 'server_address' => 'localhost:8081',
- 'telnet_address' => 'localhost:8082',
- 'varnish_name' => 'regress',
- 'storage_spec' => 'file,regress.bin,512k',
- %config);
-
- my $self = bless({ 'mux' => IO::Multiplex->new,
- 'controller' => $controller,
- 'config' => \%config,
- 'clients' => [],
- 'pending' => [] }, $class);
-
- $self->{'server'} = Varnish::Test::Server->new($self);
- $self->{'varnish'} = Varnish::Test::Varnish->new($self);
-
- my ($ev) = $self->run_loop('ev_varnish_started', 'ev_varnish_timeout');
-
- if ($ev eq 'ev_varnish_timeout') {
- $self->{'varnish'}->shutdown;
- die "Varnish did not start\n";
- }
-
- return $self;
-}
-
-=head2 log
-
-Logging facility.
-
-=cut
-
-sub log($$$) {
- my ($self, $object, $prefix, $str) = @_;
-
- $str =~ s/^/$prefix/gm;
- $str =~ s/\n?$/\n/;
-
- print STDERR $str;
-}
-
-=head2 run_loop
-
-Enter event loop based on IO::Multiplex::loop. Also, handles
-dispatching of "wait-for" or "die" events which are returned to the
-caller.
-
-=cut
-
-sub run_loop($@) {
- my ($self, @wait_for) = @_;
-
- # Sanity-check to help the novice test-case writer.
- die "Engine::run_loop: Already inside select-loop. Your code is buggy.\n"
- if exists($self->{'in_loop'});
-
- # We need to wait for at least one event.
- die "Engine::run_loop: No events to wait for.\n"
- if @wait_for == 0;
-
- # Check the queue for pending events which occurred between the
- # last pausing event and the time the loop actually paused. If we
- # are waiting for any of these events (which already occurred),
- # return the first one we find immediately.
- while (@{$self->{'pending'}} > 0) {
- my ($event, @args) = @{shift @{$self->{'pending'}}};
- return ($event, @args) if grep({ $_ eq $event } @wait_for);
- }
-
- # At this point, the queue of pending events is always empty.
- # Prepare and run IO::Multiplex::loop.
-
- $self->{'wait_for'} = \@wait_for;
- $self->{'in_loop'} = 1;
- eval { $self->{'mux'}->loop; };
- delete $self->{'in_loop'};
- delete $self->{'wait_for'};
- if ($@) {
- $self->log($self, 'ENG: ', 'IO::Multiplex INCONSISTENT AFTER UNCONTROLLED die().');
- # Maybe we should just exit() here, since we cannot do much
- # useful with an inconsistent IO::Multiplex object.
- die $@;
- }
-
- # Loop has now been paused due to the occurrence of an event we
- # were waiting for, or a controlled die(). The event is always
- # found in the front of the pending events queue at this point, so
- # return it, or die() if we find a "die event".
- if (@{$self->{'pending'}} > 0) {
- my ($event, @args) = @{shift @{$self->{'pending'}}};
- die $args[0] if ($event eq 'die');
- return ($event, @args);
- }
-
- # Hm... we should usually not reach this point. The pending queue
- # is empty. Either someone (erroneously) requested a loop pause by
- # calling IO::Multiplex::endloop and forgot to put any event in
- # the queue, or the loop ended itself because all registered
- # filehandles/sockets closed.
- return undef;
-}
-
-=head2 shutdown
-
-Shutdown Engine by shutting down Server, Varnish, and IO::Multiplex
-objects.
-
-=cut
-
-sub shutdown($) {
- my ($self) = @_;
-
- # Shutdown varnish and server.
- $self->{'varnish'}->shutdown if defined $self->{'varnish'};
- $self->{'server'}->shutdown if defined $self->{'server'};
-
- # Close any lingering sockets registered with IO::Multiplex.
- foreach my $fh ($self->{'mux'}->handles) {
- $self->{'mux'}->close($fh);
- }
-}
-
-=head2 AUTOLOAD
-
-Event dispatch mechanism. When an I/O event occurs, it goes through
-this method because $engine->ev_* resolves to this one. It will the
-look for a method of the same name in the running test-case object.
-Queuing and end-loop signaling is done when a "wait-for" or "die"
-event occurs.
-
-=cut
-
-sub AUTOLOAD($;@) {
- my ($self, @args) = @_;
-
- (my $event = our $AUTOLOAD) =~ s/.*://;
-
- return if $event eq 'DESTROY';
-
- # For the sake of readability, we want all method names we handle
- # to start with "ev_".
- die sprintf("Unknown method '%s'\n", $event)
- unless $event =~ /^ev_(.*)$/;
-
- $self->log($self, 'ENG: ', sprintf('EVENT "%s"', $1));
-
- eval {
- # Check to see if the active case object defines an event
- # handler for this event. If so, call it and bring the event
- # arguments along. This will also replace @args, which is
- # significant if this event will pause and return.
- @args = $self->{'case'}->$event(@args)
- if (defined($self->{'case'}) and $self->{'case'}->can($event));
- };
- if ($@) {
- # The event handler issued die(), which we want to control
- # because we do not want the IO::Multiplex-loop to be subject
- # to it. Hence, we queue it as a special event which will be
- # recognized outside the loop and reissued there, using die().
- # We put this die-event in the front of the queue, using
- # "unshift", so we get it through before any other events
- # already in the queue. Then, signal pause of loop.
- unshift(@{$self->{'pending'}}, [ 'die', $@ ]);
- $self->{'mux'}->endloop;
- }
- elsif (@{$self->{'pending'}} > 0) {
- # Pending event queue is NOT empty, meaning this is an event
- # arriving after a pausing (wait_for) event, but before the
- # pause is in effect. We queue this event unconditionally
- # because it might be the one we are waiting for on the next
- # call to run_loop.
- push(@{$self->{'pending'}}, [ $event, @args ]);
- }
- elsif (grep({ $_ eq $event} @{$self->{'wait_for'}}) > 0) {
- # Pending event queue is empty and this event is one of those
- # we are waiting for, so put it in the front of the queue and
- # signal loop pause by calling IO::Multiplex::endloop.
- push(@{$self->{'pending'}}, [ $event, @args ]);
- $self->{'mux'}->endloop;
- }
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Varnish::Test::Varnish>
-L<Varnish::Test::Server>
-L<IO::Multiplex>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Report/HTML.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Report/HTML.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Report/HTML.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,44 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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::Report::HTML;
-
-use strict;
-
-use base 'Varnish::Test::Report';
-
-sub init($) {
- my ($self) = @_;
-
- $self->{'template'} = 'report.html';
- $self->{'config'}->{'TAG_STYLE'} = 'html';
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Report/report.html
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Report/report.html 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Report/report.html 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,66 +0,0 @@
-<?xml version='1.0' encoding='utf-8'?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <title>Varnish test report</title>
- <meta name="svnid" content="$Id$"/>
- <style type="text/css">
-table { border-collapse: collapse; border: none; }
-td, th { border: thin solid black; padding: 3pt; text-align: left; }
-thead, tfoot { background-color: #eeeeff; }
-tr.pass { background-color: #eeffee; }
-tr.fail { background-color: #ffeeee; }
-.name { width: 10%; }
-.count { width: 5%; }
-.pass { width: 5%; }
-.fail { width: 5%; }
-.time { width: 5%; text-align: right; }
-.descr { width: 50%; }
-.notes { width: 20%; }
- </style>
- </head>
-<!-- USE ms = format('%5.3f') -->
- <body>
- <h1 class="title">Varnish test report</h1>
- <table>
- <thead>
- <tr>
- <th class="name">Name</th>
- <th class="tests">Tests</th>
- <th class="pass">Pass</th>
- <th class="fail">Fail</th>
- <th class="time">Time</th>
- <th class="descr">Description</th>
- <th class="notes">Notes</th>
- </tr>
- </thead>
-<!-- FOREACH case = cases -->
-<!-- IF case.fail == 0 -->
- <tr class="pass">
-<!-- ELSE -->
- <tr class="fail">
-<!-- END -->
- <td class="name"><!-- case.name --></td>
- <td class="count"><!-- case.count --></td>
- <td class="pass"><!-- case.pass --></td>
- <td class="fail"><!-- case.fail --></td>
- <td class="time"><!-- ms(case.time) --> s</td>
- <td class="descr"><!-- case.descr --></td>
- <td class="notes"><!-- case.notes --></td>
- </tr>
-<!-- END -->
- <tfoot>
- <tr>
- <th class="name">Total</th>
- <td class="count"><!-- count --></td>
- <td class="pass"><!-- pass --></td>
- <td class="fail"><!-- fail --></td>
- <td class="time"><!-- ms(time) --> s</td>
- <td class="descr"> </td>
- <td class="notes"> </td>
- </tr>
- </tfoot>
- </table>
- </body>
-</html>
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Report.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Report.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Report.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,109 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2007-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Report
-
-=head1 DESCRIPTION
-
-Produce test result reports in different formats. Currently, HTML
-format is supported via a subclass found in
-Varnish::Test::Report::HTML.
-
-=head1 METHODS
-
-=cut
-
-package Varnish::Test::Report;
-
-use strict;
-
-use Template;
-
-=head2 new
-
-Create a new Report object.
-
-=cut
-
-sub new($) {
- my ($this) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({
- 'config' => {
- },
- 'template' => undef,
- }, $class);
-
- ($self->{'config'}->{'INCLUDE_PATH'} = $INC{'Varnish/Test/Report.pm'}) =~ s/\.pm$//;
-
- $self->init();
-
- return $self;
-}
-
-=head2 new
-
-Generate report.
-
-=cut
-
-sub run($@) {
- my ($self, @cases) = @_;
-
- die "No template defined\n"
- unless defined($self->{'template'});
- my $template = new Template($self->{'config'});
- my ($count, $pass, $fail, $time);
- map {
- $count += $_->{'count'};
- $pass += $_->{'pass'};
- $fail += $_->{'fail'};
- $time += $_->{'time'};
- } @cases;
- $template->process($self->{'template'}, {
- 'cases' => \@cases,
- 'count' => $count,
- 'pass' => $pass,
- 'fail' => $fail,
- 'time' => $time,
- })
- or die $template->error();
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Template>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Server/Connection.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Server/Connection.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Server/Connection.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,240 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Server::Connection
-
-=head1 DESCRIPTION
-
-An Varnish::Test::Server::Connection object is used to handle an
-individual HTTP connection which stems from the listening socket
-handled by L<Varnish::Test::Server>.
-
-=cut
-
-package Varnish::Test::Server::Connection;
-
-use strict;
-use HTTP::Request;
-use HTTP::Status;
-
-=head2 new
-
-Called by a Server object when a new connection (given by the
-file-handle argument) is established. This object is set as the
-IO::Multiplex call-back object for this connection.
-
-=cut
-
-sub new($$) {
- my ($this, $server, $fh) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({ 'server' => $server,
- 'engine' => $server->{'engine'},
- 'fh' => $fh,
- 'mux' => $server->{'mux'},
- 'data' => '' }, $class);
- $self->{'mux'}->set_callback_object($self, $fh);
- return $self;
-}
-
-=head2 write
-
-Write data to the connection
-
-=cut
-
-sub write($@) {
- my ($self, @data) = @_;
-
- foreach my $data (@data) {
- $self->{'mux'}->write($self->{'fh'}, $data);
- }
-}
-
-=head2 send_response
-
-Called by test-cases to send a given HTTP::Response object out on the
-associated HTTP connection.
-
-=cut
-
-sub send_response($$) {
- my ($self, $response) = @_;
-
- $response->message(status_message($response->code()))
- unless $response->message();
- $self->{'mux'}->write($self->{'fh'}, $response->as_string("\r\n"));
- $self->{'server'}->{'responses'} += 1;
- $self->{'server'}->logf("%s %s", $response->code(), $response->message());
-}
-
-=head2 shutdown
-
-Called by test-cases to close HTTP connection.
-
-=cut
-
-sub shutdown($) {
- my ($self) = @_;
-
- my $inbuffer = $self->{'mux'}->inbuffer($self->{'fh'});
-
- if (defined($inbuffer) and $inbuffer ne '') {
- use Data::Dumper;
-
- $self->{'server'}->log('Junk or incomplete request. Discarding: ' . Dumper(\$inbuffer));
- $self->{'mux'}->inbuffer($self->{'fh'}, '');
- }
-
- $self->{'mux'}->close($self->{'fh'});
-}
-
-=head1 IO::MULTIPLEX CALLBACKS
-
-=head2 mux_input
-
-Called by L<IO::Multiplex> when new input is received on an associated
-file-handle. Complete HTTP messages are extracted from the input
-buffer, while any incomplete message is left in the buffer, awaiting
-more input (mux_input) or EOF (mux_eof).
-
-=cut
-
-sub mux_input($$$$) {
- my ($self, $mux, $fh, $data) = @_;
-
- $mux->set_timeout($fh, undef);
-
- # Iterate through the input buffer ($$data) and identify HTTP
- # messages, one per iteration. Break out of the loop when there
- # are no complete HTTP messages left in the buffer, and let
- # whatever data remains stay in the buffer, as we will get a new
- # chance to parse it next time we get more data ("mux_input").
- while ($$data =~ /\n\r?\n/) {
- # If we find a double (CR)LF in the input data, we have at
- # least a complete header section of a message, so look for
- # content-length and decide what to do.
-
- 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) {
- # We found exactly content-length amount of data, so
- # empty input buffer and send request to event
- # handling.
- $$data = '';
- $self->{'server'}->got_request($self, $request);
- }
- elsif ($data_length < $content_length) {
- # We only received the first part of an HTTP message,
- # so break out of loop and wait for more.
- $mux->set_timeout($fh, 2);
- last;
- }
- else {
- # We have more than content-length data, which means
- # more than just one HTTP message. The extra data
- # (beyond content-length) is now at the end of
- # $$content_ref, so move it back to the input buffer
- # so we can parse it on the next iteration. Note that
- # this "substr" also removes this data from
- # $$content_ref (the message body of $request itself).
- $$data = substr($$content_ref, $content_length,
- $data_length - $content_length, '');
- # Send request to event handling.
- $self->{'server'}->got_request($self, $request);
- }
- }
- else {
- # HTTP requests without a content-length has no body by
- # definition, so whatever was parsed as content must be
- # the start of another request. Hence, move this back to
- # input buffer and empty the body of this $request. Then,
- # send $request to event handling.
-
- $$data = $$content_ref;
- $$content_ref = '';
- $self->{'server'}->got_request($self, $request);
- }
- }
-}
-
-=head2 mux_timeout
-
-Called by L<IO::Multiplex> when a specified timeout has been reached
-on an associated file-handle.
-
-=cut
-
-sub mux_timeout($$$) {
- my ($self, $mux, $fh) = @_;
-
- $self->{'mux'}->set_timeout($fh, undef);
- $self->{'engine'}->ev_server_timeout($self);
-}
-
-=head2 mux_eof
-
-Called by L<IO::Multiplex> when connection is being shutdown by
-foreign host.
-
-=cut
-
-sub mux_eof($$$$) {
- my ($self, $mux, $fh, $data) = @_;
-
- # On server side, HTTP does not use EOF from client to signal end
- # of request, so if there is anything left in input buffer, it
- # must be incomplete because "mux_input" left it there.
-
- if ($$data ne '') {
- use Data::Dumper;
-
- $self->{'server'}->log('Junk or incomplete request. Discarding: ' . Dumper($data));
- $$data = '';
- }
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Varnish::Test::Server>
-L<HTTP::Request>
-L<HTTP::Response>
-L<HTTP::Status>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Server.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Server.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Server.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,177 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Server - HTTP-server emulator
-
-=head1 DESCRIPTION
-
-A Varnish::Test::Server object has the capability of listening on a
-TCP socket, receiving HTTP requests and sending responses.
-
-Every established connection is handled by an associated object of
-type L<Varnish::Test::Server::Connection>.
-
-=cut
-
-package Varnish::Test::Server;
-
-use strict;
-
-use Varnish::Test::Server::Connection;
-use IO::Socket::INET;
-
-=head2 new
-
-Called by a Varnish::Test::Engine object to create a new Server
-object. It sets up its listening socket and registers it in Engine's
-IO::Multiplex object (mux).
-
-=cut
-
-sub new($$) {
- my ($this, $engine, $attrs) = @_;
- my $class = ref($this) || $this;
-
- my ($host, $port) = split(':', $engine->{'config'}->{'server_address'});
-
- my $socket = IO::Socket::INET->new('Proto' => 'tcp',
- 'LocalAddr' => $host,
- 'LocalPort' => $port,
- 'Listen' => 4,
- 'ReuseAddr' => 1)
- or die "socket(): $!\n";
-
- my $self = bless({ 'engine' => $engine,
- 'mux' => $engine->{'mux'},
- 'socket' => $socket,
- 'requests' => 0,
- 'responses' => 0 }, $class);
-
- $self->{'mux'}->listen($socket);
- $self->{'mux'}->set_callback_object($self, $socket);
-
- return $self;
-}
-
-=head2 log
-
-Logging facility.
-
-=cut
-
-sub log($$;$) {
- my ($self, $str, $extra_prefix) = @_;
-
- $self->{'engine'}->log($self, 'SRV: ' . ($extra_prefix || ''), $str);
-}
-
-=head2 logf
-
-Logging facility using a formatting string as first argument.
-
-=cut
-
-sub logf($$;@) {
- my ($self, $fmt, @args) = @_;
-
- $self->{'engine'}->log($self, 'SRV: ', sprintf($fmt, @args));
-}
-
-=head2 shutdown
-
-Called by the main program to terminate the server object and its
-listening socket.
-
-=cut
-
-sub shutdown($) {
- my ($self) = @_;
-
- $self->{'mux'}->close($self->{'socket'});
- delete $self->{'socket'};
-}
-
-=head2 got_request
-
-Called by L<Varnish::Test::Server::Connection> object when an HTTP
-message has been received. An B<ev_server_request> event is
-dispatched.
-
-=cut
-
-sub got_request($$) {
- my ($self, $connection, $request) = @_;
-
- $self->{'requests'} += 1;
- $self->logf("%s %s %s", $request->method(), $request->uri(), $request->protocol());
- $self->{'engine'}->ev_server_request($self, $connection, $request);
-}
-
-=head1 IO::MULTIPLEX CALLBACKS
-
-=head2 mux_connection
-
-Called by L<IO::Multiplex> when the listening socket has received a
-new connection. The file-handle of the new connection is provided as
-an argument and is given to a newly created
-L<Varnish::Test::Server::Connection> object which will operate the new
-connection from now on.
-
-=cut
-
-sub mux_connection($$$) {
- my ($self, $mux, $fh) = @_;
-
- $self->log('CONNECT');
- my $connection = Varnish::Test::Server::Connection->new($self, $fh);
-}
-
-=head2 mux_close
-
-Called by L<IO::Multiplex> when the listening socket has been closed.
-
-=cut
-
-sub mux_close($$) {
- my ($self, $mux, $fh) = @_;
-
- $self->log('CLOSE');
- delete $self->{'socket'} if $fh == $self->{'socket'};
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Varnish::Test::Server::Connection>
-
-=cut
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test/Varnish.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test/Varnish.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test/Varnish.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,411 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=head1 NAME
-
-Varnish::Test::Varnish - Varnish daemon process controller
-
-=head1 DESCRIPTION
-
-A Varnish::Test::Varnish object is used to fork off a Varnish daemon
-(varnishd) process and control traffic going into and coming out of
-the Varnish (management process) command-line interface (CLI).
-
-Various events are generated when certain strings are identified in
-the output from the CLI.
-
-=head1 METHODS
-
-=cut
-
-package Varnish::Test::Varnish;
-
-use strict;
-
-use IO::Socket::INET;
-use Socket;
-
-=head2 new
-
-Called by an Varnish::Test::Engine object to create a
-Varnish::Test::Varnish object which spawns a "varnishd" sub-process.
-
-=cut
-
-sub new($$;$) {
- my ($this, $engine, $attrs) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({ 'engine' => $engine,
- 'mux' => $engine->{'mux'},
- 'state' => 'init' }, $class);
-
- # Create pipes (actually socket pairs) for communication between
- # parent and child.
-
- 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);
-
- # Ignore SIGCHLD.
- $SIG{CHLD} = 'IGNORE';
-
- my $pid = fork;
- die "fork(): $!\n"
- unless defined($pid);
-
- if ($pid == 0) {
- # Child
-
- close STDIN_WRITE;
- close STDOUT_READ;
- close STDERR_READ;
-
- # dup2(2) the I/O-channels to std{in,out,err} and close the
- # original file handles before transforming into Varnish.
-
- 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',
- '-s', $engine->{'config'}->{'storage_spec'},
- '-n', $engine->{'config'}->{'varnish_name'},
- '-a', $engine->{'config'}->{'varnish_address'},
- '-b', $engine->{'config'}->{'server_address'},
- '-T', $engine->{'config'}->{'telnet_address'});
-
- print STDERR sprintf("Starting Varnish with options: %s\n", join(' ', @opts));
-
- # Unset ignoring of SIGCHLD, so Varnish will get signals from
- # its children.
-
- delete $SIG{CHLD};
-
- # Transform into Varnish. Goodbye Perl-code!
- exec('varnishd', @opts);
- exit(1);
- }
-
- # Parent
- $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;
-
- # Register the Varnish I/O-channels with the IO::Multiplex
- # loop object.
-
- $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'});
-
- # If we don't hear "rolling(2)..." from Varnish's STDERR within 5
- # seconds, something must be wrong.
- $self->{'mux'}->set_timeout($self->{'stderr'}, 5);
-
- $self->{'state'} = 'init';
-
- return $self;
-}
-
-=head2 log
-
-Logging facility.
-
-=cut
-
-sub log($$) {
- my ($self, $str) = @_;
-
- $self->{'engine'}->log($self, 'VAR: ', $str);
-}
-
-=head2 backend_block
-
-Return a string containing a VCL "backend" block containing the
-information about the running backend (Varnish::Test::Server object).
-
-=cut
-
-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'}));
-}
-
-=head2 send_command
-
-Called by main program or test-cases to send commands to the Varnish
-deamon.
-
-=cut
-
-sub send_command($@) {
- my ($self, @args) = @_;
- die "not ready\n"
- if $self->{'state'} eq 'init';
- die sprintf("busy awaiting earlier command (%s)\n", $self->{'pending'})
- if defined $self->{'pending'};
-
- foreach (@args) {
- if (m/[\s\"\n]/) {
- s/\n/\\n/g;
- s/\"/\\\"/g;
- s/^(.*)$/"$1"/g;
- }
- }
- my $command = join(' ', @args);
- $self->log("sending command: $command");
- $self->{'mux'}->write($self->{'socket'}, $command . "\n");
- $self->{'mux'}->set_timeout($self->{'socket'}, 2);
- $self->{'pending'} = $command;
- my ($ev, $code, $text) =
- $self->{'engine'}->run_loop('ev_varnish_result',
- 'ev_varnish_timeout');
- delete $self->{'pending'};
- $self->log("result code $code")
- if ($ev eq 'ev_varnish_result');
- return ($code, $text);
-}
-
-=head2 send_vcl
-
-Send "vcl.inline" command to Varnish daemon.
-
-=cut
-
-sub send_vcl($$$) {
- my ($self, $config, $vcl) = @_;
-
- return $self->send_command('vcl.inline', $config, $vcl);
-}
-
-=head2 use_vcl
-
-Send "vcl.use" command to the Varnish daemon.
-
-=cut
-
-sub use_vcl($$) {
- my ($self, $config) = @_;
-
- return $self->send_command('vcl.use', $config);
-}
-
-=head2 start_child
-
-Issue command to start Varnish daemon's child process, so that HTTP
-traffic may begin. An B<ev_varnish_started> will be dispatched from
-"mux_input" once the child actually has started.
-
-=cut
-
-sub start_child($) {
- my ($self) = @_;
- die "not ready\n"
- if $self->{'state'} eq "init";
- die "already started\n"
- if $self->{'state'} eq "started";
-
- $self->{'state'} = 'starting';
- my ($code, $text) = $self->send_command("start");
- return ($code, $text)
- unless ($code == 200);
- for (my $n = 0; $n < 10; ++$n) {
- my ($code, $text) = $self->send_command('status');
- return ($code, $text)
- unless ($code == 200);
- if ($text =~ /state running/) {
- $self->{'state'} = 'started';
- return ($code, $text);
- }
- select(undef, undef, undef, 0.5);
- }
- $self->shutdown();
- return (500, 'unable to start child');
-}
-
-=head2 stop_child
-
-Issue command to stop Varnish daemon's child process.
-
-=cut
-
-sub stop_child($) {
- my ($self) = @_;
- die "not ready\n"
- if $self->{'state'} eq 'init';
- die "already stopped\n"
- if $self->{'state'} eq 'stopped';
-
- $self->{'state'} = 'stopping';
- my ($code, $text) = $self->send_command("stop");
- for (my $n = 0; $n < 10; ++$n) {
- my ($code, $text) = $self->send_command('status');
- return ($code, $text)
- unless ($code == 200);
- if ($text =~ /state stopped/) {
- $self->{'state'} = 'stopped';
- return ($code, $text);
- }
- select(undef, undef, undef, 0.5);
- }
- $self->shutdown();
- return (500, 'unable to stop child');
-}
-
-=head2 set_param
-
-Send "param.set" command to Varnish daemon.
-
-=cut
-
-sub set_param($$$) {
- my ($self, $param, $value) = @_;
-
- return $self->send_command('param.set', $param, $value);
-}
-
-=head2 shutdown
-
-Shutdown Varnish daemon.
-
-=cut
-
-sub shutdown($) {
- my ($self) = @_;
-
- $self->{'mux'}->close(delete $self->{'stdin'})
- if $self->{'stdin'};
- $self->{'mux'}->close(delete $self->{'stdout'})
- if $self->{'stdout'};
- $self->{'mux'}->close(delete $self->{'stderr'})
- if $self->{'stderr'};
- $self->{'mux'}->close(delete $self->{'socket'})
- if $self->{'socket'};
- kill(15, delete $self->{'pid'})
- if $self->{'pid'};
-}
-
-=head2 mux_input
-
-Called by L<IO::Multiplex> when new input is received on the Varnish
-daemon's output channels. Dispatches relevant events based on the
-output received.
-
-=cut
-
-sub mux_input($$$$) {
- my ($self, $mux, $fh, $data) = @_;
-
- $self->log($$data);
-
- if ($fh == $self->{'stderr'} and $$data =~ s/^rolling\(2\)\.\.\.//m) {
- # Varnish appears to have been started correctly, so connect
- # to management socket.
- $self->{'mux'}->set_timeout($fh, undef);
- $self->{'state'} = 'stopped';
- $self->{'socket'} = IO::Socket::INET
- ->new('Type' => SOCK_STREAM,
- 'PeerAddr' => $self->{'engine'}->{'config'}->{'telnet_address'});
- die "Unable to connect to management socket\n"
- unless defined($self->{'socket'});
- $self->{'mux'}->add($self->{'socket'});
- $self->{'mux'}->set_callback_object($self, $self->{'socket'});
- $self->{'engine'}->ev_varnish_started;
- } elsif (exists($self->{'socket'}) and $fh == $self->{'socket'}) {
- $self->{'mux'}->set_timeout($fh, undef);
- die "syntax error\n"
- unless ($$data =~ m/^([1-5][0-9][0-9]) (\d+) *$/m);
- my ($line, $code, $len) = ($&, $1, $2);
- if (length($$data) < length($line) + $len) {
- # we don't have the full response yet.
- $self->{'mux'}->set_timeout($fh, 2);
- return;
- }
- # extract the response text (if any), then remove from $$data
- $$data =~ s/^\Q$line\E\n(.{$len})\n//
- or die "oops\n";
- $self->{'engine'}->ev_varnish_result($code, $1);
- } else {
- if ($$data =~ /Child died pid=(\d+) status=0x([0-9A-Fa-f]+)/) {
- my ($pid, $status) = ($1, hex($2));
- if ($pid != $self->{'pid'}) {
- # shouldn't happen, but sometimes it does
- $self->log("stray child $pid died with status $status");
- } elsif ($self->{'state'} == 'stopping' ||
- $self->{'state'} == 'stopped') {
- # ignore
- } else {
- $self->{'state'} = 'stopped';
- die "child died unexpectedly with status $status\n";
- }
- }
- # XXX there might be more!
- $$data = '';
- }
-}
-
-=head2 mux_timeout
-
-Called by L<IO::Multiplex> when a specified timeout has been reached
-on an associated file-handle. Dispatch an B<ev_varnish_timeout> event.
-
-=cut
-
-sub mux_timeout($$$) {
- my ($self, $mux, $fh) = @_;
-
- $self->{'mux'}->set_timeout($fh, undef);
- $self->shutdown();
- $self->{'engine'}->ev_varnish_timeout($self);
-}
-
-1;
Deleted: trunk/varnish-tools/regress/lib/Varnish/Test.pm
===================================================================
--- trunk/varnish-tools/regress/lib/Varnish/Test.pm 2009-05-04 19:03:47 UTC (rev 4050)
+++ trunk/varnish-tools/regress/lib/Varnish/Test.pm 2009-05-04 20:22:41 UTC (rev 4051)
@@ -1,229 +0,0 @@
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006-2009 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$
-#
-
-=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.
-
- +---------------------------------------------------------+
- | TEST FRAMEWORK |
- | |
- | Controller |
- | +-----------------------------------+ |
- | | | C ^ | |
- | | configuration | L | status | |
- | | v I | | |
- | | requests +---------+ requests | |
- | | =========> | | =========> | |
- | Client | HTTP | VARNISH | HTTP | Server |
- | emulator | <========= | | <========= | emulator |
- | | responses +---------+ responses | |
- +----------+ +----------+
-
-=head1 STRUCTURE
-
-When regression tests start, an instance of Varnish is forked off as a
-child process, and its I/O channels (std{in,out,err} which are
-connected to the command-line interface of Varnish) are controlled by
-the parent process which also performs the tests 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 L<IO::Multiplex>.
-
-As a result of using a select-loop (as opposed to a multi-threaded or
-multi-process approach), the framework has an event-driven design in
-order to cope with the unpredictable sequence of I/O on server or
-client side (or Varnish's I/O-channels for that matter) . 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,
-and it is essential to be aware of whether a piece of code is going to
-run inside (event handler) or outside (main program) the select-loop.
-
-The framework uses Perl objects to represent instances of servers
-(Varnish::Test::Server) and clients (Varnish::Test::Client) as well as
-the Varnish instance itself (Varnish::Test::Varnish). In addition,
-there is an engine object (Varnish::Test::Engine) which dispatches
-events and controls the program flow related to the select-loop.
-Futhermore, each test case is represented by an object
-(Varnish::Test::Case subclass). HTTP requests and responses are
-represented by objects of HTTP::Request and HTTP::Response,
-respectively. Finally, there is an overall test-case controller object
-(Varnish::Test) which accumulates test-case results.
-
-=head1 EVENT PROCESSING
-
-Events typically occur in the call-back routines (mux_*) of client,
-server, and Varnish objects. An event is created by calling an ev_*
-method of the engine object. These calls are handled by Perl's
-AUTOLOAD mechanism since Engine does not define any ev_* methods
-explicitly. The AUTOLOAD routine works as the event dispatcher by
-looking for an event handler in the currently running test-case
-object, and also determines whether the event being processed is
-supposed to pause the select-loop and return control back to the main
-program.
-
-=head1 METHODS
-
-=cut
-
-package Varnish::Test;
-
-use Varnish::Test::Case;
-use Varnish::Test::Engine;
-
-=head2 new
-
-Create a new Test object.
-
-=cut
-
-sub new($) {
- my ($this) = @_;
- my $class = ref($this) || $this;
-
- return bless({ 'cases' => [] }, $class);
-}
-
-=head2 start_engine
-
-Creates an associated L<Varnish::Test::Engine> object which in turn
-starts an L<IO::Multiplex>, a L<Varnish::Test::server>, and a
-L<Varnish::Test::Varnish> object.
-
-=cut
-
-sub start_engine($;@) {
- my ($self, @args) = @_;
-
- return if defined $self->{'engine'};
- $self->{'engine'} = Varnish::Test::Engine->new(@args);
-}
-
-=head2 stop_engine
-
-Stop Engine object using its "shutdown" method which also stops the
-server, Varnish, and closes all other open sockets (which might have
-been left by client objects that have not been shut down explicitly
-during test-case run).
-
-=cut
-
-sub stop_engine($;$) {
- my ($self) = @_;
-
- if (defined($self->{'engine'})) {
- $self->{'engine'}->shutdown();
- delete $self->{'engine'};
- }
-}
-
-=head2 cases
-
-Return a list of Perl modules under Varnish/Test/Case directory. These
-are all the available test-cases.
-
-=cut
-
-sub cases($) {
- my ($self) = @_;
-
- my $dir = $INC{'Varnish/Test/Case.pm'};
- $dir =~ s/\.pm$/\//;
- local *DIR;
- opendir(DIR, $dir)
- or die("$dir: $!\n");
- my @cases = sort grep { s/^(\w+)\.pm$/$1/ } readdir(DIR);
- closedir(DIR);
- return @cases;
-}
-
-=head2 run_case
-
-Run a test-case given by its name.
-
-=cut
-
-sub run_case($$) {
- my ($self, $name) = @_;
-
- my $module = 'Varnish::Test::Case::' . $name;
-
- eval 'use ' . $module;
- die $@ if $@;
-
- $self->start_engine();
-
- my $case = $module->new($self->{'engine'});
-
- push(@{$self->{'cases'}}, $case);
-
- eval {
- $case->init();
- $case->run();
- $case->fini();
- };
- if ($@) {
- $self->{'engine'}->log($self, 'TST: ', $@);
- $self->stop_engine();
- }
-}
-
-=head2 results
-
-Return a hashref of all test-case results.
-
-=cut
-
-sub results($) {
- my ($self) = @_;
-
- map { $_->results() } @{$self->{'cases'}};
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<Varnish::Test::Engine>
-L<Varnish::Test::Server>
-L<Varnish::Test::Varnish>
-L<Varnish::Test::Case>
-L<IO::Multiplex>
-
-=cut
More information about the varnish-commit
mailing list