Commit 21c1a85c authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap Parallel Rate Limit Run

parent fa10282b
......@@ -20,6 +20,7 @@ requires 'Net::Ping' => '2.31';
requires 'Crypt::SSLeay' => '0.57';
requires 'Test::Class' => '0.31';
requires 'Test::Exception' => '';
requires 'Term::ReadKey' => '';
=pod
#too much effort to install for now
......
......@@ -5,16 +5,18 @@ REQUIREMENTS
ssh executable in path
INSTALLATION INSTRUCTIONS
perl ./localcpan.pl
perl ./localcpan.pl #this install dependencies in your homdir if you don't have root access to do it yourself
add export PERL5LIB=~/lib/perl5 to your environment
edit TBConfig.pm to point to your client certificate
copy TBConfig.pm.in to TBConfig.pm and edit it to point to your client certificate
add your emulab keys to a running ssh-agent
TO RUN Tests
make test
make t/old/old.t
make t/topologies/basic.t
TO SEE Tests available to run
./tbts
TO RUN Tests
./tbts test
./tbts t/old/old.t
./tbts t/topologies/basic.t
......@@ -29,8 +31,14 @@ TO RUN Tests
Module Install is a comprehensive installer.
It will:
download and install dependencies
install tbts in the filesystem to a PREFIX if desired
generate MAN pages for all the .pm files
etc
DEPRECATED Module::Install instructions
Module::Install instructions
cpan needs to be configured and functional
cpan Module::Install
perl Makefile.PL
......
......@@ -12,9 +12,10 @@ our $XMLRPC_VERSION = "0.1";
our $SSL_CLIENT_CERT = glob("~/.ssl/emulab.cert");
our $SSL_CLIENT_KEY = glob("~/.ssl/emulabkeyout.pem");
our $EMULAB_USER = get_emulab_user();
our $DEFAULT_PID = 'tbres';
our $DEFAULT_GID = '';
our $DEBUG_XML_CLIENT = $ENV{TBTS_DEBUG} || 0;
our $DEFAULT_PID = $ENV{'TBTS_PROJECT'} || 'tbres';
our $DEFAULT_GID = $ENV{'TBTS_GROUP'} || '';
our $DEBUG_XML_CLIENT = $ENV{'TBTS_DEBUG'} || 0;
our $CMDLINE_OPTIONS = {};
sub get_emulab_user {
my $cert = slurp($SSL_CLIENT_CERT);
......
......@@ -40,6 +40,11 @@ sub say {
croak $warning;
}
sub sayd {
use Data::Dumper;
say Dumper(@_);
}
if (1 || $] < 5.010) {
*IO::Handle::say = \&say if ! defined &IO::Handle::say;
}
......@@ -50,6 +55,7 @@ sub import {
if (1 || $] < 5.010) {
no strict 'refs';
*{caller() . '::say'} = \&say;
*{caller() . '::sayd'} = \&sayd;
use strict 'refs';
}
}
......
package TestBed::ForkFramework::Channel;
use SemiModern::Perl;
use Mouse;
use Data::Dumper;
use Storable qw(store_fd fd_retrieve);
has 'rd' => ( isa => 'Any', is => 'rw');
has 'wr' => ( isa => 'Any', is => 'rw');
sub build { TestBed::ForkFramework::Channel->new( 'rd' => shift, 'wr' => shift ); }
sub receive { receivefd(shift->rd); }
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 $self = shift; $self->send(undef); $self->closeWr }
sub sendError { shift->send( [ 'E', @_ ] ) }
sub sendResult { shift->send( [ 'R', @_ ] ) }
sub selectInit { my $self = shift; return [ $self->rd, $self->wr, 0, $self ]; }
sub sendWorkStatus {
my ($self, $error, $jobid, $result) = @_;
if ($error) { $self->sendError($error, $jobid); }
else { $self->sendResult($result, $jobid); }
}
sub closeRd { my $self = shift; my $fh = $self->rd; close($fh) if defined $fh; $self->rd(undef); }
sub closeWr { my $self = shift; my $fh = $self->wr; close($fh) if defined $fh; $self->wr(undef); }
sub close { my $self = shift; $self->closeRd; $self->closeWr; }
package TestBed::ForkFramework::BiPipe;
use SemiModern::Perl;
use Mouse;
use Carp;
use IO::Pipe;
has 'pipes' => ( isa => 'ArrayRef', is => 'rw');
sub build { TestBed::ForkFramework::BiPipe->new( 'pipes' => [ map IO::Pipe->new, 1 .. 2 ]); }
sub parentAfterFork { buildChannel(@{shift->pipes}); }
sub childAfterFork { buildChannel(reverse(@{shift->pipes})); }
sub buildChannel { my ($rd, $wr) = @_; $rd->reader; $wr->writer; TestBed::ForkFramework::Channel::build($rd, $wr); }
package TestBed::ForkFramework::Redir;
use SemiModern::Perl;
use Mouse;
use Carp;
use IO::Pipe;
has 'pipes' => ( isa => 'ArrayRef', is => 'rw');
sub build { TestBed::ForkFramework::Redir->new( 'pipes' => [ map IO::Pipe->new, 1 .. 3 ]); }
sub parentAfterFork { my $ps = shift->pipes; $ps->[0]->writer; $ps->[1]->reader; $ps->[2]->reader; return wantarray ? @{$ps} : $ps; }
sub childAfterFork {
my $s = shift;
my ($in, $out, $err) = @{$s->pipes};
$in->reader; $out->writer; $err->writer;
close STDIN;
close STDOUT;
close STDERR;
open(STDIN, "<&", $in ->fileno);
open(STDOUT, ">&", $out->fileno);
open(STDERR, ">&", $err->fileno);
$s->close
}
sub handles { my $hs = shift->pipes; return wantarray ? @{$hs} : $hs; }
sub close { my $hs = shift->pipes; map { close $_; } @$hs; }
sub in { shift->pipes->[0]; }
sub out { shift->pipes->[1]; }
sub err { shift->pipes->[2]; }
package TestBed::ForkFramework::Scheduler;
use SemiModern::Perl;
use Mouse;
use IO::Select;
use Carp;
use Data::Dumper;
has 'workers' => ( is => 'rw');
has 'results' => ( is => 'rw');
has 'errors' => ( is => 'rw');
has 'selector' => ( is => 'rw');
has 'items' => ( isa => 'ArrayRef' , is => 'rw');
has 'proc' => ( isa => 'CodeRef' , is => 'rw');
sub _gen_iterator {
my $items = shift;
my @ar = @$items;
my $pos = 0;
return sub {
return if $pos >= @ar;
my @r = ( $pos, $ar[$pos] );
$pos++;
return @r;
}
}
sub workloop {
my ($self) = @_;
LOOP: {
while( defined ( my $jobid = $self->spawnWorker ) ) {
$self->fffork($jobid);
}
if ($self->selectloop) {
redo LOOP;
}
}
my @results = (scalar @{$self->errors}, $self->results, $self->errors);
return wantarray ? @results : \@results;
}
sub selectloop {
my ($self) = @_;
my $selector = $self->selector;
if ($selector->count) {
eval {
for my $r ($selector->can_read) {
my ($rh, $wh, $eof, $ch) = @$r;
if (defined (my $result = $ch->receive)) {
my $type = shift @$result;
if ( $type eq 'R' ) { push @{ $self->results }, $result }
elsif ( $type eq 'E' ) { push @{ $self->errors }, $result }
else { die "Bad result type: $type"; }
$self->jobDone($result->[1]);
unless ( $eof ) {
if( my $jobid = $self->nextJob ) { $ch->send($jobid); }
else {
$ch->sendEnd;
@{$r}[1,2] = (undef, 1);
}
}
}
else {
$selector->remove($r);
$ch->close;
}
}
};
if ( my $error = $@ ) {
$_->[3]->sendEnd for $selector->handles;
waitpid( $_, 0 ) for @{ $self->workers };
die $error;
}
return 1;
}
return 0;
}
sub fffork {
my ($self, $workid) = @_;
my $bipipe = TestBed::ForkFramework::BiPipe::build;
if ( my $pid = fork ) {
#Parent
my $ch = $bipipe->parentAfterFork;
push @{ $self->workers }, $pid;
$self->selector->add($ch->selectInit);
$ch->send($workid);
}
else {
#Child
my $ch = $bipipe->childAfterFork;
use POSIX '_exit';
eval q{END { _exit 0 }};
while ( defined( my $itemid = $ch->receive )) {
my $result = eval { $self->doItem($itemid); };
my $error = $@;
$ch->sendWorkStatus($error, $itemid, $result);
}
$ch->sendEnd;
$ch->close;
CORE::exit;
}
}
sub redir_std_fork {
my ($self, $pworker, $worker) = @_;
my $redir = TestBed::ForkFramework::Redir::build;
if ( my $pid = fork ) {
#Parent
my $handles = $redir->parentAfterFork;
$pworker->(@$handles, $pid);
waitpid($pid, 0);
}
else {
#Child
$redir->childAfterFork;
use POSIX '_exit';
eval q{END { _exit 0 }};
$worker->();
CORE::exit;
}
}
package TestBed::ForkFramework::MaxWorkersScheduler;
use SemiModern::Perl;
use Mouse;
has 'maxworkers' => ( isa => 'Int' , is => 'rw');
has 'pos' => ( isa => 'Int' , is => 'rw');
has 'currworkers' => ( isa => 'Int' , is => 'rw');
extends 'TestBed::ForkFramework::Scheduler';
sub work {
my ($max_workers, $proc, $items) = @_;
my $s = TestBed::ForkFramework::MaxWorkersScheduler->new(
'maxworkers' => $max_workers,
'currworkers' => 0,
'workers' => [],
'results' => [],
'items' => $items,
'errors' => [],
'proc' => $proc,
'pos' => 0,
'selector' => IO::Select->new);
$s->workloop;
}
sub spawnWorker {
my $s = shift;
return if ($s->currworkers >= $s->maxworkers);
$s->{'currworkers'}++;
$s->nextJob;
}
sub nextJob {
my $s = shift;
my $pos = $s->pos;
return if ($pos >= scalar @{ $s->items });
$s->{'pos'}++;
$pos;
}
sub doItem { my ($s, $itemid) = @_; $s->proc->($s->items->[$itemid]); }
sub jobDone { }
package TestBed::ForkFramework::RateScheduler;
use SemiModern::Perl;
use Data::Dumper;
use Tools;
use Mouse;
extends 'TestBed::ForkFramework::Scheduler';
has 'maxnodes' => ( isa => 'Int' , is => 'rw');
has 'currnodes' => ( isa => 'Int' , is => 'rw');
has 'schedule' => ( isa => 'ArrayRef', is => 'rw');
has 'weight' => ( isa => 'ArrayRef', is => 'rw');
sub work {
my ($max_nodes, $proc, $weight, $items) = @_;
my $s = TestBed::ForkFramework::RateScheduler->new(
'maxnodes' => $max_nodes,
'currnodes' => 0,
'workers' => [],
'results' => [],
'items' => $items,
'errors' => [],
'proc' => $proc,
'schedule' => $weight,
'weight' => [ map { $_->[0] } (sort { $a->[1] <=> $b->[1] } @$weight) ],
'selector' => IO::Select->new);
#sayperl($s->schedule);
#sayperl($s->weight);
$s->workloop;
}
sub find_largest_item {
my ($s, $max_size) = @_;
my $found = undef;
#find largest item that is small enough
for (@{ $s->schedule }) {
$found = $_ if $_->[0] <= $max_size;
}
#remove found from schedule
if (defined $found) {
$s->schedule( [ grep { !($_->[1] == $found->[1]) } @{ $s->schedule} ]);
}
return $found;
}
sub spawnWorker { shift->nextJob; }
sub nextJob {
my $s = shift;
my $max_size = $s->maxnodes - $s->currnodes;
my $tuple = $s->find_largest_item($max_size);
if ($tuple) {
my ($e_node_size, $eindex) = @$tuple;
#say sprintf("found %s size %s max_size $max_size currnodes %s maxnodes %s", $eindex, $e_node_size, $s->currnodes, $s->maxnodes);
$s->{'currnodes'} += $e_node_size;
return $eindex;
}
else {
return;
}
}
sub doItem { my ($s, $itemid) = @_; $s->proc->($s->items->[$itemid]); }
sub jobDone { my ($s, $itemid) = @_; $s->{'currnodes'} -= $s->weight->[$itemid]; }
1;
#!/usr/bin/perl
package TAP::Parser::Iterator::StdOutErr;
use strict;
use warnings;
use vars qw($VERSION @ISA);
use TAP::Parser::Iterator::Process ();
use Config;
use IO::Select;
@ISA = 'TAP::Parser::Iterator::Process';
sub _initialize {
my ( $self, $args ) = @_;
shift;
$self->{out} = shift || die "Need out";
$self->{err} = shift || die "Need err";
$self->{sel} = IO::Select->new( $self->{out}, $self->{err} );
$self->{pid} = shift || die "Need pid";
$self->{exit} = undef;
$self->{chunk_size} = 65536;
return $self;
}
package TestBed::TestExperiment;
use SemiModern::Perl;
use TestBed::TestExperiment::Test;
use TestBed::ForkFramework;
use Data::Dumper;
my $ExperimentTests = [];
......@@ -9,18 +38,94 @@ 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);
teste($pid, $eid, $ns, $sub, $test_count, $desc);
teste($pid, $gid, $eid, $ns, $sub, $test_count, $desc);
END
sub teste {
push @$ExperimentTests, TestBed::TestExperiment::Test::tn('', '', @_);
}
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 runtests {
for (@$ExperimentTests) {
$_->prep();
#prep step
# say "Prepping";
my $result = TestBed::ForkFramework::MaxWorkersScheduler::work(4, sub {
#return { 'maximum_nodes' => 3};
$_[0]->prep
}, $ExperimentTests);
if ($result->[0]) {
sayd($result->[2]);
die 'TestBed::TestExperiment::runtests died during test prep';
}
#create schedule step
my @weighted_experiements;
for (@{$result->[1]}) {
push @weighted_experiements, [ $_->[0]->{'maximum_nodes'}, $_->[1] ];
}
@weighted_experiements = sort { $a->[0] <=> $b->[0] } @weighted_experiements;
#count tests step
my $test_count = 0;
map { $test_count += $_->test_count } @$ExperimentTests;
# say "Running";
reset_test_builder($test_count, no_numbers => 1);
$result = TestBed::ForkFramework::RateScheduler::work(20, \&tap_wrapper, \@weighted_experiements, $ExperimentTests);
use Test::Builder;
my $b = Test::Builder->new;
$b->current_test($test_count);
#sayd($result);
return;
}
sub reset_test_builder {
my ($test_count, %options) = @_;
use Test::Builder;
my $b = Test::Builder->new;
$b->reset;
$b->use_numbers(0) if $options{no_numbers};
if ($test_count) { $b->expected_tests($test_count); }
else { $b->no_plan; }
}
use Carp;
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
our $SUBTESTS = 0;
sub tap_wrapper {
my ($te) = @_;
for (@$ExperimentTests) {
$_->run();
if ($SUBTESTS) {
TestBed::ForkFramework::Scheduler->redir_std_fork( sub {
my ($in, $out, $err, $pid) = @_;
#while(<$out>) { print "K2" . $_; }
use TAP::Parser;
my $tapp = TAP::Parser->new({'stream' => TAP::Parser::Iterator::StdOutErr->new($out, $err, $pid)});
while ( defined( my $result = $tapp->next ) ) {
#sayd($result);
}
ok(1, $te->desc) if $SUBTESTS && $tapp;
},
sub {
reset_test_builder($te->test_count) if $SUBTESTS;
$te->run_ensure_kill;
});
}
else {
$te->run_ensure_kill;
}
return 0;
}
1;
......@@ -9,37 +9,53 @@ 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');
sub tn {
my ($pid, $gid, $eid, $desc, $ns, $sub) = @_;
my ($pid, $gid, $eid, $ns, $sub, $test_count, $desc) = @_;
my $e = TestBed::TestSuite::Experiment->new(
'pid' => $pid,
'gid' => $gid,
'eid' => $eid,
'ns' => $ns);
TestBed::TestExperiment::Test->new(
'eid' => $eid);
return TestBed::TestExperiment::Test->new(
'e' => $e,
'ns' => $ns,
'desc' => $desc,
'proc' => $sub );
'proc' => $sub,
'test_count' => $test_count );
}
sub prep {
my $self = shift;
my $a = $self->e->create_and_get_metadata($self->ns);
#say Dumper($a);
$a;
$self->e->create_and_get_metadata($self->ns);
}
sub run {
my $self = shift;
my $e = $self->e;
my $e = $self->e;
my $proc = $self->proc;
$proc->($e);
$e->swapin_wait;
$proc->($e);
}
sub run_ensure_kill {
my $self = shift;
eval {
$self->run;
};
my $run_exception = $@;
eval {
$self->kill;
};
my $kill_exception = $@;
die $run_exception if $run_exception;
die $kill_exception if $kill_exception;
return 1;
}
sub kill {
shift->e->end;
my $self = shift;
$self->e->end;
}
1;
......@@ -11,7 +11,7 @@ has 'pid' => ( isa => 'Str', is => 'rw');
has 'gid' => ( isa => 'Str', is => 'rw');
has 'eid' => ( isa => 'Str', is => 'rw');
#autoloaded/autogenerated/method_missings/etc batchexp swapexp endexp waitforactive getlist expinfo metadata
#autoloaded/autogenerated/method_missings/etc batchexp swapexp endexp waitforactive getlist expinfo metadata modify
sub args {
my $self = shift;
......@@ -28,6 +28,7 @@ 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 swapin { shift->augment_func_code( 'swapexp', 'direction' => 'in' ); }
sub swapout { shift->augment_func_code( 'swapexp', 'direction' => 'out' ); }
sub end { shift->augment_func_code( 'endexp' ); }
......
#!/usr/bin/perl
package TestBed::XMLRPC::Client::Node;
use SemiModern::Perl;
use Mouse;
use Data::Dumper;
extends 'TestBed::XMLRPC::Client';
#autoloaded/autogenerated/method_missings/etc available getlist typeinfo
=head1 NAME
TestBed::XMLRPC::Client::Node
=over 4
=item C<available>
returns a list of available nodes
=item C<getlist>
returns a list of available nodes
=back
=cut
sub filter_hash {
my ($hash, $proc) = @_;
my %new_hash;
while (my ($k, $v) = each %$hash) {
if ( $proc->($k, $v) ) {
$new_hash{$k} = $v;
}
}
\%new_hash;
}
sub _free {
my ($k, $v) = @_;
$v->{'free'} == 1;
}
sub get_free {
filter_hash(
shift->augment_func( 'getlist', @_ ),
\&_free);
}
sub get_free_names {
keys %{shift->get_free(@_)};
}
1;
......@@ -3,7 +3,7 @@ package TestBed::XMLRPC::Client::Pretty;
use SemiModern::Perl;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(pretty_listexp);
our @EXPORT = qw(pretty_listexp experiments_hash_to_list);
use Data::Dumper;
=head1 NAME
......@@ -15,19 +15,35 @@ TestBed::XMLRPC::Client::Pretty;
=item C<pretty_listexp>
pretty prints the XMLRPC response from listexp
=cut
sub pretty_listexp {
for my $ed (experiments_hash_to_list(@_)) {
my ($pid, $gid, $eid,) = @{ $ed->[0] };
my $status = $ed->[1]->{'state'};
say "$pid :: $gid :: $eid $status";
}
}
sub experiments_hash_to_list {
my ($h) = @_;