package Varnish::Test;
use strict;
-use base 'Varnish::Test::Context';
+use base 'Varnish::Test::Object';
use Varnish::Test::Accelerator;
use Varnish::Test::Case;
use Varnish::Test::Client;
use Varnish::Test::Server;
-use Varnish::Test::Tokenizer;
+use Varnish::Test::Parser;
+use IO::Multiplex;
+
+use Data::Dumper;
sub new($;$) {
my $this = shift;
my $class = ref($this) || $this;
+ my $fn = shift;
- my $self = Varnish::Test::Context->new();
+ my $self = new Varnish::Test::Object;
bless($self, $class);
- $self->parse($_[0])
- if (@_);
+
+ $self->{'mux'} = new IO::Multiplex;
+
+ if ($fn) {
+ $self->parse($fn);
+ }
return $self;
}
-sub _parse_ticket($$) {
+sub parse($$) {
my $self = shift;
- my $t = shift;
+ my $fn = shift;
- $t->shift_keyword("ticket");
- push(@{$self->{'ticket'}}, $t->shift("Integer"));
- $t->shift("SemiColon");
-}
+ local $/;
+ open(SRC, "<", $fn) or die("$fn: $!\n");
+ my $src = <SRC>;
+ close(SRC);
-sub _parse_test($$) {
- my $self = shift;
- my $t = shift;
-
- my $token = $t->shift_keyword("test");
- $token = $t->shift("String");
- $self->{'descr'} = $token->value;
- $token = $t->shift("LeftBrace");
- for (;;) {
- $token = $t->peek();
- last if $token->is("RightBrace");
- if (!$token->is("Keyword")) {
- $t->die("expected keyword, got " . ref($token));
- } elsif ($token->value eq 'ticket') {
- $self->_parse_ticket($t);
- } elsif ($token->value eq 'accelerator') {
- my $x = Varnish::Test::Accelerator->new($self, $t);
- $t->die("duplicate declaration of " . $x->name)
- if exists($self->{'vars'}->{$x->name});
- $self->set($x->name, $x);
- } elsif ($token->value eq 'client') {
- my $x = Varnish::Test::Client->new($self, $t);
- $t->die("duplicate declaration of " . $x->name)
- if exists($self->{'vars'}->{$x->name});
- $self->set($x->name, $x);
- } elsif ($token->value eq 'server') {
- my $x = Varnish::Test::Server->new($self, $t);
- $t->die("duplicate declaration of " . $x->name)
- if exists($self->{'vars'}->{$x->name});
- $self->set($x->name, $x);
- } elsif ($token->value eq 'case') {
- my $x = Varnish::Test::Case->new($self, $t);
- } else {
- $t->die("unexpected keyword " . $token->value);
+ $::RD_HINT = 1;
+ my $parser = new Varnish::Test::Parser;
+ if (!defined($parser)) {
+ die("Error generating parser.");
+ }
+ my $tree = $parser->module($src);
+ if (!defined($tree)) {
+ die("Parsing error.");
+ }
+
+ print "###### SYNTAX TREE BEGIN ######\n";
+ print Dumper $tree if defined($tree->{'body'});
+ print "###### SYNTAX TREE END ######\n";
+
+ $self->{'objects'} = [];
+
+ foreach my $object (@{$tree->{'body'}}) {
+ if (ref($object) eq 'ARRAY') {
+ $self->{$$object[0]} = $$object[1];
+ }
+ elsif (ref($object)) {
+ push(@{$self->{'children'}}, $object);
+ $object->set_parent($self);
}
}
- $token = $t->shift("RightBrace");
}
-sub parse($$) {
+sub main($) {
my $self = shift;
- my $fn = shift;
- my $t = Varnish::Test::Tokenizer->new($fn);
- $self->_parse_test($t);
+ while (!$self->{'finished'}) {
+ &Varnish::Test::Object::run($self);
+ print "Entering IO::Multiplex loop.\n";
+ $self->{'mux'}->loop;
+ }
+
+ print "DONE.\n";
}
sub run($) {
my $self = shift;
+ return if $self->{'finished'};
+
+ &Varnish::Test::Object::run($self);
+
+ $self->shutdown if $self->{'finished'};
}
1;
use strict;
use base 'Varnish::Test::Object';
+sub run($) {
+ my $self = shift;
+
+ print "Running case \"$self->{name}\"...\n";
+
+ &Varnish::Test::Object::run($self);
+}
+
1;
use IO::Socket;
use URI;
-sub request($$$) {
+sub _init($) {
my $self = shift;
- my $server = shift;
- my $url = shift;
+
+ $self->set('protocol', '1.1');
+ $self->set('request', \&request);
+}
+
+sub request($$) {
+ my $self = shift;
+ my $invocation = shift;
+
+ my $server = $invocation->{'args'}[0]->{'return'};
+ my $uri = $invocation->{'args'}[1]->{'return'};
(defined($server) &&
($server->isa('Varnish::Test::Accelerator') ||
$server->isa('Varnish::Test::Server')))
or die("invalid server\n");
- $url = URI->new($url)
- or die("invalid URL\n");
- # GET $uri->path_query HTTP/$self->{'protocol'}
- # Host: $uri->host_port
- # Connection: xxx
+ $uri = new URI($uri)
+ or die("invalid URI\n");
+
+ my $fh = new IO::Socket::INET(Proto => 'tcp',
+ PeerAddr => $server->get('address'),
+ PeerPort => $server->get('port'))
+ or die "socket: $@";
+
+ my $mux = $self->get_mux;
+ $mux->add($fh);
+ $mux->set_callback_object($self, $fh);
+
+ $mux->write($fh, "Hello\r\n");
+ print "Client sent: Hello\n";
+
+ $self->{'request'} = $invocation;
+}
+
+sub mux_input($$$$) {
+ my $self = shift;
+ my $mux = shift;
+ my $fh = shift;
+ my $data = shift;
+
+ $self->{'request'}->{'return'} = $$data;
+ print "Client got: $$data";
+ $$data = "";
+ $self->{'request'}->{'finished'} = 1;
+ delete $self->{'request'};
+ $self->super_run;
+}
+
+sub mux_eof($$$$) {
+ my $self = shift;
+ my $mux = shift;
+ my $fh = shift;
+ my $data = shift;
+
+ $mux->close($fh);
}
1;
# parent, from which it inherits variables and procedures.
#
-sub new($;$) {
+sub new($$;$) {
my $this = shift;
my $class = ref($this) || $this;
+ my $name = shift;
my $parent = shift;
my $self = {
- 'parent' => $parent,
+ 'name' => $name,
'vars' => { },
- 'procs' => { },
};
bless($self, $class);
+ $self->set_parent($parent);
+
return $self;
}
-sub parent($) {
+sub set_parent($$) {
my $self = shift;
+ my $parent = shift;
- return $self->{'parent'};
+ if (defined($self->{'name'})) {
+ if (defined($self->{'parent'})) {
+ # Unlink from old parent.
+ $self->{'parent'}->unset($self->{'name'});
+ }
+ if (defined($parent)) {
+ # Link to new parent.
+ $parent->set($self->{'name'}, $self);
+ }
+ }
+
+ $self->{'parent'} = $parent;
}
-sub vars($) {
+sub parent($) {
my $self = shift;
- return $self->{'vars'};
+ return $self->{'parent'};
}
-sub procs($) {
+sub vars($) {
my $self = shift;
- return $self->{'procs'};
+ return $self->{'vars'};
}
sub set($$$) {
return $value;
}
+sub unset($$) {
+ my $self = shift;
+ my $key = shift;
+
+ delete $self->vars->{$key} if exists($self->vars->{$key});
+}
+
sub has($$) {
my $self = shift;
my $key = shift;
return exists($self->{'vars'}->{$key}) ||
- $self->parent->has($key);
+ $self->parent && $self->parent->has($key);
}
sub get($$) {
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Expression;
+
+use strict;
+use base 'Varnish::Test::Object';
+use Varnish::Test::Invocation;
+
+sub new($$;$) {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $terms = shift;
+ my $force_create = shift;
+
+ if (@$terms == 1 && (!$force_create || ref($$terms[0]) eq $class)) {
+ return $$terms[0];
+ }
+
+ my $children = [];
+
+ if (@$terms == 2
+ && ref($$terms[0]) eq 'Varnish::Test::Reference'
+ && ref($$terms[1]) eq 'ARRAY') {
+ my $invocation = new Varnish::Test::Invocation($$terms[0], $$terms[1]);
+ push (@$children, $invocation);
+ undef $terms;
+ }
+ else {
+ foreach my $term (@$terms) {
+ push (@$children, $term) if ref($term) eq 'Varnish::Test::Expression';
+ }
+ }
+
+ my $self = new Varnish::Test::Object(undef, $children);
+ bless($self, $class);
+ $self->{'terms'} = $terms;
+
+ return $self;
+}
+
+sub run($) {
+ my $self = shift;
+
+ return if $self->{'finished'};
+
+ &Varnish::Test::Object::run($self);
+
+ if ($self->{'finished'} && defined($self->{'terms'})) {
+ my $expr = '';
+ my $return_as_string = 0;
+
+ foreach my $term (@{$self->{'terms'}}) {
+ my $term_value;
+ if (ref($term) eq 'Varnish::Test::Expression') {
+ $term_value = $term->{'return'};
+ }
+ elsif (ref($term) eq 'Varnish::Test::Reference') {
+ $term_value = $term->get_value($self);
+ if (!defined($term_value)) {
+ die '"' . $term->as_string . '"' . " not defined";
+ }
+ }
+ else {
+ $term_value = $term;
+ }
+
+ if (ref(\$term_value) eq 'REF') {
+ if (@{$self->{'terms'}} == 1) {
+ $self->{'return'} = $term_value;
+ return;
+ }
+ else {
+ die "Found object/context reference in complex expression.";
+ }
+ }
+
+ if ($term_value =~ /^".*"$/s) {
+ $return_as_string = 1;
+ }
+
+ $expr .= $term_value;
+ }
+
+ ($expr) = $expr =~ /(.*)/s;
+
+ $expr = eval $expr;
+
+ if ($return_as_string) {
+ $expr = '"' . $expr . '"';
+ }
+
+ $self->{'return'} = $expr;
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Invocation;
+
+use strict;
+use base 'Varnish::Test::Object';
+
+sub new($$$) {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $func_id = shift;
+ my $args = shift;
+
+ my $self = new Varnish::Test::Object(undef, $args);
+ bless($self, $class);
+
+ $self->{'func_id'} = $func_id;
+ $self->{'args'} = $args;
+
+ return $self;
+}
+
+sub run($) {
+ my $self = shift;
+
+ return if $self->{'finished'};
+
+ &Varnish::Test::Object::run($self) unless $self->{'in_call'};
+
+ if ($self->{'finished'}) {
+ $self->{'finished'} = 0;
+ if (!$self->{'in_call'}) {
+ $self->{'in_call'} = 1;
+ my ($func_ptr, $func_context) = $self->{'func_id'}->get_function($self);
+ print "Calling " . $self->{'func_id'}->as_string, "\n";
+ &$func_ptr($func_context, $self);
+ }
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Message;
+
+use strict;
+use base 'Varnish::Test::Object';
+
+1;
use strict;
use base 'Varnish::Test::Context';
-use Varnish::Test::Code;
-sub new($$;$) {
+sub new($$$;$) {
my $this = shift;
my $class = ref($this) || $this;
+ my $name = shift;
+ my $children = shift;
my $parent = shift;
- my $self = Varnish::Test::Context->new($parent);
- $self->{'code'} = [];
+ my $self = new Varnish::Test::Context($name, $parent);
bless($self, $class);
- $self->_init();
+ for my $child (@$children) {
+ $child->set_parent($self);
+ }
- $self->_parse($_[0])
- if (@_);
+ $self->{'children'} = $children;
+ $self->{'finished'} = 0;
+ $self->{'return'} = undef;
+ $self->_init;
return $self;
}
sub _init($) {
+}
+
+sub run($) {
my $self = shift;
- # nothing
+ return if $self->{'finished'};
+
+ foreach my $child (@{$self->{'children'}}) {
+ $child->run($self) unless $child->{'finished'};
+ return unless $child->{'finished'};
+ $self->{'return'} = $child->{'return'};
+ }
+
+ $self->{'finished'} = 1;
}
-sub _parse($$) {
+sub shutdown($) {
my $self = shift;
- my $t = shift;
-
- $t->shift_keyword(lc($self->type));
- $self->name($t->shift("Identifier")->value);
- $t->shift("LeftBrace");
- while (!$t->peek()->is("RightBrace")) {
- push(@{$self->{'code'}}, Varnish::Test::Code->new($self, $t));
-# $token = $t->shift("Identifier");
-# my $key = $token->value;
-# $token = $t->shift("Assign");
-# $token = $t->shift("Integer", "Real", "String");
-# my $value = $token->value;
-# $token = $t->shift("SemiColon");
-# $t->warn("multiple assignments to $self->{'name'}.$key")
-# if ($self->has($key));
-# $self->set($key, $value);
+
+ foreach my $child (@{$self->{'children'}}) {
+ $child->shutdown;
+ }
+}
+
+sub get_mux($) {
+ my $self = shift;
+ return $self->{'mux'} || $self->{'parent'} && $self->{'parent'}->get_mux;
+}
+
+sub super_run($) {
+ my $self = shift;
+ if (defined($self->{'parent'})) {
+ $self->{'parent'}->super_run;
+ }
+ else {
+ $self->run;
}
- $t->shift("RightBrace");
}
1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2007 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Parser;
+
+use strict;
+
+use Parse::RecDescent;
+use Varnish::Test::Reference;
+use Varnish::Test::Expression;
+use Varnish::Test::Statement;
+use Varnish::Test::Client;
+use Varnish::Test::Server;
+use Varnish::Test::Accelerator;
+use Varnish::Test::Case;
+
+sub new {
+ return new Parse::RecDescent(<<'EOG');
+
+STRING_LITERAL:
+ { extract_delimited($text, '"') }
+
+IDENTIFIER:
+ /[a-z]\w*/i
+
+CONSTANT:
+ /[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
+
+reference:
+ <leftop: IDENTIFIER '.' IDENTIFIER>
+ { new Varnish::Test::Reference($item[1]) }
+
+argument_list:
+ <leftop: expression ',' expression>
+
+call:
+ reference '(' argument_list(?) ')'
+ { new Varnish::Test::Expression([$item[1], (@{$item[3]}) ? $item[3][0] : []]) }
+ | <error>
+
+primary_expression:
+ call
+ | reference
+ | STRING_LITERAL
+ | CONSTANT
+ | '(' expression ')'
+ { $item[2] }
+
+mul_op:
+ '*' | '/' | '%'
+
+multiplicative_expression:
+ <leftop: primary_expression mul_op primary_expression>
+ { new Varnish::Test::Expression($item[1]) }
+
+add_op:
+ '+' | '-' | '.'
+
+additive_expression:
+ <leftop: multiplicative_expression add_op multiplicative_expression>
+ { new Varnish::Test::Expression($item[1]) }
+
+rel_op:
+ '==' | '!=' | '<=' | '>=' | '<' | '>'
+
+expression:
+ additive_expression rel_op additive_expression
+ { new Varnish::Test::Expression([@item[1..$#item]], 1) }
+ | additive_expression
+ { new Varnish::Test::Expression([$item[1]], 1) }
+ | <error>
+
+statement:
+ reference '=' expression
+ { new Varnish::Test::Statement([@item[1..3]]) }
+ | call
+ { new Varnish::Test::Statement([$item[1]]) }
+
+block:
+ '{' statement(s? /;/) (';')(?) '}'
+ { $item[2] }
+ | <error>
+
+object:
+ 'ticket' CONSTANT ';'
+ { [@item[1,2]] }
+ | 'client' IDENTIFIER block
+ { new Varnish::Test::Client(@item[2,3]) }
+ | 'server' IDENTIFIER block
+ { new Varnish::Test::Server(@item[2,3]) }
+ | 'accelerator' IDENTIFIER block
+ { new Varnish::Test::Accelerator(@item[2,3]) }
+ | 'case' IDENTIFIER block
+ { new Varnish::Test::Case(@item[2,3]) }
+ | <error>
+
+module:
+ 'test' STRING_LITERAL(?) '{' object(s?) '}' /^\Z/
+ { { 'id' => (@{$item[2]}) ? $item[2][0] : undef,
+ 'body' => $item[4] } }
+ | <error>
+
+EOG
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -Tw
+#-
+# Copyright (c) 2006 Linpro AS
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer
+# in this position and unchanged.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id$
+#
+
+package Varnish::Test::Reference;
+
+use strict;
+
+sub new($$) {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $symbols = shift;
+
+ my $self = {
+ 'symbols' => $symbols,
+ };
+ bless($self, $class);
+
+ return $self;
+}
+
+sub as_string($) {
+ my $self = shift;
+ return join('.', @{$self->{'symbols'}});
+}
+
+sub _find_context($$) {
+ my $self = shift;
+ my $context = shift;
+
+ foreach my $symbol (@{$self->{'symbols'}}[0..$#{$self->{'symbols'}}-1]) {
+ $context = $context->get($symbol);
+ if (!(ref($context) =~ /^Varnish::Test::\w+$/
+ && $context->isa('Varnish::Test::Context'))) {
+ return undef;
+ }
+ }
+
+ return $context;
+}
+
+sub get_value($$) {
+ my $self = shift;
+ my $context = shift;
+
+ $context = $self->_find_context($context);
+ if (defined($context)) {
+ return $context->get($self->{'symbols'}[$#{$self->{'symbols'}}]);
+ }
+ else {
+ return undef;
+ }
+}
+
+sub set_value($$) {
+ my $self = shift;
+ my $context = shift;
+ my $value = shift;
+
+ $context = $self->_find_context($context);
+ if (defined($context)) {
+ $context->set($self->{'symbols'}[$#{$self->{'symbols'}}], $value);
+ }
+ else {
+ die "Cannot find containing context for ", join('.', @{$self->{'symbols'}}), ".\n";
+ }
+}
+
+sub get_function($$) {
+ my $self = shift;
+ my $context = shift;
+
+ $context = $self->_find_context($context);
+ if (defined($context)) {
+ return ($context->get($self->{'symbols'}[$#{$self->{'symbols'}}]), $context);
+ }
+}
+
+1;
package Varnish::Test::Request;
use strict;
-use base 'Varnish::Test::Object';
+use base 'Varnish::Test::Message';
1;
package Varnish::Test::Response;
use strict;
-use base 'Varnish::Test::Object';
+use base 'Varnish::Test::Message';
1;
use strict;
use base 'Varnish::Test::Object';
+use IO::Socket;
sub _init($) {
my $self = shift;
- $self->vars->{'address'} = 'localhost';
- $self->vars->{'port'} = '9001';
+ $self->set('address', 'localhost');
+ $self->set('port', '9001');
+}
+
+sub run($) {
+ my $self = shift;
+
+ return if $self->{'finished'};
+
+ &Varnish::Test::Object::run($self);
+
+ my $fh = new IO::Socket::INET(Proto => 'tcp',
+ LocalAddr => $self->get('address'),
+ LocalPort => $self->get('port'),
+ Listen => 4)
+ or die "socket: $@";
+
+ $self->{'fh'} = $fh;
+
+ my $mux = $self->get_mux;
+ $mux->listen($fh);
+ $mux->set_callback_object($self, $fh);
+}
+
+sub shutdown($) {
+ my $self = shift;
+
+ $self->get_mux->close($self->{'fh'});
+}
+
+sub mux_connection($$$) {
+ my $self = shift;
+ my $mux = shift;
+ my $fh = shift;
+
+ $mux->set_callback_object($self, $fh);
+}
+
+sub mux_input($$$$) {
+ my $self = shift;
+ my $mux = shift;
+ my $fh = shift;
+ my $data = shift;
+
+ print "Server got: $$data";
+ $$data = "";
+ $mux->write($fh, "HTTP/1.1 200 OK\r\n");
+ print "Server sent: HTTP/1.1 200 OK\n";
+ $mux->shutdown($fh, 1);
}
1;
# $Id$
#
-package Varnish::Test::Code;
+package Varnish::Test::Statement;
use strict;
+use base 'Varnish::Test::Object';
-sub new($$$) {
+sub new($$) {
my $this = shift;
my $class = ref($this) || $this;
- my $context = shift;
+ my $args = shift;
- my $self = {
- 'context' => $context,
- };
- bless($self, $class);
+ my $children = [];
- $self->_parse(shift)
- if (@_);
+ if (@$args > 1 && $$args[1] eq '=') {
+ my $self = new Varnish::Test::Object(undef, [$$args[2]]);
+ bless($self, $class);
- return $self;
+ $self->{'lhs'} = $$args[0];
+
+ return $self;
+ }
+ else {
+ return $$args[0];
+ }
}
-sub _parse($$) {
+sub run($$) {
my $self = shift;
- my $t = shift;
- print STDERR "\t";
- while (!$t->peek()->is("SemiColon")) {
- print STDERR " " . $t->peek()->value();
- $t->shift();
- }
- $t->shift("SemiColon");
- print STDERR ";\n";
-}
+ return if $self->{'finished'};
+
+ &Varnish::Test::Object::run($self);
-sub run($) {
+ if ($self->{'finished'}) {
+ $self->{'lhs'}->set_value($self, $self->{'return'});
+ }
}
1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Token;
-
-use strict;
-
-# Common constructor
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my $pos = shift;
-
- my $self = {
- 'pos' => $pos,
- 'value' => '???',
- };
- bless($self, $class);
-
- # hack: use eval to avoid clobbering @_
- eval { ($self->{'type'} = $class) =~ s/^(\w+::)*(\w+)$/$2/; };
-
- $self->init(@_);
-
- return $self;
-}
-
-# Default initializer
-sub init($;$) {
- my $self = shift;
-
- $self->value(@_);
-}
-
-sub type($;$) {
- my $self = shift;
-
- $self->{'type'} = shift
- if (@_);
- return $self->{'type'};
-}
-
-sub value($;$) {
- my $self = shift;
-
- $self->{'value'} = shift
- if (@_);
- return $self->{'value'};
-}
-
-sub is($$) {
- my $self = shift;
- my $type = shift;
-
- return ($self->{'type'} eq $type);
-}
-
-sub equals($$) {
- my $self = shift;
- my $other = shift;
-
- return ($self->type() eq $other->type() &&
- $self->value() eq $other->value());
-}
-
-package Varnish::Test::Token::Assign;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Comma;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Compare;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::EOF;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Identifier;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Integer;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Keyword;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::LeftBrace;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::LeftParen;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Period;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::Real;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::RightBrace;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::RightParen;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::SemiColon;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-package Varnish::Test::Token::String;
-
-use strict;
-use base 'Varnish::Test::Token';
-
-1;
+++ /dev/null
-#!/usr/bin/perl -Tw
-#-
-# Copyright (c) 2006 Linpro AS
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer
-# in this position and unchanged.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id$
-#
-
-package Varnish::Test::Tokenizer;
-
-use strict;
-use Varnish::Test::Token;
-
-sub new($$) {
- my $this = shift;
- my $class = ref($this) || $this;
-
- my $self = {};
- bless($self, $class);
- $self->tokenize($_[0])
- if (@_);
-
- return $self;
-}
-
-sub tokenize($$) {
- my $self = shift;
- my $fn = shift;
-
- local *FILE;
- local $/;
-
- $self->{'fn'} = $fn;
- $self->{'tokens'} = ();
-
- open(FILE, "<", $self->{'fn'})
- or die("$self->{'fn'}: $!\n");
- my $spec = <FILE>;
- close(FILE);
-
- # tokenize
- my @tokens = ();
- for (;;) {
- my $type = undef;
- if ($spec =~ m/\G\s*$/gc) {
- # EOF
- push(@tokens, Varnish::Test::Token::EOF->new(pos($spec)));
- last;
- } elsif ($spec =~ m/\G\s*(\*\/\*([^\*]|\*[^\/])+\*\/)/gc) {
- # multiline comment
- } elsif ($spec =~ m/\G\s*((?:\/\/|\#).*?)\n/gc) {
- # single-line comment
- } elsif ($spec =~ m/\G\s*\b(\d+\.\d+)\b/gc) {
- # real literal
- push(@tokens, Varnish::Test::Token::Real->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*\b(\d+)\b/gc) {
- # integer literal
- push(@tokens, Varnish::Test::Token::Integer->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*\"((?:\\.|[^\"])*)\"/gc) {
- # string literal
- push(@tokens, Varnish::Test::Token::String->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*\b(accelerator|client|init|server|case|test|ticket)\b/gc) {
- # keyword
- push(@tokens, Varnish::Test::Token::Keyword->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*\b(\w+)\b/gc) {
- # identifier
- push(@tokens, Varnish::Test::Token::Identifier->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\{)/gc) {
- # opening brace
- push(@tokens, Varnish::Test::Token::LeftBrace->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\})/gc) {
- # closing brace
- push(@tokens, Varnish::Test::Token::RightBrace->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\()/gc) {
- # opening paren
- push(@tokens, Varnish::Test::Token::LeftParen->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\))/gc) {
- # closing paren
- push(@tokens, Varnish::Test::Token::RightParen->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\;)/gc) {
- # semicolon
- push(@tokens, Varnish::Test::Token::SemiColon->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\.)/gc) {
- # period
- push(@tokens, Varnish::Test::Token::Period->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*(\,)/gc) {
- # comma
- push(@tokens, Varnish::Test::Token::Comma->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*([\<\>\=\!]=)/gc) {
- # comparison operator
- push(@tokens, Varnish::Test::Token::Compare->new(pos($spec), $1));
- } elsif ($spec =~ m/\G\s*([\+\-\*\/]?=)/gc) {
- # assignment operator
- push(@tokens, Varnish::Test::Token::Assign->new(pos($spec), $1));
-# } elsif ($spec =~ m/\G\s*([\+\-\*\/])/gc) {
-# # arithmetic operator
-# push(@tokens, Varnish::Test::Token::ArOp->new(pos($spec), $1));
- } else {
- die "$self->{'fn'}: syntax error\n" . substr($spec, pos($spec)) . "\n";
- }
- }
-
- $self->{'tokens'} = \@tokens;
- return @tokens;
-}
-
-sub die($$) {
- my $self = shift;
- my $msg = shift;
-
- CORE::die("$self->{'fn'}: $msg\n");
-}
-
-sub warn($$) {
- my $self = shift;
- my $msg = shift;
-
- CORE::warn("$self->{'fn'}: $msg\n");
-}
-
-
-# Return the next token from the input queue, but do not remove it
-# from the queue. Fatal if the queue is empty.
-sub peek($) {
- my $self = shift;
-
- $self->die("premature end of input")
- unless @{$self->{'tokens'}};
- return $self->{'tokens'}->[0];
-}
-
-# Remove the next token from the input queue and return it.
-# Additional (optional) arguments are token types which the next token
-# must match. Fatal if the queue is empty, or arguments were provided
-# but none matched.
-sub shift($;@) {
- my $self = CORE::shift;
- my @expect = @_;
-
- $self->die("premature end of input")
- unless @{$self->{'tokens'}};
- my $token = shift @{$self->{'tokens'}};
- if (@expect) {
- return $token
- if grep({ $token->is($_) } @expect);
- $self->die("expected " . join(", ", @expect) . ", got " . $token->type);
- }
- return $token;
-}
-
-# As shift(), but next token must be a keyword and the arguments are
-# matched against the token's value rather than its type.
-sub shift_keyword($@) {
- my $self = CORE::shift;
- my @expect = @_;
-
- my $token = $self->shift("Keyword");
- return $token
- if grep({ $token->value eq $_ } @expect);
- $self->die("expected " . join(", ", @expect) . ", got " . $token->value);
-}
-
-1;
comment = "client 1.0, server 1.0";
c1.protocol = "1.0";
s1.protocol = "1.0";
- c1.request(a1, "http://www.example.com/");
- assert(c1.response.protocol == "1.0");
- }
-
- case c10_s11 {
- comment = "client 1.0, server 1.1";
- c1.protocol = "1.0";
- s1.protocol = "1.1";
- c1.request(a1, "http://www.example.com/");
- assert(c1.response.protocol == "1.0");
- }
-
- case c11_s10 {
- comment = "client 1.1, server 1.0";
- c1.protocol = "1.1";
- s1.protocol = "1.0";
- c1.request(a1, "http://www.example.com/");
- assert(c1.response.protocol == "1.1");
- }
-
- case c11_s11 {
- comment = "client 1.1, server 1.1";
- c1.protocol = "1.1";
- s1.protocol = "1.1";
- c1.request(a1, "http://www.example.com/");
- assert(c1.response.protocol == "1.1");
+ c1.request(s1, "http://www.example.com/");
+ c1.request(s1, "http://www.example.com/");
+ c1.request(s1, "http://www.example.com/");
}
}
use Data::Dumper;
MAIN:{
- my $test = Varnish::Test->new($ARGV[0]);
+ my $test = new Varnish::Test($ARGV[0]);
#print STDERR Dumper($test);
+ $test->main;
}
projects / varnish / commitdiff