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