Commit a6337bb1 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap reduce use of CPAN

parent 2576cf19
......@@ -3,17 +3,11 @@ use inc::Module::Install;
# Define metadata
name 'tbts';
all_from 'lib/TestBed/XMLRPC/Client.pm';
perl_version '5.008';
author 'Kevin Tew <tewk@flux.utah.edu>';
version '0.01';
# Specific dependencies
requires 'bignum' => '0.23';
requires 'Math::BigRat' => '0.22';
requires 'Crypt::SSLeay' => '';
requires 'Test::Exception' => '';
requires 'Sub::Uplevel' => '';
#requires 'Test::Exception' => '0.27';
requires 'Mouse' => '';
requires 'RPC::XML::Client' => '1.24';
requires 'RPC::XML' => '1.41';
......@@ -21,18 +15,22 @@ requires 'Sys::Hostname' => '1.11';
requires 'Test::More' => '0.86';
requires 'Time::Local' => '1.1901';
requires 'TAP::Harness' => '3.16';
requires 'Math::BigInt::GMP' => '';
requires 'Math::BigInt::Pari' => '';
requires 'Net::SSH::Perl' => '1.34';
requires 'Net::SFTP' => '0.10';
requires 'Crypt::X509' => '0.32';
requires 'Log::Log4perl' => '1.20';
requires 'Log::Dispatch::File' => '1.22';
requires 'Data::UUID' => '';
requires 'Net::Ping' => '';
requires 'Data::UUID' => '1.149';
requires 'Net::Ping' => '2.31';
requires 'Crypt::SSLeay' => '';
test_requires 'Test::More' => '0.42';
no_index 'directory' => 'demos';
=pod
#too much effort to install for now
#required for fast SSH and Crypt::DH
requires 'bignum' => '0.22';
requires 'Math::BigRat' => '0.22';
requires 'Math::BigInt::GMP' => '1.24';
requires 'Net::SSH::Perl' => '1.34';
requires 'Net::SFTP' => '0.10';
=cut
auto_install();
......
......@@ -4,7 +4,7 @@ REQUIREMENTS
TBConfig.pm set up correctly
INSTALLATION INSTRUCTIONS
cpan HAS to be configured and functional
cpan needs to be configured and functional
cpan Module::Install
perl Makefile.PL
make
......
DOC
POD
DOCS TODO
buildup, teardown - Test::Class
TODO
VERBOSENESS
buildup, teardown using Test::Class
create BSD virtual machine for testing
Add basic image-test parameterization examples
EXAMPLES
traffic generation`
convert more old tests
general result code handling framework
possibly collapse TestBed/XMLRPC/Client/* and TestBed/TestSuite
possibly collapse tbts and t/harness
Add parameterization examples
EXAMPLES
traffic generation`
convert more old tests
general result code handling
better parallel support
EXPAND CURRENT IMPLEMENTATION
event subsystem
better parallel support (custom test harness) - functionality like image-test
LATER
Client.pm duplicate code elimination - Maybe this would make the code too unreadable
TestSuite::Experiment::Macros should be a monadic language like JQuery
test groupings
event system
DONE
POD function documentation
better general result code handling (ping_test single_node_test)
testswap is a object orient / declarative test framework for the emulab testbed.
LIBRARY CODE
./lib/TestBed/TestSuite/
Core framework modules that the testwriter should use
......@@ -16,10 +15,16 @@ command line utility wrappers
utility modules and functions used by the framework
TESTS
./t/topologies/
./t/topologies/*.t
topology swap tests
./t/*.t
./t/xmlrpc/*.t
xmlrpc tests
./t/lib
testswap framework tests
Exporter is used to export symbols form the defining modules namespace into the module that is using the namespace.
Mouse is a lightweight version of the Moose object system for Perl.
Moose is the best practice way of doing object orientation in Perl and is modeled after Perl6's OO system.
Moose is used as the OO basis of testswap
......@@ -9,6 +9,20 @@ use IO::Handle;
use Scalar::Util 'openhandle';
use Carp;
=head1 NAME
ensures perl version >= 5.008
=over 4
=item say
implements a perl5.10 like say for perl < 5.10
=back
=cut
sub say {
my $currfh = select();
my $handle;
......
......@@ -8,6 +8,28 @@ require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(e ep dpe);
=head1 NAME
TestBed::TestSuite
=over 4
=item C<ep()>
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<dpe($eid)>
new experiement takes one arg a eid and uses the default pid in TBConfig
=back
=cut
sub ep { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid'=> shift, 'eid' => shift) }
sub dpe { TestBed::TestSuite::Experiment->new('pid'=> $TBConfig::DEFAULT_PID, 'eid' => shift) }
......
#!/usr/bin/perl
use SemiModern::Perl;
package TestBed::TestSuite::Experiment;
use SemiModern::Perl;
use Mouse;
use TestBed::XMLRPC::Client::Experiment;
use TestBed::Wrap::tevc;
......@@ -13,46 +12,77 @@ use TestBed::TestSuite::Node;
extends 'Exporter', 'TestBed::XMLRPC::Client::Experiment';
require Exporter;
our @EXPORT;
push @EXPORT, qw(e ep launchpingkill launchpingswapkill);
push @EXPORT, qw(launchpingkill launchpingswapkill);
=head1 NAME
TestBed::TestSuite::Experiment
sub ep { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid'=> shift, 'eid' => shift) }
framwork class for starting and testing experiments
=over 4
=item C<nodes()>
returns a list of node objects representing each node in the experiment
=cut
sub nodes {
my ($e) = @_;
my @node_instances = map { TestBed::TestSuite::Node->new('experiment' => $e, 'name'=>$_); } @{$e->nodeinfo()};
\@node_instances;
}
=item C<ping_test()>
runs a ping test across all nodes
=cut
sub ping_test {
my ($e) = @_;
for (@{$e->nodes}) {
$_->ping();
die $_->name . "failed ping" unless $_->ping();
}
}
=item C<single_node_tests()>
runs a single_node_tests test across all nodes
=cut
sub single_node_tests {
my ($e) = @_;
for (@{$e->nodes}) {
$_->single_node_tests();
die $_->name . "failed single_node_tests" unless $_->single_node_tests();
}
}
=item C<linktest>
runs a linktest on the experiment
=cut
sub linktest {
my ($e) = @_;
TestBed::Wrap::linktest::linktest($e->pid, $e->eid);
}
=item C<tevc>
runs tevc on ops for this experiment.
takes an argument string such as "now link1 down"
=cut
sub tevc {
my ($e) = shift;
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, @_);
}
=item C<trytest { code ... } $e>
catches exceptions while a test is running and cleans up the experiment
=cut
sub trytest(&$) {
eval {$_[0]->()};
my ($sub, $e) = @_;
eval {$sub->()};
if ($@) {
say $@;
$_[1]->end;
$e->end;
0;
}
else {
......@@ -60,17 +90,26 @@ sub trytest(&$) {
}
}
=item C<< $e->startrunkill($ns_contents, $worker_sub) >>
starts an experiment given a $ns file and a $worker
call the $worker passing in the experiment $e
ends the experiemnt
=cut
sub startrunkill {
my ($e, $ns, $worker) = @_;
my $eid = $e->eid;
trytest {
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$worker->($e) && die "worker function failed";
$worker->($e) || die "worker function failed";
$e->end && die "exp end $eid failed";
} $e;
}
#class methods
=item C<launchpingkill($pid, $eid, $ns)>
class method that starts an experiment, runs a ping_test, and ends the experiment
=cut
sub launchpingkill {
my ($pid, $eid, $ns) = @_;
my $e = e($pid, $eid);
......@@ -81,10 +120,16 @@ sub launchpingkill {
} $e;
}
=item C<launchpingkill($pid, $eid, $ns)>
class 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
sub launchpingswapkill {
my ($pid, $eid, $ns) = @_;
my $e = e($pid, $eid);
trytest {
trytest {
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$e->ping_test && die "connectivity test $eid failed";
$e->swapout_wait && die "swap out $eid failed";
......@@ -94,4 +139,8 @@ sub launchpingswapkill {
} $e;
}
=back
=cut
1;
#!/usr/bin/perl
use SemiModern::Perl;
package TestBed::TestSuite::Experiment::Macros;
use SemiModern::Perl;
use TestBed::XMLRPC::Client::Pretty;
use Data::Dumper;
require Exporter;
......@@ -9,6 +8,7 @@ our @ISA = qw(Test::More);
our @EXPORT =qw(e ep echo newexp batchexp list list_brief list_full
plistexps);
use TestBed::TestSuite;
use TestBed::TestSuite::Experiment;
use Test::More;
......@@ -22,4 +22,14 @@ sub list_brief { ep()->getlist_brief; }
sub list_full { ep()->getlist_full; }
sub plistexps { pretty_listexp(list_full); }
=head1 NAME
TestBed::TestSuite::Experiment::Macros
B<EXPERIMENTAL>
provides some common used class methods as global functions in the current package namespace
=cut
1;
#!/usr/bin/perl
package TestBed::TestSuite::Node;
use SemiModern::Perl;
use Mouse;
......@@ -11,11 +10,24 @@ use Data::Dumper;
has 'name' => ( isa => 'Str', is => 'rw');
has 'experiment' => ( is => 'rw');
=head1 NAME
TestBed::TestSuite::Node
=over 4
=item C<< $n->ping_test >>
=cut
sub ping_test {
my ($self) = @_;
ping($self->name);
}
=item C<< $n->single_node_tests >>
executes hostname, sudo ls, mount via ssh on the remote node
=cut
sub single_node_tests {
my ($self) = @_;
my $ssh = $self->ssh();
......@@ -24,9 +36,17 @@ sub single_node_tests {
$ssh->cmdsuccess("mount");
}
=item C<$n->ssh>
returns a $ssh connection to the node
=cut
sub ssh {
my $self = shift;
my $ssh = Tools::TBSSH::ssh($self->name, $TBConfig::EMULAB_USER);
my $ssh = Tools::TBSSH::instance($self->name);
}
=back
=cut
1;
#!/usr/bin/perl
package TestBed::Wrap::linktest;
use SemiModern::Perl;
use TBConfig;
......@@ -8,6 +7,7 @@ use Tools;
use Tools::TBSSH;
=pod
sleep 10;
test_cmd 'linktest1', [], "run_linktest.pl -v -L 1 -l 1 -e $pid/$eid";
sleep 2;
......@@ -16,18 +16,35 @@ use Tools::TBSSH;
test_cmd 'linktest3', [], "run_linktest.pl -v -L 3 -l 3 -e $pid/$eid";
sleep 2;
test_cmd 'linktest4', [], "run_linktest.pl -v -L 4 -l 4 -e $pid/$eid";
=cut
=head1 NAME
TestBed::Wrap::linktest
=over 4
=item C<linktest($pid, $eid)>
executes linktest on $pid and $eid by sshing to ops
=back
=cut
sub linktest {
my ($pid, $eid) = @_;
my $ssh = Tools::TBSSH::ssh($TBConfig::OPS_SERVER, $TBConfig::EMULAB_USER);
my $results = 0;
my $ssh = Tools::TBSSH::instance($TBConfig::OPS_SERVER);
sleep 8;
for my $i (1..4) {
sleep 2;
my $cmd = 'PATH=/usr/testbed/bin:$PATH '. "run_linktest.pl -v -L $i -l $i -e $pid/$eid";
say $cmd;
$ssh->cmdsuccessdump($cmd);
$results && $ssh->cmdsuccess($cmd);
}
!$results;
}
1;
#!/usr/bin/perl
package TestBed::Wrap::tevc;
use SemiModern::Perl;
use TBConfig;
......@@ -8,6 +7,7 @@ use Tools;
use Tools::TBSSH;
=pod
tevc -e proj/expt time objname event [args ...]
where the time parameter is one of:
......@@ -25,6 +25,21 @@ tevc -e testbed/myexp +17 link0 up
tevc -e testbed/myexp +20 cbr0 stop
=cut
=head1 NAME
TestBed::Wrap::tevc
=over 4
=item C<tevc($pid, $eid, $arg)>
executes tevc on $pid and $eid with $arg string such as "now link1 down"
by sshing to ops
=back
=cut
sub tevc {
my ($pid, $eid, @args) = @_;
my $cmd = 'PATH=/usr/testbed/bin:$PATH tevc ' . "-e $pid/$eid " . join(" ", @args);
......
#!/usr/bin/perl
package TestBed::XMLRPC::Client;
use SemiModern::Perl;
use Mouse;
......@@ -13,18 +12,23 @@ my $loglevel = "INFO";
$loglevel = "DEBUG" if $TBConfig::DEBUG_XML_CLIENT;
my $logger = init_tbts_logger("XMLRPCClient", undef, "INFO", "SCREEN");
#ensures loading of client side SSL certificates
BEGIN {
use TBConfig;
$ENV{HTTPS_CERT_FILE} = glob($TBConfig::SSL_CLIENT_CERT);
$ENV{HTTPS_KEY_FILE} = glob($TBConfig::SSL_CLIENT_KEY);
}
#constructs RPC::XML::Client with 10 minute socket timeout
my $HTTP_TIMEOUT = (60 * 10);
has 'client' => ( isa => 'RPC::XML::Client', is => 'rw', default => sub {
my $c = RPC::XML::Client->new($TBConfig::XMLRPC_SERVER, 'timeout' => (10*60));
$c->{'__useragent'}->timeout(60*10);
my $c = RPC::XML::Client->new($TBConfig::XMLRPC_SERVER, 'timeout' => ($HTTP_TIMEOUT));
$c->{'__useragent'}->timeout($HTTP_TIMEOUT);
$c; } );
#autoloaded/autogenerated/method_missings/etc
#automatically constructs XMLRPC resquests for any sub name not defined in the package
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
......@@ -91,4 +95,88 @@ sub augment_func_code {
$self->xmlrpc_req_code($self->pkg() . "." . shift, $self->args(@_));
}
=head1 NAME
TestBed::XMLRPC::Client
=over 4
=item C<< $client->args(@args) >>
default implementation of arg stuffing.
overridable by subclasses
=item C<< xmlrpcfunc($fq_package_name) >>
B<INTERNAL:>
takes a fully qualified package name and generates xml package and function names
strips _.* off the end of the function name
returns ("$package.$funcname", $package, $funcname)
=item C<< pkgfunclist >>
B<INTERNAL:> reaches up the caller chain three levels and returns the fully qualified package name
=item C<< pkgfunc >>
B<INTERNAL:> reaches up the caller chain three levels and returns the XMLRPC package.function
=item C<< pkg >>
B<INTERNAL:> reaches up the caller chain three levels and returns the XMLRPC package.function
=item C<< func >>
B<INTERNAL:> reaches up the caller chain three levels and returns the XMLRPC package.function
=item C<< $client->single_request($command, @args) >>
B<INTERNAL:> executes a single XMLRPC $command with @args and returns a XMLRPC response
=item C<< $client->xmlrpc_req_value(@args) >>
B<INTERNAL:> returns the value member of a XMLRPC call with @args
=item C<< $client->xmlrpc_req_output(@args) >>
B<INTERNAL:> returns the output member of a XMLRPC call with @args
=item C<< $client->xmlrpc_req_code(@args) >>
B<INTERNAL:> returns the code member of a XMLRPC call with @args
=item C<< $client->augment(@other_args) >>
executes xmlrpc request divining the XMLRPC package and function from the current perl package and function
returns XMLRPC reponse value
=item C<< $client->augment_output(@other_args) >>
executes xmlrpc request divining the XMLRPC package and function from the current perl package and function
returns XMLRPC reponse ouput
=item C<< $client->augment_code(@other_args) >>
executes xmlrpc request divining the XMLRPC package and function from the current perl package and function
returns XMLRPC reponse code
=item C<< $client->augment_func($funcname, @other_args) >>
executes xmlrpc request divining the XMLRPC package from the current perl package
returns XMLRPC reponse value
=item C<< $client->augment_func_output($funcname, @other_args) >>
executes xmlrpc request divining the XMLRPC package from the current perl package
returns XMLRPC reponse output
=item C<< $client->augment_code($funcname, @other_args) >>
executes xmlrpc request divining the XMLRPC package from the current perl package
returns XMLRPC reponse code
=back
=cut
1;
#!/usr/bin/perl
use SemiModern::Perl;
package TestBed::XMLRPC::Client::Emulab;
use SemiModern::Perl;
use Mouse;
use Data::Dumper;
extends 'TestBed::XMLRPC::Client';
=head1 NAME
TestBed::XMLRPC::Client::Emulab
=over 4
=item C<news()>
returns the emulab news
=back
=cut
#autoloaded/autogenerated/method_missings/etc news
1;
#!/usr/bin/perl
use SemiModern::Perl;
package TestBed::XMLRPC::Client::Experiment;
use SemiModern::Perl;
use Mouse;
use Data::Dumper;
use TestBed::XMLRPC::Client::NodeInfo;
......@@ -73,4 +72,128 @@ sub gen_expinfo_funcs {
gen_expinfo_funcs();
=head1 NAME
TestBed::XMLRPC::Client::Experiment
=over 4
=item C<pid>
experiment pid
=item C<eid>
experiment eid
=item C<batchexp>
calls batchexp xmlrpc function
=item C<swapexp>
calls swapexp xmlrpc function
=item C<endexp>
calls endexp xmlrpc function
=item C<waitforactive>
calls waitforactive xmlrpc function
=item C<getlist>
calls getlist xmlrpc function
=item C<expinfo>
calls expinfo xmlrpc cfunction
=item C<args>
B<INTERNAL>: internal method for inserting pid and eid arguments into a xmlrpc call
=item C<< $e->echo($msg) >>
echos $msg through the emulab xmlrpc server
=item C<< $e->getlist_brief() >>
returns the 'format' => 'brief' experiement list
=item C<< $e->getlist_full() >>
returns the 'format' => 'full' experiement list
=item C<< $e->batchexp_ns($nsfile_contents, @args) >>
batches experiment defined in $nsfile_contents
=item C<< $e->swapin >>
swaps the experiment in
=item C<< $e->swapout >>
swaps the experiment out
=item C<< $e->end >>
ends the experiment
=item C<< $e->nodeinfo >>
returns a list of node names in the experiment
=item C<< $e->waitsforactive >>
waits for the experiment to enter the active state
=item C<< $e->waitforswapped >>