Commit 0467c247 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap bug fixes

parent 097a502a
......@@ -30,7 +30,7 @@ sub send { sendfd(shift->wr, shift); }
sub receivefd { my $fd = shift; my $r = fd_retrieve $fd; return $r->[0]; }
sub sendfd { my $fd = shift; store_fd [shift], $fd; $fd->flush; }
sub sendEnd { my $s = shift; $s->send(undef); $s->closeWr }
sub selectInit { my $s = shift; return [ $s->rd, $s->wr, 0, $s ]; }
sub selectInit { my $s = shift; return [ $s->rd, $s->wr, 0, $s, shift ]; }
sub closeRd { my $s = shift; my $fh = $s->rd; close($fh) if defined $fh; $s->rd(undef); }
sub closeWr { my $s = shift; my $fh = $s->wr; close($fh) if defined $fh; $s->wr(undef); }
sub close { my $s = shift; $s->closeRd; $s->closeWr; }
......@@ -139,6 +139,7 @@ use Mouse;
use IO::Select;
use Carp;
use Data::Dumper;
use POSIX ":sys_wait_h";
has 'workers' => ( is => 'rw', default => sub { [] });
has 'results' => ( is => 'rw', default => sub { TestBed::ForkFramework::Results->new; });
......@@ -148,8 +149,15 @@ has 'proc' => ( is => 'rw', isa => 'CodeRef' , required => 1 );
sub wait_for_all_children_to_exit {
my ($self) = @_;
waitpid( $_, 0 ) for @{ $self->workers };
my ($s) = @_;
waitpid( $_, 0 ) for @{ $s->workers };
}
sub reap_zombies {
my ($s) = @_;
while ((my $child = waitpid(-1, WNOHANG)) > 0) {
$s->workers( [ grep { !($_ == $child) } @{ $s->workers } ]);
}
}
sub workloop {
......@@ -162,6 +170,8 @@ sub workloop {
my $selectrc = $self->process_select; say "CALL SELECT" if $FFDEBUG;
my $schedulerc = $self->schedule;
$self->reap_zombies;
if ($selectrc || $schedulerc) { redo LOOP; }
}
$self->wait_for_all_children_to_exit;
......@@ -172,15 +182,51 @@ sub workloop {
use constant SELECT_HAS_HANDLES => 1;
use constant SELECT_NO_HANDLES => 0;
sub eval_report_error(&$) {
my ($p, $m) = @_;
eval { $p->(); };
if ($@) {
say $m;
sayd($@);
}
}
sub handle_select_error {
my ($s, $r) = @_;
my ($rh, $wh, $eof, $ch, $pid) = @$r;
say "SELECT HAS EXCEPTION";
sayd($r);
eval_report_error { $ch->sendEnd; } "sendEnd";
eval_report_error { $ch->close; } "chclose";
eval_report_error { $s->selector->remove($r); } "selectorremove";
eval_report_error { @{$r}[1,2] = (undef, 1); } "undefassign";
eval_report_error { kill 9, $pid; } "kill $pid";
say "DONE SELECT HAS EXCEPTION";
}
sub process_select {
my ($self) = @_;
my $selector = $self->selector;
if ($selector->count) {
my ($r, $rh, $wh, $eof, $ch, $pid);
eval {
for $r ($selector->has_exception(0)) {
$self->handle_select_error($r);
}
};
if ( my $error = $@ ) {
say "SELECT HAS EXCEPTION ERRORS";
sayd($error);
sayd($r);
say "DONE SELECT HAS EXCEPTION ERRORS";
}
eval {
for my $r ($selector->can_read($self->selecttimeout)) {
my ($rh, $wh, $eof, $ch) = @$r;
for $r ($selector->can_read($self->selecttimeout)) {
($rh, $wh, $eof, $ch, $pid) = @$r;
if (defined (my $itemResult = $ch->receive)) {
$self->handleItemResult($itemResult);
eval_report_error { $self->handleItemResult($itemResult); } 'ERROR $self->handleItemResult($itemResult);';
unless ( $eof ) {
if( my $jobid = $self->nextJob ) {
......@@ -201,10 +247,11 @@ sub process_select {
}
};
if ( my $error = $@ ) {
say "SELECT HAS ERRORS" if $FFDEBUG;
$_->[3]->sendEnd for $selector->handles;
$self->wait_for_all_children_to_exit;
die $error;
say "SELECT HAS ERRORS";
sayd($error);
$self->handle_select_error($r);
#$_->[3]->sendEnd for $selector->handles;
#$self->wait_for_all_children_to_exit;
}
say "SELECT_HAS_HANDLES" if $FFDEBUG;
return SELECT_HAS_HANDLES;
......@@ -221,7 +268,7 @@ sub fffork {
#Parent
$ch->parentAfterFork;
push @{ $self->workers }, $pid;
$self->selector->add($ch->selectInit);
$self->selector->add($ch->selectInit($pid));
$ch->send($workid);
}
else {
......
......@@ -37,7 +37,7 @@ sub build_e {
my $args;
if (@_ == 0) { $args = {}; }
if (@_ == 1) { $args = { 'eid' => shift }; }
if (@_ == 2) { $args = { 'pid' => shift, 'eid' => shift }; }
if (@_ == 2) { my $pid = shift; $args = { 'pid' => $pid, 'gid' => $pid, 'eid' => shift }; }
if (@_ == 3) { $args = { 'pid' => shift, 'gid' => shift, 'eid' => shift }; }
if (@_ > 3) { die 'Too many args to e'; }
TestBed::TestSuite::Experiment->new(%$args);
......@@ -126,11 +126,17 @@ waits until $timeout for @nodes to respond to ping
sub wait_for_nodes_to_activate {
my ($e, $timeout) = (shift, shift);
my $start = time;
for (@_) {
while ($e->node($_)->ping) {
sleep 1;
if ((time - $start) > $timeout) { die "Timeout before $_ activated"; }
my $done = 0;
while (!$done){
my $mapping = $e->info(aspect => 'mapping');
$done = 1;
for my $key (keys %$mapping){
if ($mapping->{$key}->{'eventstatus'} ne 'ISUP'){
$done = 0;
}
}
sleep 4;
if ((time - $start) > $timeout) { die "Timeout before $_ activated"; }
}
}
......@@ -154,6 +160,19 @@ sub traceroute_ok {
Tools::Network::traceroute_ok($src, @_);
}
sub gen_try($$){
my ($func, $times) = @_;
my $work = sub{
my $ex;
for (1..$times){
eval{$func->()};
$ex = $@;
unless ($ex){ return 1; }
}
die $ex;
};
return $work;
}
=item C<< $e->cartesian_ping() >>
......@@ -170,7 +189,7 @@ sub cartesian_ping{
for (@hosts){
my $dest_node = $_;
if ($src_node ne $dest_node){
push @work, sub{$e->ping_from_to($src_node, $dest_node)};
push @work, gen_try(sub{$e->ping_from_to($src_node, $dest_node)}, 5);
}
}
}
......@@ -293,7 +312,7 @@ uses tevc to bring down a link
=cut
sub linkup {
my ($e, $link) = @_;
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, "now $link up");
TestBed::Wrap::tevc::tevc($e, "now $link up");
}
=item C<< $e->linkdown($linkname) >>
......@@ -302,7 +321,7 @@ uses tevc to bring up a link
=cut
sub linkdown {
my ($e, $link) = @_;
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, "now $link down");
TestBed::Wrap::tevc::tevc($e, "now $link down");
}
=item C<< $e->pretty_list() >>
......
......@@ -35,7 +35,7 @@ uses tevc to control link
sub tevc {
my ($self, $cmd) = @_;
my $name = $self->name;
TestBed::Wrap::tevc::tevc($self->experiment->pid, $self->experiment->eid, "now $name $cmd");
TestBed::Wrap::tevc::tevc($self->experiment, "now $name $cmd");
}
=back
......
......@@ -35,7 +35,6 @@ sub get_free {
sub get_free_names {
my $x = shift;
sayd(keys %{$x->get_free(@_)});
keys %{$x->get_free(@_)};
}
......
......@@ -22,9 +22,12 @@ our $OPS_PATH = "/usr/testbed/bin:/sbin:/bin:/usr/sbin:/usr/bin:/usr/games:/usr/
sub ping {
my ($host) = @_;
my $p = Net::Ping->new('tcp', 2);
#system("ping -c 2 $host");
#my $rc = $?;
#returns 0 on success
#$rc;
#Net::Ping returns 0 on success
my $p = Net::Ping->new('tcp', 2);
!$p->ping($host);
}
......@@ -63,6 +66,14 @@ sub traceroute {
});
}
sub ping_from_to($$){
my ($from, $to) = @_;
Tools::TBSSH::cmdcheckoutput($from, "'sh -c \"PATH=/bin:/usr/sbin:/usr/sbin:/sbin ping -c 5 $to\"'",
sub {
return 1;
});
}
sub traceroute_ok {
my ($src,$dest,@path) = @_;
ok(traceroute(@_), "traceroute $src to $dest");
......
......@@ -60,8 +60,8 @@ sub cmdcheckoutput {
}
sub cmdsuccess {
my ($host, $cmd) = @_;
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[2] == 0; } );
my ($host, $cmd, $diemessage) = @_;
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[2] == 0; }, $diemessage);
}
sub cmdoutput {
......
......@@ -99,31 +99,31 @@ sub watchall {
eval {
if (@ARGV) {
$_ = shift;
if (/endall/) { end_all_experiments; }
elsif (/end/) { for(@ARGV) { e(split(/\./, $_))->end; }; }
if (/endall/) { end_all_experiments; }
elsif ($_ eq 'st') { e->pretty_list; }
elsif (/end/) { for(@ARGV) { e(split(/\./, $_))->end; }; }
elsif (/watchall/) { watchall; }
elsif (/rn/) { (say Dumper(Tools::Network::node_reboot($_))) for @ARGV; }
elsif (/rn/) { (say Dumper(Tools::Network::node_reboot($_))) for @ARGV; }
else {
my $e = e(shift);
if (/--help/) { usage; }
elsif (/end/) { $e->end_wait; }
elsif (/ping/ ) { $e->ping_test; }
elsif (/swapin/) { $e->swapin_wait; }
elsif (/swapout/) { $e->swapout_wait; }
elsif (/start/) { $e->startexp_ns_wait($ns); }
elsif (/tevc/) { $e->tevc(@ARGV); }
elsif (/linktest/) { $e->linktest; }
if (/--help/) { usage; }
elsif (/end/) { $e->end_wait; }
elsif (/ping/ ) { $e->ping_test; }
elsif (/swapin/) { $e->swapin_wait; }
elsif (/swapout/) { $e->swapout_wait; }
elsif (/start/) { $e->startexp_ns_wait($ns); }
elsif (/tevc/) { $e->tevc(@ARGV); }
elsif (/linktest/) { $e->linktest; }
elsif (/single_node_tests/) { $e->single_node_tests; }
elsif (/fqnn/) { say Dumper($e->fqnodenames) ;}
elsif (/ni/) { say Dumper($e->nodeinfo) ;}
elsif (/li/) { say Dumper($e->linkinfo) ;}
elsif (/im/) { say Dumper($e->info(aspect => 'mapping')) ;}
elsif (/ip/) { say Dumper($e->info(aspect => 'physical')) ;}
elsif (/it/) { say Dumper($e->info(aspect => 'traces')) ;}
elsif (/il/) { say Dumper($e->info(aspect => 'links')) ;}
elsif (/kk/) { say Dumper($e->node('node1')->reboot) ;}
elsif ($_ eq 'syncs') { prun( map { my $n = $_; sub { $e->node('node1')->ssh->cmdoutput('/usr/testbed/bin/emulab-sync'); } } (1..shift)); }
elsif (/watch/) { watch($e); }
elsif (/fqnn/) { say Dumper($e->fqnodenames) ;}
elsif (/ni/) { say Dumper($e->nodeinfo) ;}
elsif (/li/) { say Dumper($e->linkinfo) ;}
elsif (/im/) { say Dumper($e->info(aspect => 'mapping')) ;}
elsif (/ip/) { say Dumper($e->info(aspect => 'physical')) ;}
elsif (/it/) { say Dumper($e->info(aspect => 'traces')) ;}
elsif (/il/) { say Dumper($e->info(aspect => 'links')) ;}
elsif ($_ eq 'syncs') { prun( map { my $n = $_; sub { $e->node('node1')->ssh->cmdoutput('/usr/testbed/bin/emulab-sync'); } } (1..shift)); }
elsif (/watch/) { watch($e); }
elsif ($_ eq'ex') {
say $ARGV[0];
my $result = eval $ARGV[0];
......
......@@ -16,6 +16,7 @@ BEGIN {
use lib qw(lib tests);
use SemiModern::Perl;
use Data::Dumper;
use TBConfig;
use TestBed::Daemonize;
......@@ -104,7 +105,7 @@ TestBed TestSwap
TESTSUITES:
all - all framework tests
massive - all experiment tests
all - all framework tests
sanity - all framework utility and xmlrpc client modules test
lib - all framework utility tests
......@@ -137,7 +138,7 @@ if (@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 (/massive/) { runharness( @massive ); }
elsif (/massive/) { runharness( @massive ); }
elsif (/all/) { runharness( @all ); }
elsif (/sanity/) { runharness( @sanity ); }
elsif (/lib/) { runharness( @lib ); }
......
......@@ -514,7 +514,7 @@ set lan1 [$ns make-lan "$node1 $node2 $node3" 100Mb 0ms]
set link1 [$ns duplex-link $node4 $node1 100Mb 50ms DropTail]
set link2 [$ns duplex-link $node4 $node3 10Mb 100ms DropTail]
tb-set-lan-simplex-params $lan1 $node1 0ms 100Mb 0 100ms 10Mb 0.2
tb-set-lan-simplex-params $lan1 $node1 0ms 100Mb 0.02 100ms 10Mb 0.02
tb-set-link-simplex-params $link1 $node4 300ms 20Mb 0.4
$ns run
......
......@@ -6,8 +6,9 @@ use Test::More;
my $test_body = sub {
my $e = shift;
my $eid = $e->eid;
sleep(5);
ok(!($e->ping_test), 'Ping Test');
ok(!($e->ping_test), "$eid Ping Test");
sleep(5);
};
......
......@@ -8,7 +8,8 @@ use TestBed::ParallelRunner;
my $test_body = sub {
my $e = shift;
ok(!($e->ping_test), 'Ping Test');
my $eid = $e->eid;
ok(!($e->ping_test), "$eid Ping Test");
};
sub handleResult {
......
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