-* Ticket 55.
* Completely POD-ify Perl-code.
* Detect and act upon unexpected death of Varnish grandchild process.
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 regressions tests start, an instance of Varnish is forked off as
-a child process, and its I/O channels (std{in,out,err}) are controlled
-by the parent process which also performs the test by playing the role
+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 IO::Multiplex.
-As a result of using a select-loop, the framework has an event-driven
-design in order to cope with unpredictable sequence of processing on
-either server og client side. To drive a test-case forward, the
-select-loop is paused when certain events occur, and control returns
-to the "main program" which can then inspect the situation. This
-results in certain structural constraints. It is essential to be aware
-of whether a piece of code is going to run inside or outside the
-select-loop.
-
-The framework uses Perl objects to represent instances of servers and
-clients as well as the Varnish instance itself. In addition, there is
-an "engine" object which propagates events and controls the program
-flow related to the select-loop.
+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.
=cut
# $Id$
#
+=head1 NAME
+
+Varnish::Test::Case - test-case superclass
+
+=head1 DESCRIPTION
+
+Varnish::Test::Case is meant to be the superclass of specific
+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.
+
+=cut
+
package Varnish::Test::Case;
use strict;
-use Varnish::Test::Logger;
-
+use Varnish::Test::Client;
use HTTP::Request;
use HTTP::Response;
use Time::HiRes qw(gettimeofday tv_interval);
# $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;
sub mux_input($$$$) {
my ($self, $mux, $fh, $data) = @_;
+ # 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/) {
+ # 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;
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(sprintf('Partial response. Bytes in body: %d received, %d expected, %d remaining',
$data_length, $content_length, $content_length - $data_length));
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.');
last;
}
}
+
+ # At this point, what remains in the input buffer is either
+ # nothing at all or a partial HTTP message.
}
sub mux_eof($$$$) {
# $Id$
#
+=head1 NAME
+
+Varnish::Test::Engine - select-loop wrapper and event dispatcher
+
+=head1 DESCRIPTION
+
+Varnish::Test::Engine is primarily a wrapper around a
+IO::Multiplex-based select-loop which monitors activity on
+client-side, server-side and Varnish's I/O-channels. On startup, it
+automatically creates an associated Server object and a Varnish
+objects whoses sockets/filehandles are registered in the
+IO::Multiplex-object.
+
+Additionally, event dispatching is performed by the AUTOLOAD method.
+
+=cut
+
package Varnish::Test::Engine;
use strict;
use Varnish::Test::Server;
use Varnish::Test::Varnish;
-use Varnish::Test::Client;
use IO::Multiplex;
sub new($$;%) {
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;
$self->{'mux'}->loop;
delete $self->{'in_loop'};
delete $self->{'wait_for'};
+ # Loop has now been paused due to the occurrence of an event we
+ # were waiting for. This event is always found in the front of the
+ # pending events queue at this point, so return it.
return @{shift @{$self->{'pending'}}} if @{$self->{'pending'}} > 0;
+
+ # 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;
}
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);
}
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));
+ # 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 (@{$self->{'pending'}} > 0) {
- push(@{$self->{'pending'}}, [ $event, @args ]);
+ # 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;
}
+++ /dev/null
-#!/usr/bin/perl -w
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Logger;
-
-sub new($;$) {
- my ($this, $prefix) = @_;
- my $class = ref($this) || $this;
-
- my $self = bless({ 'prefix' => $prefix || '' }, $class);
-}
-
-sub write($$;$) {
- my ($self, $data, $extra_prefix) = @_;
-
- my $prefix = $self->{'prefix'};
- $prefix .= ': ' . $extra_prefix if defined($extra_prefix);
-
- if ($prefix) {
- $data =~ s/^/$prefix: /gm;
- }
-
- $data =~ s/\n?$/\n/;
-
- print STDERR $data;
-}
-
-1;
# $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 Varnish::Test::Server::Connection.
+
+=cut
+
package Varnish::Test::Server;
use strict;
sub mux_input($$$$) {
my ($self, $mux, $fh, $data) = @_;
+ # 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.
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);
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.
+
die "Junk or incomplete request\n"
unless $$data eq '';
}
# $Id$
#
+=head1 NAME
+
+Varnish::Test::Varnish - Varnish child-process controller
+
+=head1 DESCRIPTION
+
+A Varnish::Test::Varnish object is used to fork off a Varnish child
+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.
+
+=cut
+
package Varnish::Test::Varnish;
use strict;
use Socket;
-use Varnish::Test::Logger;
-
sub new($$;$) {
my ($this, $engine, $attrs) = @_;
my $class = ref($this) || $this;
'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);
shutdown(STDERR_READ, 1);
shutdown(STDERR_WRITE, 0);
- delete $SIG{CHLD};
+ # Ignore SIGCHLD.
+ $SIG{CHLD} = 'IGNORE';
my $pid = fork;
die "fork(): $!\n"
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;
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);
}
else {
# Parent
-
- $SIG{CHLD} = 'IGNORE';
-
$self->log('PID: ' . $pid);
close STDIN_READ;
$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'});
projects / varnish / commitdiff