+++ /dev/null
-* Completely POD-ify Perl-code.
-* Detect and act upon unexpected death of Varnish grandchild process.
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;
=head1 SEE ALSO
L<Varnish::Test>
+L<Varnish::Test::Report>
=cut
=head1 DESCRIPTION
-The varnish regression test framework works by starting up a Varnish
+The Varnish regression test framework works by starting up a Varnish
process and then communicating with this process as both 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.
+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
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) = @_;
$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) = @_;
}
}
+=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) = @_;
return @cases;
}
+=head2 run_case
+
+Run a test-case given by its name.
+
+=cut
+
sub run_case($$) {
my ($self, $name) = @_;
}
}
+=head2 results
+
+Return a hashref of all test-case results.
+
+=cut
+
sub results($) {
my ($self) = @_;
=head1 SEE ALSO
L<Varnish::Test::Engine>
-L<Varnish::Test::Varnish>
L<Varnish::Test::Server>
+L<Varnish::Test::Varnish>
L<Varnish::Test::Case>
+L<IO::Multiplex>
=cut
=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.
+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 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;
'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);
}
}
+=head2 fini
+
+Does the reverse of "init" by stopping the Varnish child and reverting
+to a default VCL definition.
+
+=cut
+
sub fini($) {
my ($self) = @_;
}
}
+=head2 run
+
+Run test-case proper when everything is set up right.
+
+=cut
+
sub run($;@) {
my ($self, @args) = @_;
$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) = @_;
# 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) = @_;
return $client;
}
+=head2 ev_server_request
+
+=cut
+
sub ev_server_request($$$$) {
my ($self, $server, $connection, $request) = @_;
$connection->send_response($response);
}
+=head2 ev_server_timeout
+
+=cut
+
sub ev_server_timeout($$) {
my ($self, $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) = @_;
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) = @_;
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) = @_;
unless $resp->code == $code;
}
+=head2 assert_ok
+
+Assert status "200 OK" using "assert_code" method above.
+
+=cut
+
sub assert_ok($;$) {
my ($self, $resp) = @_;
$self->assert_code(200, $resp);
}
+=head2 assert_xid
+
+Assert a certain XID in "X-Varnish" header.
+
+=cut
+
sub assert_xid($;$) {
my ($self, $resp) = @_;
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) = @_;
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) = @_;
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) = @_;
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) = @_;
}
}
+=head2 assert_body
+
+Assert presence of a HTTP body, optionally matching given regular
+expression.
+
+=cut
+
sub assert_body($;$$) {
my ($self, $re, $resp) = @_;
}
}
+=head2 assert_no_body
+
+Assert absence of HTTP body.
+
+=cut
+
sub assert_no_body($;$) {
my ($self, $resp) = @_;
# Miscellaneous
#
+=head1 MISCELLANEOUS METHODS
+
+=head2 usleep
+
+Sleep for a given number of microseconds.
+
+=cut
+
sub usleep($$) {
my ($self, $usec) = @_;
}
1;
+
+=head1 SEE ALSO
+
+L<Varnish::Test::Client>
+L<HTTP::Request>
+L<HTTP::Response>
+
+=cut
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;
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) = @_;
$self->logf("%s %s %s", $request->method(), $request->uri(), $request->protocol());
}
+=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->{'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) = @_;
}
}
+=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) = @_;
# 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) = @_;
}
}
+=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->{'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) = @_;
}
1;
+
+=head1 SEE ALSO
+
+L<HTTP::Response>
+L<HTTP::Request>
+
+=cut
=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.
+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, event dispatching is performed by the AUTOLOAD method.
+Additionally, an Engine object performs event dispatching and queuing,
+which are handled by an AUTOLOAD method.
+
+=head1 METHODS
=cut
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;
return $self;
}
+=head2 log
+
+Logging facility.
+
+=cut
+
sub log($$$) {
my ($self, $object, $prefix, $str) = @_;
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) = @_;
return undef;
}
+=head2 shutdown
+
+Shutdown Engine by shutting down Server, Varnish, and IO::Multiplex
+objects.
+
+=cut
+
sub shutdown($) {
my ($self) = @_;
}
}
-sub AUTOLOAD ($;@) {
+=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/.*://;
}
1;
+
+=head1 SEE ALSO
+
+L<Varnish::Test::Varnish>
+L<Varnish::Test::Server>
+L<IO::Multiplex>
+
+=cut
# $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;
return $self;
}
+=head2 new
+
+Generate report.
+
+=cut
+
sub run($@) {
my ($self, @cases) = @_;
}
1;
+
+=head1 SEE ALSO
+
+L<Template>
+
+=cut
TCP socket, receiving HTTP requests and sending responses.
Every established connection is handled by an associated object of
-type Varnish::Test::Server::Connection.
+type L<Varnish::Test::Server::Connection>.
=cut
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;
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) = @_;
delete $self->{'socket'};
}
-sub mux_connection($$$) {
- my ($self, $mux, $fh) = @_;
+=head2 got_request
- $self->log('CONNECT');
- my $connection = Varnish::Test::Server::Connection->new($self, $fh);
-}
+Called by L<Varnish::Test::Server::Connection> object when an HTTP
+message has been received. An B<ev_server_request> event is
+dispatched.
-sub mux_close($$) {
- my ($self, $mux, $fh) = @_;
-
- $self->log('CLOSE');
- delete $self->{'socket'} if $fh == $self->{'socket'};
-}
+=cut
sub got_request($$) {
my ($self, $connection, $request) = @_;
$self->{'engine'}->ev_server_request($self, $connection, $request);
}
-package Varnish::Test::Server::Connection;
+=head1 IO::MULTIPLEX CALLBACKS
-use strict;
-use HTTP::Status;
+=head2 mux_connection
-sub new($$) {
- my ($this, $server, $fh) = @_;
- my $class = ref($this) || $this;
+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.
- my $self = bless({ 'server' => $server,
- 'engine' => $server->{'engine'},
- 'fh' => $fh,
- 'mux' => $server->{'mux'},
- 'data' => '' }, $class);
- $self->{'mux'}->set_callback_object($self, $fh);
- return $self;
-}
+=cut
-sub send_response($$) {
- my ($self, $response) = @_;
+sub mux_connection($$$) {
+ my ($self, $mux, $fh) = @_;
- $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());
+ $self->log('CONNECT');
+ my $connection = Varnish::Test::Server::Connection->new($self, $fh);
}
-sub shutdown($) {
- my ($self) = @_;
-
- my $inbuffer = $self->{'mux'}->inbuffer($self->{'fh'});
+=head2 mux_close
- if (defined($inbuffer) and $inbuffer ne '') {
- use Data::Dumper;
+Called by L<IO::Multiplex> when the listening socket has been closed.
- $self->{'server'}->log('Junk or incomplete request. Discarding: ' . Dumper(\$inbuffer));
- $self->{'mux'}->inbuffer($self->{'fh'}, '');
- }
-
- $self->{'mux'}->close($self->{'fh'});
-}
-
-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);
- }
- }
-}
+=cut
-sub mux_timeout($$$) {
+sub mux_close($$) {
my ($self, $mux, $fh) = @_;
- $self->{'mux'}->set_timeout($fh, undef);
- $self->{'engine'}->ev_server_timeout($self);
+ $self->log('CLOSE');
+ delete $self->{'socket'} if $fh == $self->{'socket'};
}
-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.
+1;
- if ($$data ne '') {
- use Data::Dumper;
+=head1 SEE ALSO
- $self->{'server'}->log('Junk or incomplete request. Discarding: ' . Dumper($data));
- $$data = '';
- }
-}
+L<Varnish::Test::Server::Connection>
-1;
+=cut
--- /dev/null
+#!/usr/bin/perl -w
+#-
+# Copyright (c) 2006-2007 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+=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 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
=head1 NAME
-Varnish::Test::Varnish - Varnish child-process controller
+Varnish::Test::Varnish - Varnish daemon 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).
+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 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;
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) = @_;
$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"
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"
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"
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) = @_;
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) = @_;
}
}
+=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) = @_;
projects / varnish / commitdiff