diff --git a/testsuite/testswap/doc/HOW_TO_WRITE_A_PARALLEL_TEST.txt b/testsuite/testswap/doc/HOW_TO_WRITE_A_PARALLEL_TEST.txt new file mode 100644 index 0000000000000000000000000000000000000000..7c644d4729cc829f9ed708cfbb14a9a5701c2c58 --- /dev/null +++ b/testsuite/testswap/doc/HOW_TO_WRITE_A_PARALLEL_TEST.txt @@ -0,0 +1,61 @@ +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; diff --git a/testsuite/testswap/doc/HOW_TO_WRITE_A_SIMPLE_AUTOMATION_TEST.txt b/testsuite/testswap/doc/HOW_TO_WRITE_A_SIMPLE_AUTOMATION_TEST.txt new file mode 100644 index 0000000000000000000000000000000000000000..4130971bf7c0b199dd5c7b041085eefd905509f4 --- /dev/null +++ b/testsuite/testswap/doc/HOW_TO_WRITE_A_SIMPLE_AUTOMATION_TEST.txt @@ -0,0 +1,74 @@ +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"; + diff --git a/testsuite/testswap/lib/TestBed/ForkFramework.pm b/testsuite/testswap/lib/TestBed/ForkFramework.pm index 512e4ee00c6bc7e0b107afd0ef0a948c4c45e6fa..d428617aed017ea7ad78cbd5fbeca4a37d187eee 100644 --- a/testsuite/testswap/lib/TestBed/ForkFramework.pm +++ b/testsuite/testswap/lib/TestBed/ForkFramework.pm @@ -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; diff --git a/testsuite/testswap/lib/TestBed/Harness.pm b/testsuite/testswap/lib/TestBed/Harness.pm new file mode 100644 index 0000000000000000000000000000000000000000..e0e02d63e8a232b8f9c456c6cce1dc013e15a8fb --- /dev/null +++ b/testsuite/testswap/lib/TestBed/Harness.pm @@ -0,0 +1,44 @@ +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; diff --git a/testsuite/testswap/lib/TestBed/ParallelRunner.pm b/testsuite/testswap/lib/TestBed/ParallelRunner.pm index 3b9789adb7abd7370582fa1181875a90da98f0d0..1532a3944c80995dcfe5df826b3b42054775c280 100644 --- a/testsuite/testswap/lib/TestBed/ParallelRunner.pm +++ b/testsuite/testswap/lib/TestBed/ParallelRunner.pm @@ -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; diff --git a/testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm b/testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm index a018057af09d80326e91cb43b00406b22a9352a0..d5f84b7430f16e77bd194ebde65d1689d5eefa9d 100644 --- a/testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm +++ b/testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm @@ -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 +=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 diff --git a/testsuite/testswap/lib/TestBed/XMLRPC/Client.pm b/testsuite/testswap/lib/TestBed/XMLRPC/Client.pm index d9bcc8adf33a19ef3e56ad7a339b4b52ad8bcaef..9f8038b4f483900af9ca5571c1e5f9994f7fe70b 100644 --- a/testsuite/testswap/lib/TestBed/XMLRPC/Client.pm +++ b/testsuite/testswap/lib/TestBed/XMLRPC/Client.pm @@ -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; } diff --git a/testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm b/testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm index aa4cd97b1345dfe03de1b48c93ded41d0e0eefde..40bb697ed6c103112814d980f99288262265a86f 100644 --- a/testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm +++ b/testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm @@ -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 } diff --git a/testsuite/testswap/t/eine/elab_in_elab.t b/testsuite/testswap/t/eine/elab_in_elab.t index 830a5d268a4ed8f90d36cb069106a89e12379ed7..dbff2b16740edd96af7a7a0d42508dcf52eb4650 100644 --- a/testsuite/testswap/t/eine/elab_in_elab.t +++ b/testsuite/testswap/t/eine/elab_in_elab.t @@ -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; diff --git a/testsuite/testswap/t/harness b/testsuite/testswap/t/harness deleted file mode 100644 index 898e9d95fb9741776b65bf81000ca19b9efa1e6b..0000000000000000000000000000000000000000 --- a/testsuite/testswap/t/harness +++ /dev/null @@ -1,16 +0,0 @@ -#/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: diff --git a/testsuite/testswap/t/old/old.t b/testsuite/testswap/t/old/old.t deleted file mode 100644 index d2bcb6c975c2b8cd96c182bdb1dbb6d2973eab82..0000000000000000000000000000000000000000 --- a/testsuite/testswap/t/old/old.t +++ /dev/null @@ -1,25 +0,0 @@ -#!/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), $_); -} diff --git a/testsuite/testswap/t/parallel/basic_topologies.t b/testsuite/testswap/t/parallel/basic_topologies.t deleted file mode 100644 index 5363e16f6249f6e38a4b804965533d74f14b2d1b..0000000000000000000000000000000000000000 --- a/testsuite/testswap/t/parallel/basic_topologies.t +++ /dev/null @@ -1,6 +0,0 @@ -#! /usr/bin/perl -use TestBed::TestSuite; -use BasicTopologies; - -# run all the tests in RateLimitParallelExample -runtests; diff --git a/testsuite/testswap/tbts b/testsuite/testswap/tbts index 80ea7bdc742cc26914bba05b9a29ce6b974ceec1..d7cec38e9ffa53880264cb1914935b97fde8f2af 100755 --- a/testsuite/testswap/tbts +++ b/testsuite/testswap/tbts @@ -1,20 +1,18 @@ #!/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(); diff --git a/testsuite/testswap/t/old/oldtestsuite.pm b/testsuite/testswap/tests/OldTestSuite.pm similarity index 99% rename from testsuite/testswap/t/old/oldtestsuite.pm rename to testsuite/testswap/tests/OldTestSuite.pm index 2a3263052f33b13007e948ada1b05690d09ddd66..a1ac7ec7fc176e472fc13f2f74debd7d2f0ffbdf 100644 --- a/testsuite/testswap/t/old/oldtestsuite.pm +++ b/testsuite/testswap/tests/OldTestSuite.pm @@ -1,6 +1,6 @@ -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 diff --git a/testsuite/testswap/tests/OldTestSuiteTests.pm b/testsuite/testswap/tests/OldTestSuiteTests.pm new file mode 100644 index 0000000000000000000000000000000000000000..534f62b2eecf4146622bfc5d3721fbb3e6a8e796 --- /dev/null +++ b/testsuite/testswap/tests/OldTestSuiteTests.pm @@ -0,0 +1,32 @@ +#!/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;