Commit 2d953a1b authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap ErrorStrategy

parent 74919953
DOCS TODO
Overview / howto write a test
TODO
TIMEOUT of XMLRPC Calls
TESTLWP
scp cleanup
chmod +x
wait for end of experiment
cmdline params (-D)
VERBOSENESS
Add basic image-test parameterization examples
EXAMPLES, Get some tests
traffic generation
convert more old tests
general result code handling framework
STILL MESSY
XMLRPC/Client/Experiment TestSuite/Experiment return codes, exceptions, composability
Calling parallel tests
XMLRPC/Client/Experiment TestSuite/Experiment dsl
EXPAND CURRENT IMPLEMENTATION
event subsystem
......@@ -30,7 +26,6 @@ LATER
Large External Tars and Resources for experiements
buildup, teardown using Test::Class
create BSD virtual machine for testing
possibly collapse tbts and t/harness
Parallel TODOS
retry
......
......@@ -25,13 +25,13 @@ sub _initialize {
return $self;
}
package TestBed::ParallelRunner;
use SemiModern::Perl;
use TestBed::ParallelRunner::Test;
use TestBed::ForkFramework;
use Data::Dumper;
use Mouse;
use TBConfig;
our $ExperimentTests = [];
......@@ -42,12 +42,16 @@ Not enough arguments to teste
teste($pid, $gid, $eid, $ns, $sub, $test_count, $desc);
END
sub add_experiment { push @$ExperimentTests, TestBed::ParallelRunner::Test::tn(@_); }
sub add_experiment {
my $te = TestBed::ParallelRunner::Test::tn(@_);
push @$ExperimentTests, $te;
$te;
}
sub runtests {
my ($concurrent_pre_runs, $concurrent_node_count_usage ) = @_;
$concurrent_pre_runs ||= 4;
$concurrent_node_count_usage ||= 20;
$concurrent_pre_runs ||= $TBConfig::concurrent_prerun_jobs;
$concurrent_node_count_usage ||= $TBConfig::concurrent_node_usage;
#prerun step
my $result = TestBed::ForkFramework::MaxWorkersScheduler::work($concurrent_pre_runs, sub { $_[0]->prep }, $ExperimentTests);
......@@ -63,14 +67,18 @@ sub runtests {
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 ];
if ($maximum_nodes > $concurrent_node_count_usage) {
warn "$eid requires upto $maximum_nodes nodes, only $concurrent_node_count_usage concurrent nodes permitted\n$eid will not be run";
}
else {
push @weighted_experiements, [ +$maximum_nodes, +$item_id ];
}
}
@weighted_experiements = sort { $a->[0] <=> $b->[0] } @weighted_experiements;
#count tests step
my $test_count = 0;
map { $test_count += $_->test_count } @$ExperimentTests;
map { $test_count += $ExperimentTests->[$_->[1]]->test_count } @weighted_experiements;
#run tests
reset_test_builder($test_count, no_numbers => 1);
......@@ -114,7 +122,7 @@ sub tap_wrapper {
my ($te) = @_;
if ($ENABLE_SUBTESTS_FEATURE) {
TestBed::ForkFramework::Scheduler->redir_std_fork( sub {
TestBed::ForkFramework::fork_redir( sub {
my ($in, $out, $err, $pid) = @_;
#while(<$out>) { print "K2" . $_; }
use TAP::Parser;
......@@ -138,7 +146,7 @@ sub tap_wrapper {
sub build_TAP_stream {
use TestBed::TestSuite;
my ($in, $out, $err, $pid) = TestBed::ForkFramework::redir_fork(sub { runtests; });
my ($in, $out, $err, $pid) = TestBed::ForkFramework::fork_child_redir(sub { runtests; });
return TAP::Parser::Iterator::StdOutErr->new($out, $err, $pid);
}
......
#!/usr/bin/perl
package TestBed::ParallelRunner::Exception;
use Mouse;
has original => ( is => 'rw');
no Mouse;
package TestBed::ParallelRunner::RetryAtEnd;
use Mouse;
extends('TestBed::ParallelRunner::Exception');
no Mouse;
package TestBed::ParallelRunner::SwapOutFailed;
use Mouse;
extends('TestBed::ParallelRunner::Exception');
no Mouse;
package TestBed::ParallelRunner::ErrorStrategy;
use SemiModern::Perl;
use Mouse;
sub swapin_error { }
sub run_error { }
sub swapout_error {
my ($xmlrpc_error) = @_;
die TestBed::ParallelRunner::SwapOutFailed->new($xmlrpc_error);
}
sub end_error { }
package TestBed::ParallelRunner::ErrorRetryStrategy;
use SemiModern::Perl;
use Mouse;
extends 'TestBed::ParallelRunner::ErrorStrategy';
sub swapin_error {
my @retry_causes = qw( temp internal software hardware canceled unknown);
my ($xmlrpc_error) = @_;
if ($xmlrpc_error =~ /RPC::XML::Struct/) {
my $cause = $xmlrpc_error->value->value->{'cause'};
if ( grep { /$cause/ } @retry_causes) {
die TestBed::ParallelRunner::RetryAtEnd->new($xmlrpc_error);
}
}
}
=head1 NAME
TestBed::ParallelRunner::ErrorStrategy
handle parallel run errors;
=over 4
=item C<< swapin_error($error) >>
=item C<< run_error($error) >>
=item C<< swapout_error($error) >>
=item C<< end_error($error) >>
=back
=cut
1;
#!/usr/bin/perl
package TestBed::ParallelRunner::Test;
use TestBed::ParallelRunner::ErrorStrategy;
use SemiModern::Perl;
use TestBed::TestSuite::Experiment;
use Mouse;
......@@ -9,16 +10,18 @@ has 'e' => ( isa => 'TestBed::TestSuite::Experiment', is => 'rw');
has 'desc' => ( isa => 'Str', is => 'rw');
has 'ns' => ( isa => 'Str', is => 'rw');
has 'proc' => ( isa => 'CodeRef', is => 'rw');
has 'test_count' => ( isa => 'Any', is => 'rw');
has 'test_count' => ( isa => 'Any', is => 'rw');
has 'error_strategy' => ( is => 'rw');
sub tn {
my ($e, $ns, $sub, $test_count, $desc) = @_;
return TestBed::ParallelRunner::Test->new(
'e' => $e,
'ns' => $ns,
'desc' => $desc,
'proc' => $sub,
'test_count' => $test_count );
'test_count' => $test_count,
'desc' => $desc,
);
}
sub prep {
......@@ -38,22 +41,27 @@ sub run {
sub run_ensure_kill {
my $self = shift;
eval {
$self->run;
};
my $run_exception = $@;
eval {
$self->kill;
};
my $kill_exception = $@;
my $error_strategy = $self->error_strategy || TestBed::ParallelRunner::ErrorStrategy->new;
eval { $self->swapin_wait; };
$error_strategy->swapin_error(my $swapin_exception = $@);
die $swapin_exception if $swapin_exception;
eval { $self->proc->($self->e); };
$error_strategy->run_error(my $run_exception = $@);
eval { $self->swapout_wait; };
$error_strategy->swapout_error(my $swapout_exception = $@);
eval { $self->kill; };
$error_strategy->kill_error(my $kill_exception = $@);
die $run_exception if $run_exception;
die $swapout_exception if $run_exception;
die $kill_exception if $kill_exception;
return 1;
}
sub kill {
my $self = shift;
$self->e->end;
$self->e->end_wait;
}
=head1 NAME
......
......@@ -21,6 +21,18 @@ sub rege {
else { die 'Too many args to rege'; }
return TestBed::ParallelRunner::add_experiment($e, @_);
}
sub rege_with_strategy {
my $strategy = pop @_;
my $te = rege(@_);
$te->strategy($strategy);
$te;
}
sub rege_with_retry {
rege_with_strategy(@_, TestBed::ParallelRunner::ErrorRetryStrategy->new);
}
sub runtests { TestBed::ParallelRunner::runtests(@_); }
......@@ -99,6 +111,13 @@ sub override {
return { %{($params || {})}, %overrides };
}
use Carp;
$SIG{ __DIE__ } = sub {
say Dumper($_[0]) if ref($_[0]) eq 'HASH';
Carp::confess( @_ )
};
=head1 NAME
TestBed::TestSuite
......@@ -127,6 +146,14 @@ creates a new experiment with pid, gid, and eid
registers experiement with parallel test running engine
=item C<rege_with_strategy(rege args ..., $strategy)>
registers experiement with a error strategy
=item C<rege_with_retry(rege args ...)>
registers experiement with the retry if fail on swapin strategy
=item C<runtests($concurrent_pre_runs, $concurrent_node_count_usage) >
allows a maximum of $concurrent_pre_runs during parallel execution
......
......@@ -47,16 +47,17 @@ 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, 'noswapin' =>1, noemail, @_ ); }
sub batchexp_ns { shift->augment_code( 'nsfilestr' => shift, 'noswapin' =>1, noemail, 'extrainfo' => 1, @_ ); }
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 swapin { shift->augment_func_code( 'swapexp', noemail, 'direction' => 'in', 'extrainfo' => 1, @_ ); }
sub swapout { shift->augment_func_code( 'swapexp', noemail, 'direction' => 'out','extrainfo' => 1, @_ ); }
sub end { shift->augment_func_code( 'endexp', noemail); }
sub end_wait { shift->augment_func_code( 'endexp', noemail, 'wait' => 1); }
sub nodeinfo { parseNodeInfo(shift->augment_func_output('expinfo', 'show' => 'nodeinfo')); }
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 waitforended { my $e = shift; retry_on_TIMEOUT { $e->augment_func_code( 'statewait', 'state' => 'ended' ) } 'waitforended'; }
sub startexp_ns { batchexp_ns(@_, 'batch' => 0); }
sub startexp_ns_wait { batchexp_ns_wait(@_, 'batch' => 0); }
sub create_and_get_metadata {
......@@ -70,20 +71,32 @@ 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->startexp_ns_wait(@_);
if ($rc && $rc != EXPERIMENT_NAME_ALREADY_TAKEN) { return $rc }
$self->swapin_wait;
eval { $self->startexp_ns_wait(@_); };
my $exception = $@;
if ($exception) {
unless ($exception->isa('RPC::XML::struct') and $exception->value->{ 'code' } == EXPERIMENT_NAME_ALREADY_TAKEN) {
die $exception;
}
}
my $rc = eval { $self->swapin_wait; };
$exception = $@;
if ($exception) {
unless ($exception->isa('RPC::XML::struct') and $exception->value->{ 'code' } == 2) {
die $exception;
}
}
$rc;
}
sub swapin_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'in', 'wait' => 1, noemail );
$self->swapin('wait' => 1);
$self->waitforactive;
}
sub swapout_wait {
my $self = shift;
$self->augment_func_code( 'swapexp', 'direction' => 'out', 'wait' => 1, noemail );
$self->swapout('wait' => 1);
$self->waitforswapped
}
......@@ -179,6 +192,10 @@ swaps the experiment out
ends the experiment
=item C<< $e->end_wait >>
ends the experiment, waits for it to reach the ended state
=item C<< $e->nodeinfo >>
returns a list of node names in the experiment
......@@ -191,6 +208,11 @@ waits for the experiment to enter the active state
waits for the experiment to enter the swapped state
=item C<< $e->waitforended >>
waits for the experiment to enter the ended state
=item C<< $e->startexp_ns($nsfile_contents, @args) >>
start experiment defined in $nsfile_contents
......
......@@ -45,6 +45,7 @@ sub end_all_experiments {
say "";
if (yn_prompt("Are you sure you want to terminate all experiments?")) {
e(@{$_->[0]})->end for( experiments_hash_to_list(list_full));
e(@{$_->[0]})->waitforended for( experiments_hash_to_list(list_full));
}
}
if (@ARGV) {
......@@ -54,7 +55,7 @@ if (@ARGV) {
else {
my $e = e(shift);
if (/--help/) { usage; }
elsif (/end/) { $e->end; }
elsif (/end/) { $e->end_wait; }
elsif (/ping/ ) { $e->ping_test; }
elsif (/swapin/) { $e->swapin_wait; }
elsif (/swapout/) { $e->swapout_wait; }
......@@ -64,7 +65,7 @@ if (@ARGV) {
elsif (/single_node_tests/) { $e->single_node_tests; }
elsif (/ni/) { say Dumper($e->nodeinfo) ;}
elsif (/li/) { say Dumper($e->linkinfo) ;}
elsif (/ex/) {
elsif ($_ eq'ex') {
say $ARGV[0];
my $result = eval $ARGV[0];
sayd($result);
......
......@@ -3,7 +3,7 @@ use SemiModern::Perl;
use TestBed::ForkFramework;
use Data::Dumper;
use Test::Exception;
use Test::More tests => 2;
use Test::More tests => 3;
my $results = TestBed::ForkFramework::MaxWorkersScheduler::work(2, sub { my $d = `date`; chomp($d); $_[0] . " $d " . $$; }, ['K1', 'K2', 'K3', 'K4'] );
ok($results->[0]== 0 && @{ $results->[1] } == 4, 'ForkFramework::MaxWorkersScheduler::work');
......@@ -12,4 +12,10 @@ $results = TestBed::ForkFramework::RateScheduler::work(4, sub { my $d = `date`;
[[1, 1], [1, 0], [2, 2], [3, 3]],
['K1', 'K2', 'K3', 'K4'] );
ok($results->[0]== 0 && @{ $results->[1] } == 4, 'ForkFramework::RateScheduler::work');
use TestBed::ParallelRunner::ErrorStrategy;
$results = TestBed::ForkFramework::RateScheduler::work(4, sub { die TestBed::ParallelRunner::RetryAtEnd->new; },
[[1, 0]],
['K1', 'K2', 'K3', 'K4'] );
ok($results->[0]== 1 && @{ $results->[2] } == 1, 'ForkFramework::RateScheduler::work, retry');
#say Dumper($results);
......@@ -2,20 +2,17 @@
use SemiModern::Perl;
use TestBed::TestSuite;
use Test::More tests => 3;
use Test::Exception;
use Data::Dumper;
use BasicNSs;
my $e = e('ensureactive');
=pod
ok(!$e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'first start');
ok($e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'failed second start');
throws_ok {$e->startexp_ns_wait($BasicNSs::TwoNodeLan)} 'RPC::XML::struct', 'failed second start';
ok(!$e->ensure_active_ns($BasicNSs::TwoNodeLan), 'ensure active_start');
ok(!$e->end);
=cut
sleep(5);
system('./sc');
ok(!$e->end_wait, 'kill_wait succeded');
ok(!$e->ensure_active_ns($BasicNSs::TwoNodeLan), 'ensure active_start');
ok($e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'failed second start');
ok(!$e->end);
throws_ok {$e->startexp_ns_wait($BasicNSs::TwoNodeLan)} 'RPC::XML::struct', 'failed second start';
ok(!$e->end_wait, 'kill_wait succeded');
......@@ -28,6 +28,8 @@ use Data::Dumper;
my $group;
my $defines;
my $xmlrpcurl;
my $concurrent_prerun_jobs;
my $concurrent_node_usage;
my $result = GetOptions (
# "D=s%" => \$defines,
# "jobs=i" => \$pjobs,
......@@ -37,7 +39,10 @@ use Data::Dumper;
"project=s" => \$project,
"xmlrpcurl=s" => \$xmlrpcurl,
"group=s" => \$group,
"debug" => \$debug);
"debug" => \$debug,
"cprj=i" => \$concurrent_prerun_jobs,
"cnu=i" => \$concurrent_node_usage,
);
if ($debug) { $ENV { 'TBTS_DEBUG' } = 1; }
if ($group) { $ENV { 'TBTS_GROUP' } = $group; }
......@@ -100,11 +105,11 @@ if (@ARGV) {
}
elsif (/critic/) { exec 'perlcritic lib t'; }
elsif (/sanity/) { runharness( qw(t/lib/*.t t/lib/*/*.t t/xmlrpc/*.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); }
elsif (/coding/) { runharness qw(t/coding/pod_coverage.t); }
elsif (/coding/) { runharness qw(t/coding/pod_coverage.t); }
}
else {
print usage();
......
......@@ -49,4 +49,21 @@ set link1 [$ns duplex-link $node1 $node2 100Mb 50ms DropTail]
$ns run
END
our $TooManyLans = << 'END';
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" 100Mb 0ms]
set lan2 [$ns make-lan "$node1 $node2" 100Mb 0ms]
set lan3 [$ns make-lan "$node1 $node2" 100Mb 0ms]
set lan4 [$ns make-lan "$node1 $node2" 100Mb 0ms]
set lan5 [$ns make-lan "$node1 $node2" 100Mb 0ms]
$ns run
END
1;
......@@ -23,7 +23,7 @@ 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) {
for (@who_knows) {
my $eid = $_;
my $ns = $OldTestSuite::tests->{$_}->{'nsfile'};
rege($_, $ns, sub { ok(!shift->ping_test, $eid); }, 1, $_)
......
......@@ -6,9 +6,11 @@ use Test::More;
my $test_body = sub {
my $e = shift;
sleep(5);
ok(!($e->ping_test), 'Ping Test');
sleep(5);
};
rege("k$_", $BasicNSs::TwoNodeLan, $test_body, 1, "k$_ desc" ) for (1..2);
rege("ksks$_", $BasicNSs::SingleNode, $test_body, 1, "k$_ desc" ) for (1..5);
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