Commit 68670679 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap dpge* cleanup and start of rate-limit parallel run

parent 1229a9a6
......@@ -7,7 +7,7 @@ perl_version '5.008';
author 'Kevin Tew <tewk@flux.utah.edu>';
version '0.01';
requires 'Mouse' => '';
requires 'Mouse' => '0.22';
requires 'RPC::XML::Client' => '1.24';
requires 'RPC::XML' => '1.41';
requires 'Test::More' => '0.86';
......@@ -17,7 +17,9 @@ requires 'Crypt::X509' => '0.32';
requires 'Log::Log4perl' => '1.20';
requires 'Data::UUID' => '1.149';
requires 'Net::Ping' => '2.31';
requires 'Crypt::SSLeay' => '';
requires 'Crypt::SSLeay' => '0.57';
requires 'Test::Class' => '0.31';
requires 'Test::Exception' => '';
=pod
#too much effort to install for now
......
#!/usr/bin/perl
package TestBed::TestExperiment;
use SemiModern::Perl;
use TestBed::TestExperiment::Test;
my $ExperimentTests = [];
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(teste runtests);
sub teste {
push @$ExperimentTests, TestBed::TestExperiment::Test::tn('', '', @_);
}
sub runtests {
for (@$ExperimentTests) {
$_->prep();
}
for (@$ExperimentTests) {
$_->run();
}
}
1;
#!/usr/bin/perl
package TestBed::TestExperiment::Test;
use SemiModern::Perl;
use TestBed::TestSuite::Experiment;
use Mouse;
use Data::Dumper;
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');
sub tn {
my ($pid, $gid, $eid, $desc, $ns, $sub) = @_;
my $e = TestBed::TestSuite::Experiment->new(
'pid' => $pid,
'gid' => $gid,
'eid' => $eid,
'ns' => $ns);
TestBed::TestExperiment::Test->new(
'e' => $e,
'ns' => $ns,
'desc' => $desc,
'proc' => $sub );
}
sub prep {
my $self = shift;
my $a = $self->e->create_and_get_metadata($self->ns);
#say Dumper($a);
$a;
}
sub run {
my $self = shift;
my $e = $self->e;
my $proc = $self->proc;
$proc->($e);
}
sub kill {
shift->e->end;
}
1;
......@@ -7,16 +7,16 @@ use Tools;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(ee e pge dpe dpge CartProd CartProdRunner concretize defaults override);
sub ee { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid' => shift, 'eid' => shift) }
sub pge { TestBed::TestSuite::Experiment->new('pid' => shift, 'gid' => shift, 'eid' => shift) }
sub dpe { TestBed::TestSuite::Experiment->new('pid' => $TBConfig::DEFAULT_PID, 'eid' => shift) }
sub dpge { TestBed::TestSuite::Experiment->new(
'pid' => $TBConfig::DEFAULT_PID,
'gid' => ($TBConfig::DEFAULT_GID || $TBConfig::DEFAULT_PID),
'eid' => shift);
our @EXPORT = qw(e dpge CartProd CartProdRunner concretize defaults override);
sub e { TestBed::TestSuite::Experiment->new(_build_e_from_positionals(@_)); }
sub _build_e_from_positionals {
if (@_ == 0) { return {}; }
if (@_ == 1) { return { 'eid' => shift }; }
if (@_ == 2) { return { 'pid' => shift, 'eid' => shift }; }
if (@_ == 3) { return { 'pid' => shift, 'gid' => shift, 'eid' => shift }; }
if (@_ > 3) { die 'Too many args to e'; }
}
sub CartProd {
......@@ -92,25 +92,20 @@ TestBed::TestSuite
=over 4
=item C<ep()>
=item C<e()>
creates a new empty experiment, for calling experiement "class methods" on
=item C<e($pid, $eid)>
creates a new experiment with pid and eid
=item C<e($eid)>
=item C<pge($pid, $gid, $eid)>
creates a new experiment with eid and uses the default pid and gid in TBConfig
creates a new experiment with pid, gid, and eid
=item C<dpe($eid)>
=item C<e($pid, $eid)>
new experiement takes one arg a eid and uses the default pid in TBConfig
creates a new experiment with pid and eid and uses the default gid in TBConfig
=item C<dpge($eid)>
=item C<e($pid, $gid, $eid)>
new experiement takes one arg a eid and uses the default pid and gid in TBConfig
creates a new experiment with pid, gid, and eid
=item C<CartProd($hashref)> Cartesian Product Runner
......
......@@ -11,6 +11,9 @@ 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);
......
......@@ -5,21 +5,17 @@ use TestBed::XMLRPC::Client::Pretty;
use Data::Dumper;
require Exporter;
our @ISA = qw(Test::More);
our @EXPORT =qw(e ep echo newexp batchexp list list_brief list_full
our @EXPORT =qw(e echo list list_brief list_full
plistexps);
use TestBed::TestSuite;
use TestBed::TestSuite::Experiment;
use Test::More;
sub echo { ee()->echo(@_); }
sub batchexp { my $e = e(shift, shift); $e->batchexp_ns(@_); $e }
sub batchexp_wait { my $e = e(shift, shift); $e->batchexp_ns_wait(@_); $e }
sub newexp { batchexp(@_, batch => 0); }
sub newexp_wait { batchexp_wait(@_, batch => 0); }
sub list { ee()->getlist; }
sub list_brief { ee()->getlist_brief; }
sub list_full { ee()->getlist_full; }
sub echo { e()->echo(@_); }
sub list { e()->getlist; }
sub list_brief { e()->getlist_brief; }
sub list_full { e()->getlist_full; }
sub plistexps { pretty_listexp(list_full); }
=head1 NAME
......
......@@ -9,7 +9,7 @@ use Data::Dumper;
use TestBed::Wrap::tevc;
has 'name' => ( isa => 'Str', is => 'rw');
has 'experiment' => ( is => 'rw');
has 'experiment' => ( isa => 'TestBed::TestSuite::Experiment', is => 'rw');
=head1 NAME
TestBed::TestSuite::Link
......
......@@ -8,7 +8,7 @@ use Tools::TBSSH;
use Data::Dumper;
has 'name' => ( isa => 'Str', is => 'rw');
has 'experiment' => ( is => 'rw');
has 'experiment' => ( isa => 'TestBed::TestSuite::Experiment', is => 'rw');
=head1 NAME
TestBed::TestSuite::Node
......
......@@ -11,12 +11,15 @@ 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
#autoloaded/autogenerated/method_missings/etc batchexp swapexp endexp waitforactive getlist expinfo metadata
sub args {
my $self = shift;
my $args = { 'pid' => $self->pid, 'eid' => $self->eid };
my $gid = $self->gid;
my $pid = $self->pid || $TBConfig::DEFAULT_PID;
my $gid = $self->gid || $TBConfig::DEFAULT_GID || $TBConfig::DEFAULT_PID;
my $eid = $self->eid; # || gen_random_eid;
my $args = { 'pid' => $pid, 'eid' => $eid };
$args->{'gid'} = $gid if $gid;
return { %$args, @_ };
}
......@@ -42,6 +45,12 @@ sub 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->metadata;
}
sub batchexp_ns_wait {
my $self = shift;
$self->batchexp_ns(@_);
......
......@@ -39,7 +39,9 @@ sub install_deps_from_cpan {
Data::UUID
IPC::Run3
Crypt::SSLeay
Test::Exception
);
# Test::Class
#Crypt::SSLeay # required for SSL
#Data::UUID requires user input
#Net::Ping #tests fail, default installed version 2.31 is good enough
......
......@@ -39,12 +39,11 @@ ShortCut
END
}
my $pid = $TBConfig::DEFAULT_PID;
if (@ARGV) {
$_ = shift;
my $eid = shift;
my $e = e($pid, $eid);
if (/end/) { e($_)->end() for(@ARGV); }
my $e = e(shift);
if (/--help/) { usage; }
elsif (/end/) { $e->end(); }
elsif (/ping/ ) { $e->ping_test; }
......
#!/usr/bin/perl
use TestBed::TestSuite;
use VNodeTest;
my $config = {
'OS' => [qw( AOS BOS COS )],
'HARDWARE' => [qw( AHW BHW CHW )],
'LINKTYPE' => [qw( ALT BLT CLT )],
};
CartProdRunner(\&VNodeTest::VNodeTest, $config);
......@@ -2,7 +2,8 @@
use SemiModern::Perl;
use TestBed::TestSuite;
use Data::Dumper;
use Test::More tests => 5;
use Test::Exception;
use Test::More tests => 10;
my $a = {
'a' => [qw(a1 a2 a3)],
......@@ -66,3 +67,9 @@ ok(array_of_hash_equals( $expected2, \@result2), 'CartProd($config, $filter_and_
ok(hash_equals( defaults({ 'a' => 'B' }, 'a' => 'A', b => 'B'), { 'a' => 'B', 'b' => 'B' } ), 'defaults1');
ok(hash_equals( override({ 'a' => 'B' }, 'a' => 'A', b => 'B'), { 'a' => 'A', 'b' => 'B' } ), 'override1');
is_deeply(TestBed::TestSuite::_build_e_from_positionals(), {}, 'e()');
is_deeply(TestBed::TestSuite::_build_e_from_positionals('e1'), { 'eid' => 'e1' }, 'e($eid)');
is_deeply(TestBed::TestSuite::_build_e_from_positionals('p1', 'e1'), { 'pid' => 'p1', 'eid' => 'e1' }, 'e($pid, $eid)');
is_deeply(TestBed::TestSuite::_build_e_from_positionals('p1', 'g1', 'e1'), { 'pid' => 'p1', 'gid' => 'g1', 'eid' => 'e1' }, 'e($pid, $gid, $eid)');
dies_ok( sub { TestBed::TestSuite::_build_e_from_positionals(1, 2, 3, 4) }, 'e(1,2,3,4) dies');
......@@ -21,7 +21,7 @@ $ns run
NSEND
my $eid='linkupdown';
my $e = dpe($eid);
my $e = e($eid);
$e->startrunkill($ns,
sub {
......
......@@ -18,7 +18,7 @@ $ns run
NSEND
my $eid='simple';
my $e = dpge($eid);
my $e = e($eid);
$e->startrunkill($ns,
sub {
my ($e) = @_;
......
#!/usr/bin/perl
use SemiModern::Perl;
package BasicNSs;
our $TwoNodeLan = << '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
1;
#!/usr/bin/perl
package T2;
use TestBed::TestExperiment;
use BasicNSs;
use Test::More tests => 4;
my $sub = sub {
ok(1, 'I\'m alive');
};
teste("k$_", "k$_ desc", $BasicNSs::TwoNodeLan, $sub) for (1..4);
1;
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