Commit 752040a4 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap New Harness and separation of start and swap

parent a8d6de15
HOWTO write a parallel test.
1. create a perl module in tests/ e.g. test/BasicTopologies.pm
TestBed::TestStute provides the rege (register experiment for parallel execution) function
rege has the following signature
rege($eid, $ns_file_contents, $test_body_sub, $number_of_tests_in_test_body, $test_description);
when the experiment is swapped in $test_body_sub will get called with a single argument $e, the TestBed::TestSuite::Experiement object.
EXTRA DETAILS:
SemiModern::Perl provides the say function and turns on strict and warnings;
TestBed::TestSuite provides the rege constructor function
BasicNSs provides some common $ns_file_contents
Test::More provides Perl's basic test functions
Perl Modules should end with a single statement, e.g. 1;
DO NOT give Test::More any use argumentes i.e.
use Test::More tests => 1; # DO NOT DO THIS, parallel tests in tests/ may be ran with othere testsuites.
specify the number of test in the rege call.
3. run the set of parallel tests
./tbts test/BasicTopologies.pm
### test/BasicTopologies.pm ###
#!/usr/bin/perl
use SemiModern::Perl;
use TestBed::TestSuite;
use BasicNSs;
use Test::More;
my $linkupdowntest = sub {
my ($e) = @_;
my $eid = $e->eid;
ok($e->linktest, "$eid linktest");
ok($e->link("link1")->down, "link down");
sleep(2);
my $n1ssh = $e->node("node1")->ssh;
ok($n1ssh->cmdfailuredump("ping -c 5 10.1.2.3"));
ok($e->link("link1")->up, "link up");
sleep(2);
ok($n1ssh->cmdsuccessdump("ping -c 5 10.1.2.3"));
};
rege('linkupdown', $BasicNSs::TwoNodeLanWithLink, $linkupdowntest, 5, 'link up and down with ping on link');
my $twonodelan5Mbtest = sub {
my ($e) = @_;
my $eid = $e->eid;
ok($e->linktest, "$eid linktest");
};
rege('2nodelan5Mb', $BasicNSs::TwoNodeLan5Mb, $twonodelan5Mbtest, 1, 'two node 5mb lan pingswapkill');
rege('singlenode', $BasicNSs::SingleNode, sub { ok(shift->pingswapkill); }, 1, 'single node pingswapkill');
rege('2nodelan', $BasicNSs::TwoNodeLan, sub { ok(shift->pingswapkill); }, 1, 'two node lan pingswapkill');
1;
HOWTO write a simple automation test.
1. create a perl script in t/ e.g. t/topologies/link_up_link_down.t
TestBed::TestStute provides the e (experiment constructor) function
e has the following signatures
e($eid);
e($pid, $eid);
e($pid, $gid, $eid);
EXTRA DETAILS:
SemiModern::Perl provides the say function and turns on strict and warnings
TestBed::TestSuite provides the e constructor function
BasicNSs provides some common $ns_file_contents
Test::More provides Perl's basic test functions
specify atest plan
use Test::More tests => 5; #says there are 5 ok tests in this test script
use Test::More 'no_plan'; #says there is no predetermined plan, Test::More wont't ensure that 5 tests run, only that there are no failures.
my $ns = <<'NSEND'; #this is heredoc syntax that allows embedding of multiline text until the NSEND token is reached;
see lib/TestBed/XMLRPC/Client/Experiment.pm lib/TestBed/TestSuite/Experiment.pm for api details that you can use on an experiment.
pod2text lib/TestBed/XMLRPC/Client/Experiment.pm
pod2text lib/TestBed/TestSuite/Experiment.pm
2. run the set of parallel tests
./tbts t/topologies/link_up_link_down.t
### test/BasicTopologies.pm ###
#!/usr/bin/perl
use SemiModern::Perl;
use TestBed::TestSuite;
use Test::More tests => 5;
my $ns = <<'NSEND';
source tb_compat.tcl
set ns [new Simulator]
set node1 [$ns node]
set node2 [$ns node]
set lan1 [$ns make-lan "$node1 $node2" 5Mb 20ms]
set link1 [$ns duplex-link $node1 $node2 100Mb 50ms DropTail]
$ns run
NSEND
my $eid='linkupdown';
my $e = e($eid);
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
ok($e->linktest, "$eid linktest");
ok($e->link("link1")->down, "link down");
sleep(2);
my $n1ssh = $e->node("node1")->ssh;
ok($n1ssh->cmdfailuredump("ping -c 5 10.1.2.3"));
ok($e->link("link1")->up, "link up");
sleep(2);
ok($n1ssh->cmdsuccessdump("ping -c 5 10.1.2.3"));
$e->end && die "exp end $eid failed";
......@@ -66,6 +66,29 @@ sub in { shift->pipes->[0]; }
sub out { shift->pipes->[1]; }
sub err { shift->pipes->[2]; }
package TestBed::ForkFramework;
sub redir_fork {
my ($worker) = @_;
my $redir = TestBed::ForkFramework::Redir::build;
if ( my $pid = fork ) {
#Parent
my $handles = $redir->parentAfterFork;
return (@$handles, $pid);
}
else {
#Child
$redir->childAfterFork;
use POSIX '_exit';
eval q{END { _exit 0 }};
$worker->();
CORE::exit;
}
}
package TestBed::ForkFramework::Scheduler;
use SemiModern::Perl;
use Mouse;
......
use SemiModern::Perl;
use TAP::Harness;
require Exporter;
our @ISA = qw(Exporter TAP::Harness);
our @EXPORT = qw(runharness);
use TestBed::TestSuite;
sub parser_args_callback {
my $args = shift;
my $ref = $args->{source};
if (ref $ref and $ref->isa('TestBed::ParallelRunner')) {
delete $args->{source};
$args->{'stream'} = $ref->build_TAP_stream;
}
$args;
}
sub split_t_pm {
my @t;
my @pm;
map {
if (/\.pm$/) { push @pm, glob($_); }
elsif (/\.t$/) { push @t, glob($_); }
} @_;
(\@t, \@pm);
}
sub runharness {
my @parts = my ($ts, $pms) = split_t_pm(@_);
for (@$pms) { eval "require \'$_\';"; }
my %harness_args = (
verbosity => 1,
lib => [ '.', 'lib', 'blib/lib' ],
);
my $harness = TAP::Harness->new( \%harness_args );
$harness->callback('parser_args', \&parser_args_callback);
push @$ts, TestBed::ParallelRunner->new() if @$pms;
$harness->runtests(@$ts);
}
1;
......@@ -31,8 +31,9 @@ use SemiModern::Perl;
use TestBed::ParallelRunner::Test;
use TestBed::ForkFramework;
use Data::Dumper;
use Mouse;
my $ExperimentTests = [];
our $ExperimentTests = [];
my $teste_desc = <<'END';
Not enough arguments to teste
......@@ -44,12 +45,12 @@ END
sub add_experiment { push @$ExperimentTests, TestBed::ParallelRunner::Test::tn(@_); }
sub runtests {
#prep step
# say "Prepping";
my $result = TestBed::ForkFramework::MaxWorkersScheduler::work(4, sub {
#return { 'maximum_nodes' => 3};
$_[0]->prep
}, $ExperimentTests);
my ($concurrent_pre_runs, $concurrent_node_count_usage ) = @_;
$concurrent_pre_runs ||= 4;
$concurrent_node_count_usage ||= 20;
#prerun step
my $result = TestBed::ForkFramework::MaxWorkersScheduler::work($concurrent_pre_runs, sub { $_[0]->prep }, $ExperimentTests);
if ($result->[0]) {
sayd($result->[2]);
die 'TestBed::ParallelRunner::runtests died during test prep';
......@@ -58,7 +59,12 @@ sub runtests {
#create schedule step
my @weighted_experiements;
for (@{$result->[1]}) {
push @weighted_experiements, [ $_->[0]->{'maximum_nodes'}, $_->[1] ];
my ($hash, $item_id) = @$_;
my $maximum_nodes = $hash->{'maximum_nodes'};
my $eid = $ExperimentTests->[$item_id]->e->eid;
#say "$eid $item_id $maximum_nodes";
push @weighted_experiements, [ $maximum_nodes, $item_id ];
}
@weighted_experiements = sort { $a->[0] <=> $b->[0] } @weighted_experiements;
......@@ -66,14 +72,18 @@ sub runtests {
my $test_count = 0;
map { $test_count += $_->test_count } @$ExperimentTests;
# say "Running";
#run tests
reset_test_builder($test_count, no_numbers => 1);
$result = TestBed::ForkFramework::RateScheduler::work(20, \&tap_wrapper, \@weighted_experiements, $ExperimentTests);
$result = TestBed::ForkFramework::RateScheduler::work($concurrent_node_count_usage, \&tap_wrapper, \@weighted_experiements, $ExperimentTests);
set_test_builder_to_end_state($test_count);
return;
}
sub set_test_builder_to_end_state {
my ($test_count, %options) = @_;
use Test::Builder;
my $b = Test::Builder->new;
$b->current_test($test_count);
#sayd($result);
return;
}
sub reset_test_builder {
......@@ -126,4 +136,10 @@ sub tap_wrapper {
return 0;
}
sub build_TAP_stream {
use TestBed::TestSuite;
my ($in, $out, $err, $pid) = TestBed::ForkFramework::redir_fork(sub { runtests; });
return TAP::Parser::Iterator::StdOutErr->new($out, $err, $pid);
}
1;
......@@ -187,16 +187,19 @@ sub linkdown {
catches exceptions while a test is running and cleans up the experiment
=cut
use constant TRYTEST_SUCCES => 1;
use constant TRYTEST_FAILURE => 0;
sub trytest(&$) {
my ($sub, $e) = @_;
eval {$sub->()};
if ($@) {
say $@;
$e->end;
0;
eval {$e->end};
if ($@) { my $eid = $e->eid; warn "finally cleanup of $eid failed in trytest";}
TRYTEST_FAILURE;
}
else {
1;
TRYTEST_SUCCES;
}
}
......@@ -210,7 +213,7 @@ sub startrunkill {
my ($e, $ns, $worker) = @_;
my $eid = $e->eid;
trytest {
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ensure_active_ns($ns) && die "batchexp $eid failed";
$worker->($e) || die "worker function failed";
$e->end && die "exp end $eid failed";
} $e;
......@@ -219,7 +222,7 @@ sub startrunkill {
sub startrun {
my ($e, $ns, $worker) = @_;
my $eid = $e->eid;
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ensure_active_ns($ns) && die "batchexp $eid failed";
$worker->($e) || die "worker function failed";
}
......@@ -231,7 +234,7 @@ sub launchpingkill {
my ($e, $ns) = @_;
my $eid = $e->eid;
trytest {
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ensure_active_ns($ns) && die "batchexp $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->end && die "exp end $eid failed";
} $e;
......@@ -247,7 +250,7 @@ sub launchpingswapkill {
my ($e, $ns) = @_;
my $eid = $e->eid;
trytest {
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ensure_artive_ns($ns) && die "batchexp $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->swapout_wait && die "swap out $eid failed";
$e->swapin_wait && die "swap in $eid failed";
......@@ -256,7 +259,21 @@ trytest {
} $e;
}
=item C<pingkill($e)>
=item C<< $e->pingkill() >>
method that runs a ping_test, and ends the experiment
=cut
sub pingkill {
my ($e, $ns) = @_;
my $eid = $e->eid;
trytest {
$e->ping_test && die "connectivity test $eid failed";
$e->end && die "exp end $eid failed";
} $e;
}
=item C<< $e->pingswapkill() >>
method that runs a ping_test,
swaps the experiment out and then back in, runs a ping test, and finally
......
......@@ -75,6 +75,9 @@ sub single_request {
if ((!ref($resp)) && ($resp =~ /SSL \w+ timeout/)) {
die "SSL_SOCKET_TIMEOUT";
}
if ($resp->isa('RPC::XML::struct') && $resp->value->{'code'} != 0 ) {
die $resp;
}
$resp;
}
......
......@@ -30,64 +30,60 @@ sub args {
return { 'pid' => $pid, 'gid' => $gid, 'eid' => $eid, @_ };
}
sub retry_on_TIMEOUT(&) {
my ($sub) = @_;
sub retry_on_TIMEOUT(&$) {
my ($sub, $message) = @_;
RETRY:
{
my $result = eval { $sub->(); };
if ($@ && $@ =~ /SSL_SOCKET_TIMEOUT/) {
warn "SSL_SOCKET_TIMEOUT after $TBConfig::XMLRPC_SERVER_TIMEOUT seconds";
warn "SSL_SOCKET_TIMEOUT after $TBConfig::XMLRPC_SERVER_TIMEOUT seconds in $message";
redo RETRY;
}
$result;
}
}
sub noemail { @TBConfig::EXPERIMENT_OPS_PARAMS; }
sub echo { shift->augment_output( 'str' => shift ); }
sub getlist_brief { shift->augment( 'format' => 'brief'); }
sub getlist_full { shift->augment( 'format' => 'full' ); }
sub batchexp_ns { shift->augment_code( 'nsfilestr' => shift, @_ ); }
sub modify_ns { shift->augment_code( 'nsfilestr' => shift, @_ ); }
sub swapin { shift->augment_func_code( 'swapexp', 'direction' => 'in' ); }
sub swapout { shift->augment_func_code( 'swapexp', 'direction' => 'out' ); }
sub end { shift->augment_func_code( 'endexp' ); }
sub batchexp_ns { shift->augment_code( 'nsfilestr' => shift, 'noswapin' =>1, noemail, @_ ); }
sub modify_ns { shift->augment_code( 'nsfilestr' => shift, noemail, @_ ); }
sub swapin { shift->augment_func_code( 'swapexp', noemail, 'direction' => 'in' ); }
sub swapout { shift->augment_func_code( 'swapexp', noemail, 'direction' => 'out' ); }
sub end { shift->augment_func_code( 'endexp', noemail); }
sub nodeinfo { parseNodeInfo(shift->augment_func_output('expinfo', 'show' => 'nodeinfo')); }
sub waitforactive { my $e = shift; retry_on_TIMEOUT { $e->augment_func_code('waitforactive', @_) }; }
sub waitforswapped { my $e = shift; retry_on_TIMEOUT { $e->augment_func_code( 'statewait', 'state' => 'swapped' ) }; }
sub waitforactive { my $e = shift; retry_on_TIMEOUT { $e->augment_func_code('waitforactive', @_) } 'waitforactive'; }
sub waitforswapped { my $e = shift; retry_on_TIMEOUT { $e->augment_func_code( 'statewait', 'state' => 'swapped' ) } 'waitforswapped'; }
sub startexp_ns { batchexp_ns(@_, 'batch' => 0); }
sub startexp_ns_wait { batchexp_ns_wait(@_, 'batch' => 0); }
sub create_and_get_metadata {
my $self = shift;
$self->startexp_ns(@_, 'noswapin' => 1, 'wait' => 1);
$self->startexp_ns_wait(shift);
$self->metadata;
}
sub batchexp_ns_wait {
my $self = shift;
my $rc = $self->batchexp_ns(@_);
if ($rc) { return $rc }
$self->waitforactive;
}
sub batchexp_ns_wait { shift->batchexp_ns(@_,'wait' => 1); }
use constant EXPERIMENT_NAME_ALREADY_TAKEN => 2;
sub ensure_active_ns {
my $self = shift;
my $rc = $self->batchexp_ns(@_);
my $rc = $self->startexp_ns_wait(@_);
if ($rc && $rc != EXPERIMENT_NAME_ALREADY_TAKEN) { return $rc }
$self->waitforactive;
$self->swapin_wait;
}
sub swapin_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'in', 'wait' => 1 );
$self->augment_func_code( 'swapexp', 'direction' => 'in', 'wait' => 1, noemail );
$self->waitforactive;
}
sub swapout_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'out', 'wait' => 1 );
$self->augment_func_code( 'swapexp', 'direction' => 'out', 'wait' => 1, noemail );
$self->waitforswapped
}
......
......@@ -33,6 +33,8 @@ sub run_inside_exper {
my $boss_name = $e->node('myboss.eine.tbres.emulab.net')->name;
my $boss_url = "https://$boss_name:3069/usr/testbed";
say $boss_url;
ok(!system("./tbts -x -v https://$boss_url/usr/testbed t/xmlrpc/experiment.t"), 'eine single node experiment');
my $cmd = "./tbts -d -x '$boss_url' t/xmlrpc/experiment.t";
say $cmd;
ok(!system($cmd), 'eine single node experiment');
}
run_inside_exper;
#/usr/bin/perl
use strict;
use warnings;
use TAP::Harness;
use Data::Dumper;
my %args = (
verbosity => 1,
lib => [ '.', 'lib', 'blib/lib' ],
);
my $harness = TAP::Harness->new( \%args );
my @default_tests = qw( t/*.t );
my @tests = map { glob($_) } (@ARGV ? @ARGV : @default_tests);
$harness->runtests(@tests);
# vim: ft=perl:
#!/usr/bin/perl
use SemiModern::Perl;
use TestBed::TestSuite;
use TestBed::TestSuite::Experiment
use Test::More qw(no_plan);
use Data::Dumper;
require 't/old/oldtestsuite.pm';
our @pass = qw(basic cbr complete5 delaylan1 delaylink);
our @who_knows_passed = qw( lan1 multilink );
our @who_knows = qw( ixp lan1 nodes singlenode trafgen simplelink simplex setip red ping );
our @should_fail = qw(negprerun toomanylinks toofast);
=pod
vtypes (may want to parameterize the vtypes)
S fixed (you will have to change the ns file depending on which nodes are
available)
=cut
#for (@pass) {
for (@who_knows) {
my $ns = $Testbed::OldTestSuite::data->{$_}->{'nsfile'};
say "Running " . $_;
say $ns;
ok(e($_)->launchpingkill($ns), $_);
}
#! /usr/bin/perl
use TestBed::TestSuite;
use BasicTopologies;
# run all the tests in RateLimitParallelExample
runtests;
#!/usr/bin/perl
use lib 'lib';
#add lib directory to library search path
use lib qw(lib tests);
use SemiModern::Perl;
#add localcpan path to library search path
if (-f glob("~/lib/perl5/Test/Harness.pm")) {
my $glob = glob('~/lib/perl5');
my $localcpan_path = glob('~/lib/perl5');
my $p5l = $ENV{PERL5LIB};
unless ( (defined $p5l) && ($p5l =~ /$glob/)) {
if (defined $p5l) {
$ENV{PERL5LIB} .= ":$glob";
}
else {
$ENV{PERL5LIB} = "$glob";
}
unless ( (defined $p5l) && ($p5l =~ /$localcpan_path/)) {
my $sep = (defined $p5l) ? ":" : "";
$ENV { PERL5LIB} .= "$sep" . " $localcpan_path";
}
}
#add tests directory to library search path
$ENV{PERL5LIB} .= ":tests";
use Data::Dumper;
......@@ -47,26 +45,17 @@ use Data::Dumper;
if ($project) { $ENV { 'TBTS_PROJECT' } = $project; }
if ($timing) { $ENV { 'HARNESS_TIMER' } = 1; }
if ($verbose) { $ENV { 'HARNESS_VERBOSE' } = 1; $ENV { 'HARNESS_COLOR' } = 1; }
if ($xmlrpcurl) { $ENV { 'TBTS_XMLRPC_URL' } = $xmlrpcurl; }
if ($xmlrpcurl) { $ENV { 'TBTS_XMLRPC_URL' } = $xmlrpcurl; }
}
my $THARNESS = 'perl t/harness';
sub usage {
our $ts;
our $tpms;
sub wanted_t {
if (-f && /\.t$/) {
$ts .= " " . $File::Find::name . "\n";
}
}
sub wanted_tests {
if (-f && /\.pm$/) {
$tpms .= " " . $File::Find::name . "\n";
}
}
sub scandir_t { if (-f && /\.t$/) { $ts .= " " . $File::Find::name . "\n"; } }
sub scandir_tests { if (-f && /\.pm$/) { $tpms .= " " . $File::Find::name . "\n"; } }
use File::Find;
find(\&wanted_t, 't');
find(\&wanted_tests, 'tests');
find(\&scandir_t, 't');
find(\&scandir_tests, 'tests');
print <<"USAGE";
TestBed TestSwap
......@@ -86,7 +75,6 @@ TestBed TestSwap
xmlrpc - all xmlrpc client modules tests
critic - runs perl critic on framework code
coding -
TESTFILES:
USAGE
......@@ -94,29 +82,19 @@ USAGE
print $tpms;
}
my @basic_exper_tests = qw(
t/topologies/single_node.t
t/topologies/two_node_lan.t
t/topologies/simple_two_node_linktest.t
t/topologies/link_up_link_down.t
);
#sayd(@basic_exper_tests);
use TestBed::Harness;
if (@ARGV) {
my $cmd = $ARGV[0];
$_ = $cmd;
chomp $_;
if (/.*\.t$/ || /.*\.pm/) { exec "$THARNESS $cmd"; }
if (/.*\.t$/ || /.*\.pm$/) { runharness(@ARGV); }
elsif ($_ eq 'podc') { system 'for x in `find lib -iname "*.pm"`; do podchecker $x 2>&1 |grep contain; done; '; }
elsif ($_ eq 'pode') { system 'for x in `find lib -iname "*.pm"`; do podchecker $x 2>&1 |grep ERROR; done;'; }
elsif (/critic/) { exec 'perlcritic lib t'; }
elsif (/codingtests/) { }
elsif (/sanity/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t t/xmlrpc/*.t "; }
elsif (/lib/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t"; }
elsif (/xmlrpc/) { exec "$THARNESS t/xmlrpc/*.t"; }
elsif (/test/) { exec "$THARNESS t/topologies/*.t"; }
elsif (/test/) { exec "$THARNESS t/topologies/*.t"; }
elsif (/sanity/) { runharness( qw(t/lib/*.t t/lib/*/*.t t/xmlrpc/*.t)); }
elsif (/lib/) { runharness qw(t/lib/*.t t/lib/*/*.t); }
elsif (/xmlrpc/) { runharness qw(t/xmlrpc/*.t); }
elsif (/test/) { runharness qw(t/topologies/*.t); }
}
else {
print usage();
......
package Testbed::OldTestSuite;
package OldTestSuite;
our $data = {
our $tests = {
'frontend' => {},
'cbr' => {
'info' => 'Test UDP and a TCP agent/CBR. Also throw in some events to start/stop
......
#!/usr/bin/perl
use SemiModern::Perl;
use TestBed::TestSuite;
use Test::More;
use Data::Dumper;
use OldTestSuite;
our @should_pass = qw( basic cbr complete5 delaylan1 delaylink );
our @who_knows_passed = qw( lan1 multilink );
our @who_knows = qw( ixp lan1 nodes singlenode trafgen simplelink simplex setip red ping );
our @should_fail = qw( negprerun toomanylinks toofast );
#cbr basic complete5 delaylan1 delaylink
#lan1 multilink
#ixp nodes singlenode trafgen simplelink simplex red ping
#negprerun toomanylinks toofast
#unclassified
#frontend dnardshelf mini_nodes spinglass sharkshelf full vtypes spinglass2 fixed set-ip basic_rsrv widearea_types delaycheck mini_set-ip db1 10mbit buddycache trivial mini_tbcmd widearea_mapped mini_multilink tbcmd
=pod
vtypes (may want to parameterize the vtypes)
fixed (you will have to change the ns file depending on which nodes are available)
=cut
for (@should_pass) {
my $eid = $_;
my $ns = $OldTestSuite::tests->{$_}->{'nsfile'};
rege($_, $ns, sub { ok(!shift->ping_test, $eid); }, 1, $_)
}
1;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment