testsuite/testswap added ensure_swaped_ns, simplifying parallel run

testsuite/testswap/TODO

@@ -10,6 +10,10 @@ TODO
   convert more old tests
   general result code handling framework
 
+STILL MESSY
+  XMLRPC/Client/Experiment TestSuite/Experiment return codes, exceptions, composability
+  Calling parallel tests 
+
 EXPAND CURRENT IMPLEMENTATION
   event subsystem
   parallel support (custom test harness)
@@ -23,12 +27,13 @@ LATER
   create BSD virtual machine for testing
   possibly collapse tbts and t/harness
 
+Parallel TODOS
+  retry
+  clean up FFF, Roles, constructors
+  CartProd teste - image test example
+
 DONE
   POD function documentation
   better general result code handling (ping_test single_node_test)
   ForkFramework Constants
 
-Parallel TODOS
-  retry
-  clean up FFF, Roles, constructors
-  CartProd teste - image test example

testsuite/testswap/lib/TestBed/ForkFramework.pm

@@ -102,6 +102,8 @@ sub workloop {
       redo LOOP;
     }
   }
+  waitpid( $_, 0 ) for @{ $self->workers };
+
   my @results = (scalar @{$self->errors}, $self->results, $self->errors);
   return wantarray ? @results : \@results;
 }

testsuite/testswap/lib/TestBed/TestExperiment.pm → testsuite/testswap/lib/TestBed/ParallelRunner.pm

@@ -26,18 +26,14 @@ sub _initialize {
 }
 
 
-package TestBed::TestExperiment;
+package TestBed::ParallelRunner;
 use SemiModern::Perl;
-use TestBed::TestExperiment::Test;
+use TestBed::ParallelRunner::Test;
 use TestBed::ForkFramework;
 use Data::Dumper;
 
 my $ExperimentTests = [];
 
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(teste runtests);
-
 my $teste_desc = <<'END';
 Not enough arguments to teste
   teste(eid, $ns, $sub, $test_count, $desc);
@@ -45,13 +41,7 @@ Not enough arguments to teste
   teste($pid, $gid, $eid, $ns, $sub, $test_count, $desc);
 END
       
-sub teste {
-  if (@_ == 4)    { push @$ExperimentTests, TestBed::TestExperiment::Test::tn('', '', '', @_); }
-  elsif (@_ == 5) { push @$ExperimentTests, TestBed::TestExperiment::Test::tn('', '', @_);     }
-  elsif (@_ == 6) { push @$ExperimentTests, TestBed::TestExperiment::Test::tn(shift, '', @_);  }
-  elsif (@_ == 7) { push @$ExperimentTests, TestBed::TestExperiment::Test::tn(@_);             }
-  else { die $teste_desc; }
-} 
+sub add_experiment { push @$ExperimentTests, TestBed::ParallelRunner::Test::tn(@_); }
 
 sub runtests {
   #prep step
@@ -62,7 +52,7 @@ sub runtests {
   }, $ExperimentTests);
   if ($result->[0]) {
     sayd($result->[2]);
-    die 'TestBed::TestExperiment::runtests died during test prep';
+    die 'TestBed::ParallelRunner::runtests died during test prep';
   }
 
   #create schedule step
@@ -96,6 +86,15 @@ sub reset_test_builder {
   else { $b->no_plan; }
 }
 
+sub setup_test_builder_ouputs {
+  my ($out, $err) = @_;
+  use Test::Builder;
+  my $b = Test::Builder->new;
+  $b->output($out);
+  $b->fail_output($out);
+  $b->todo_output($out);
+}
+
 use Carp;
 $SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
 
@@ -117,6 +116,7 @@ sub tap_wrapper {
     },
     sub {
       reset_test_builder($te->test_count) if $SUBTESTS;
+      setup_test_builder_ouputs(*STDOUT, *STDERR);
       $te->run_ensure_kill;
     });
   }

testsuite/testswap/lib/TestBed/TestExperiment/Test.pm → testsuite/testswap/lib/TestBed/ParallelRunner/Test.pm

 #!/usr/bin/perl
-package TestBed::TestExperiment::Test;
+package TestBed::ParallelRunner::Test;
 use SemiModern::Perl;
 use TestBed::TestSuite::Experiment;
 use Mouse;
@@ -12,12 +12,8 @@ has 'proc' => ( isa => 'CodeRef', is => 'rw');
 has 'test_count'   => ( isa => 'Any', is => 'rw');
 
 sub tn {
-  my ($pid, $gid, $eid, $ns, $sub, $test_count, $desc) = @_;
-  my $e = TestBed::TestSuite::Experiment->new(
-      'pid' => $pid,
-      'gid' => $gid,
-      'eid' => $eid);
-  return TestBed::TestExperiment::Test->new(
+  my ($e, $ns, $sub, $test_count, $desc) = @_;
+  return TestBed::ParallelRunner::Test->new(
     'e' => $e, 
     'ns' => $ns,
     'desc' => $desc,
@@ -27,7 +23,9 @@ sub tn {
 
 sub prep {
   my $self = shift;
-  $self->e->create_and_get_metadata($self->ns);
+  my $r = $self->e->create_and_get_metadata($self->ns);
+  #sayd($r);
+  $r;
 }
 
 sub run {

testsuite/testswap/lib/TestBed/TestSuite.pm

@@ -2,14 +2,26 @@
 package TestBed::TestSuite;
 use SemiModern::Perl;
 use TestBed::TestSuite::Experiment;
+use TestBed::ParallelRunner;
 use Data::Dumper;
 use Tools;
 
 require Exporter;
 our @ISA = qw(Exporter);
-our @EXPORT = qw(e dpge CartProd CartProdRunner concretize defaults override);
+our @EXPORT = qw(e CartProd CartProdRunner concretize defaults override rege runtests);
 
 sub e { TestBed::TestSuite::Experiment->new(_build_e_from_positionals(@_)); }
+sub rege {
+  my $e;
+  if (@_ == 4)    { $e = e(); }
+  elsif (@_ == 5) { $e = e(shift); }
+  elsif (@_ == 6) { $e = e(shift, shift); }
+  elsif (@_ == 7) { $e = e(shift, shift, shift); }
+  else { die 'Too many args to rege'; }
+  return TestBed::ParallelRunner::add_experiment($e, @_);
+}
+sub runtests { TestBed::ParallelRunner::runtests; }
+
 
 sub _build_e_from_positionals {
   if (@_ == 0) { return {}; }

testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm

@@ -11,13 +11,7 @@ use TestBed::TestSuite;
 use TestBed::TestSuite::Node;
 use TestBed::TestSuite::Link;
 
-extends 'Exporter', 'TestBed::XMLRPC::Client::Experiment';
-
-has 'ns' => ( isa => 'Str', is => 'rw');
-
-require Exporter;
-our @EXPORT;
-push @EXPORT, qw(launchpingkill launchpingswapkill);
+extends 'TestBed::XMLRPC::Client::Experiment';
 
 =head1 NAME
 
@@ -156,7 +150,7 @@ sub startrun {
 
 =item C<launchpingkill($e, $ns)>
 
-class method that starts an experiment, runs a ping_test, and ends the experiment
+method that starts an experiment, runs a ping_test, and ends the experiment
 =cut
 sub launchpingkill {
   my ($e, $ns) = @_;
@@ -170,7 +164,7 @@ sub launchpingkill {
 
 =item C<launchpingkill($e, $ns)>
 
-class method that starts an experiment, runs a ping_test, 
+method that starts an experiment, runs a ping_test, 
 swaps the experiment out and then back in, runs a ping test, and finally
 ends the experiment
 =cut
@@ -187,6 +181,24 @@ trytest {
   } $e;
 }
 
+=item C<pingkill($e)>
+
+method that runs a ping_test, 
+swaps the experiment out and then back in, runs a ping test, and finally
+ends the experiment
+=cut
+sub pingswapkill {
+  my ($e) = @_;
+  my $eid = $e->eid;
+trytest {
+    $e->ping_test             && die "connectivity test $eid failed";
+    $e->swapout_wait          && die "swap out $eid failed";
+    $e->swapin_wait           && die "swap in $eid failed";
+    $e->ping_test             && die "connectivity test $eid failed";
+    $e->end                   && die "exp end $eid failed";
+  } $e;
+}
+
 =back
 
 =cut

testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm

@@ -33,21 +33,14 @@ sub args {
 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( 'nsfilestr' => shift, @_ ); }
-sub modify_ns      { shift->augment( 'nsfilestr' => shift, @_ ); }
+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 nodeinfo       { parseNodeInfo(shift->augment_func_output('expinfo', 'show' => 'nodeinfo')); }
-sub waitforactive  {
-  my $self = shift;
-  $self->augment_code(@_) && die sprintf("wait for swapin %s failed", $self->eid);
-}
-sub waitforswapped { 
-  my $self = shift;
-  $self->augment_func_code( 'statewait', 'state' => 'swapped' )
-     && die sprintf("wait for swapin %s failed", $self->eid);
-}
+sub waitforactive  { shift->augment_code(@_) }
+sub waitforswapped { shift->augment_func_code( 'statewait', 'state' => 'swapped' ) }
 
 sub startexp_ns { batchexp_ns(@_, 'batch' => 0); }
 sub startexp_ns_wait { batchexp_ns_wait(@_, 'batch' => 0); }
@@ -60,14 +53,25 @@ sub create_and_get_metadata {
 
 sub batchexp_ns_wait { 
   my $self = shift;
-  $self->batchexp_ns(@_);
+  my $rc = $self->batchexp_ns(@_);
+  if ($rc) { return $rc }
+  $self->waitforactive;
+}
+
+use constant EXPERIMENT_NAME_ALREADY_TAKEN => 2;
+sub ensure_active_ns {
+  my $self = shift;
+  my $rc = $self->batchexp_ns(@_);
+  if ($rc && $rc != EXPERIMENT_NAME_ALREADY_TAKEN) { return $rc }
   $self->waitforactive;
 }
+
 sub swapin_wait { 
   my $self = shift;
   $self->augment_func_code( 'swapexp', 'direction' => 'in',  'wait' => 1 );
   $self->waitforactive;
 }
+
 sub swapout_wait { 
   my $self = shift;
   $self->augment_func_code( 'swapexp', 'direction' => 'out',  'wait' => 1 );

testsuite/testswap/t/examples/parallel.t

 #! /usr/bin/perl
-use TestBed::TestExperiment;
+use TestBed::TestSuite;
 use RateLimitParallelExample;
 
-# run all the test methods in Example::Test
-TestBed::TestExperiment->runtests;
+# run all the tests in RateLimitParallelExample
+runtests;

testsuite/testswap/t/livetests/ensure_active.t

+#!/usr/bin/perl
+use SemiModern::Perl;
+use TestBed::TestSuite;
+use Test::More tests => 3;
+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');
+ok(!$e->ensure_active_ns($BasicNSs::TwoNodeLan), 'ensure active_start');
+ok(!$e->end);
+=cut
+
+sleep(5);
+system('./sc');
+
+ok(!$e->ensure_active_ns($BasicNSs::TwoNodeLan), 'ensure active_start');
+ok($e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'failed second start');
+ok(!$e->end);

testsuite/testswap/t/old/old.t

@@ -21,5 +21,5 @@ for (@who_knows) {
   my $ns = $Testbed::OldTestSuite::data->{$_}->{'nsfile'};
   say "Running " . $_;
   say $ns;
-  ok(launchpingkill(e($_), $ns), $_);
+  ok(e($_)->launchpingkill($ns), $_);
 }

testsuite/testswap/t/parallel/basic_topologies.t

+#! /usr/bin/perl
+use TestBed::TestSuite;
+use BasicTopologies;
+
+# run all the tests in RateLimitParallelExample
+runtests;

testsuite/testswap/t/topologies/link_up_link_down.t

 #!/usr/bin/perl
 use SemiModern::Perl;
-use TBConfig;
 use TestBed::TestSuite;
 use Test::More tests => 5;
 use Data::Dumper;

testsuite/testswap/t/topologies/simple_two_node_linktest.t

 #!/usr/bin/perl
 use SemiModern::Perl;
-use TBConfig;
 use TestBed::TestSuite;
 use Test::More tests => 1;
 use Data::Dumper;

testsuite/testswap/t/topologies/single_node.t

 #!/usr/bin/perl
 use SemiModern::Perl;
 use TestBed::TestSuite;
-use TestBed::TestSuite::Experiment;
 use Test::More tests => 1;
 use Data::Dumper;
 
@@ -15,4 +14,4 @@ set node1 [$ns node]
 $ns run
 NSEND
 
-ok(launchpingswapkill(e('tewkt'), $ns));
+ok(e('tewkt')->launchpingswapkill($ns));

testsuite/testswap/t/topologies/two_node_lan.t

 #!/usr/bin/perl
 use SemiModern::Perl;
 use TestBed::TestSuite;
-use TestBed::TestSuite::Experiment;
 use Test::More tests => 1;
 use Data::Dumper;
 
@@ -17,4 +16,4 @@ set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
 $ns run
 NSEND
 
-ok(launchpingswapkill(e('tewkt'), $ns));
+ok(e('tewkt')->launchpingswapkill($ns));

testsuite/testswap/tests/BasicNSs.pm

@@ -10,7 +10,42 @@ set ns [new Simulator]
 set node1 [$ns node]
 set node2 [$ns node]
 
+set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
+$ns run
+END
+
+our $TwoNodeLan5Mb = << 'END';
+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]
+$ns run
+END
+
+our $SingleNode = << 'END';
+source tb_compat.tcl
+
+set ns [new Simulator]
+
+set node1 [$ns node]
+
+$ns run
+END
+
+our $TwoNodeLanWithLink = << 'END';
+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
 END
 

testsuite/testswap/tests/BasicTopologies.pm

+#!/usr/bin/perl
+use SemiModern::Perl;
+use TestBed::TestSuite;
+use BasicNSs;
+use Test::More tests => 4;
+use Data::Dumper;
+
+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;

testsuite/testswap/tests/RateLimitParallelExample.pm

 #!/usr/bin/perl
 package RateLimitParallelExample;
-use TestBed::TestExperiment;
+use TestBed::TestSuite;
 use BasicNSs;
 use Test::More;
 
@@ -9,6 +9,6 @@ my $test_body = sub {
   ok(!($e->ping_test), 'Ping Test');
 };
 
-#$eid, $ns, $test_desc, $ns, $desc)
-teste("k$_", $BasicNSs::TwoNodeLan, $test_body, 1, "k$_ desc" ) for (1..2);
+rege("k$_", $BasicNSs::TwoNodeLan, $test_body, 1, "k$_ desc" ) for (1..2);
+
 1;