Commit 448160a8 authored by Kevin Tew's avatar Kevin Tew

Perl testsuite for swapping

parent 213f7535
THARNESS=perl t/harness
all: usage
$(MAKE) test
usage:
@echo "make"
@echo " test"
@echo " exptest"
@echo " t/SPECIFIC_TEST.t"
test:
$(THARNESS)
critic:
perlcritic .
topo:
$(THARNESS) t/topologies/*.t
# Run a single test
t/*.t t/*/*.t t/*/*/*.t: force
$(THARNESS) $@
force: ;
# pull in ExtUtils/AutoInstall.pm from 'inc'
use lib 'inc';
use ExtUtils::AutoInstall (
-core => [ # mandatory modules
'Carp' => '',
'Modern::Perl' => '',
'Mouse' => '',
'RPC::XML::Client' => '',
'RPC::XML' => '',
'Sys::Hostname' => '',
'Test::More' => '',
'Time::Local' => '',
'TAP::Harness' => '',
],
);
=pod
WriteMakefile(
AUTHOR => 'Emula Perl <perl@emulab.net>',
ABSTRACT => 'Perl Testsuite for Emulab',
NAME => 'Testbed::Testsuite',
VERSION_FROM => 'Testbed::Testsuite::Experiment.pm',
DISTNAME => 'Emulab-Testbed',
);
=cut
use Modern::Perl;
package TBConfig;
use Sys::Hostname;
=pod
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw($XMLRPC_SERVER, $CLIENT_CERT, $CLIENT_KEY);
=cut
sub istan {
hostname() =~ /tan/;
}
our $XMLRPC_SERVER = "https://boss.emulab.net:3069/usr/testbed";
our $XMLRPC_VERSION = "0.1";
our $SSL_CLIENT_CERT = "~/.ssl/emulab.cert";
our $SSL_CLIENT_KEY = "~/.ssl/emulabkeyout.pem";
our $DEBUG_XML_CLIENT = istan();
sub KEVINS_MOCK_SETUP {
our $XMLRPC_SERVER = "https://localhost:3069/home/tewk/srcs/tbxmlrpctests";
our $SSL_CLIENT_CERT = "mock/client/cl-cert.pem";
our $SSL_CLIENT_KEY = "mock/client/cl-key.pem";
our $DBI_CONNECT_STR = "DBI:mysql:tbdb";
}
1;
xml result codes
DEBUG flags
hand die in middle of a swap
topology dsls
ssh test
test groupings
#!/usr/bin/perl
use Modern::Perl;
package TestBed::TestSuite::Experiment;
use Tools::PingTest;
use TestBed::XMLRPC::Client::Experiment;
use Test::More;
our @ISA = qw(Test::More);
our @EXPORT = qw(e ep echo newexp batchexp list list_brief list_full launchpingswapkill);
sub ep { TestBed::XMLRPC::Client::Experiment->new() }
sub e { TestBed::XMLRPC::Client::Experiment->new('pid'=> shift, 'eid' => shift) }
sub echo { ep()->echo(@_); }
sub _newexp { my $e = e(shift, shift); $e->batchexp_ns(shift, @_); $e }
sub _newexp_wait { _newexp(@_, 'wait' => 1); }
sub newexp { _newexp(@_); }
sub newexp_wait { _newexp_wait(@_); }
sub batchexp { _newexp(@_); }
sub batchexp_wait { _newexp_wait(@_); }
sub list { ep()->getlist; }
sub list_brief { ep()->getlist_brief; }
sub list_full { ep()->getlist_full; }
sub connectivity_test {
ping("node1.tewkt.tbres.emulab.net");
ping("node2.tewkt.tbres.emulab.net");
}
sub launchpingswapkill {
my ($pid, $eid, $ns) = @_;
my $e = e($pid, $eid);
$e->batchexp_ns($ns) && die "batchexp $eid failed";
$e->waitforactive();
connectivity_test($e);
$e->nodeinfo();
$e->swapoutw();
$e->waitforswapped();
$e->swapinw();
$e->waitforactive();
connectivity_test($e);
$e->end();
}
1;
#!/usr/bin/perl
use Modern::Perl;
package TestBed::XMLRPC::Client;
use Mouse;
use RPC::XML::Client;
use TBConfig;
use Data::Dumper;
use Carp;
use Tools;
BEGIN {
use TBConfig;
$ENV{HTTPS_CERT_FILE} = glob($TBConfig::SSL_CLIENT_CERT);
$ENV{HTTPS_KEY_FILE} = glob($TBConfig::SSL_CLIENT_KEY);
}
our $DEBUG = $TBConfig::DEBUG_XML_CLIENT;
has 'client' => ( isa => 'RPC::XML::Client', is => 'rw', default => sub {
my $c = RPC::XML::Client->new($TBConfig::XMLRPC_SERVER, 'timeout' => (4*60));
$c->{'__useragent'}->timeout(60*4);
$c; } );
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
my $type = ref($self) or croak "$self is not an object";
$self->xmlrpc_req_value(($self->xmlrpcfunc($AUTOLOAD))[0], $self->args(@_));
}
sub args {
my $self = shift;
+{ @_ };
}
sub augment {
my $self = shift;
$self->xmlrpc_req_value($self->pkgfunc(), $self->args(@_));
}
sub augment_output {
my $self = shift;
$self->xmlrpc_req_output($self->pkgfunc(), $self->args(@_));
}
sub augment_func {
my $self = shift;
$self->xmlrpc_req_value($self->pkg() . "." . shift, $self->args(@_));
}
sub xmlrpcfunc {
$_[1] =~ m/.*:([^:]*)::([^:]*)/;
my ($package, $func) = ($1, $2);
$func =~ s/\_.*//;
(lc($package) . "." . $func, lc($package), $func);
}
sub pkgfunclist {
my $c = ((caller(3))[3]);
#say $c;
(shift->xmlrpcfunc($c));
}
sub pkgfunc { (shift->pkgfunclist())[0]; }
sub pkg { (shift->pkgfunclist())[1]; }
sub func { (shift->pkgfunclist())[2]; }
sub single_request {
my ($self, $command, @args) = @_;
if ($DEBUG) {
sayperl($command, @args);
sayts("Sent");
}
my $resp = $self->client->send_request($command, $TBConfig::XMLRPC_VERSION, @args);
if ($DEBUG) {
sayts("Received");
say Dumper($resp);
}
$resp;
}
sub xmlrpc_req_value { single_request(@_)->value-> {'value'}; }
sub xmlrpc_req_output { single_request(@_)->value-> {'output'}; }
sub xmlrpc_req_code { single_request(@_)->value-> {'code'}; }
1;
#!/usr/bin/perl
use Modern::Perl;
package TestBed::XMLRPC::Client::Emulab;
use Mouse;
use Data::Dumper;
extends 'TestBed::XMLRPC::Client';
#autoloaded/autogenerated/method_missings/etc news
1;
#!/usr/bin/perl
use Modern::Perl;
package TestBed::XMLRPC::Client::Experiment;
use Mouse;
use Data::Dumper;
extends 'TestBed::XMLRPC::Client';
has 'pid' => ( isa => 'Str', is => 'rw');
has 'eid' => ( isa => 'Str', is => 'rw');
#autoloaded/autogenerated/method_missings/etc batchexp swapexp endexp waitforactive getlist expinfo
sub args {
my $self = shift;
{ 'pid' => $self->pid, 'eid' => $self->eid, @_ };
}
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 swapin { shift->augment_func( 'swapexp', 'direction' => 'in' ); }
sub swapout { shift->augment_func( 'swapexp', 'direction' => 'out' ); }
sub swapinw { shift->augment_func( 'swapexp', 'direction' => 'in', 'wait' => 1 ); }
sub swapoutw { shift->augment_func( 'swapexp', 'direction' => 'out', 'wait' => 1 ); }
sub end { shift->augment_func( 'endexp' ); }
sub waitforswapped { shift->augment_func( 'statewait', 'state' => 'swapped' ); }
sub gen_expinfo_funcs {
my ($package) = caller();
for my $funcname (qw( nodeinfo mapping linkinfo shaping) ) {
my $sub = sub {
shift->augment_func('expinfo', 'show' => $funcname );
};
no strict 'refs';
*{ $package . '::' . $funcname } = $sub;
}
}
gen_expinfo_funcs();
1;
use Modern::Perl;
package Tools;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(prettytimestamp timestamp sayts sayperl);
sub prettytimestamp {
my $t = shift || time;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($t);
sprintf "%4d-%02d-%02dT%02d:%02d:%02d", $year+1900,$mon+1,$mday,$hour,$min,$sec;
}
sub timestamp {
my $t = shift || time;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($t);
sprintf "%4d%02d%02d%02d%02d%02d", $year+1900,$mon+1,$mday,$hour,$min,$sec;
}
sub sayts {
print prettytimestamp() . " ";
say @_;
}
sub perlit {
map {_perlit($_)} @_;
}
sub sayperl {
say join(", ", perlit(@_));
}
sub _perlit {
my ($x) = @_;
$x ||= '';
my $ref = ref($x);
if (!defined $ref) {
}
elsif ($ref eq 'ARRAY') {
"[" . join(", ", perlit(@$x)) . "]";
}
elsif ($ref eq 'HASH') {
my $o = "[";
my @els;
while (my ($k, $v) = each (%$x)) {
my $o =_perlit($k) . " => " . _perlit($v);
push @els, $o;
}
$o .= join(", ", @els);
$o .= "]";
$o;
}
else {
return "'" . $x . "'";
}
}
1;
#!/usr/bin/perl
use Modern::Perl;
package Tools::PingTest;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(ping);
use Data::Dumper;
sub ping {
my ($host) = @_;
system("ping -c 3 -W 1 -w 5 $host");
$?;
}
1;
#!/usr/bin/perl
use Modern::Perl;
use lib 'lib';
use TestBed::TestSuite::Experiment;
use Test::More;
use Data::Dumper;
sub listexps {
output(list_full)
}
my $ns = <<'NSEND';
source tb_compat.tcl
set ns [new Simulator]
set node1 [$ns node]
set node2 [$ns node]
set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
$ns run
NSEND
#launchpingswapkill('tbres', 'tewkt', $ns);
sub output {
my ($h) = @_;
while(my ($pk, $v) = each %$h) {
while(my ($gk, $v) = each %$v) {
for my $e (@$v) {
my $eid;
given ($e) {
when('name') { $eid = sprintf("%s %s", $e->{'name'}, $e->{'state'});}
default { $eid = $e; }
};
say "$pk :: $gk :: $eid";
}
}
}
}
listexps();
if (@ARGV && $ARGV[0] eq 'end') {
e('tbres', 'tewkt')->end();
listexps();
}
# vim: ft=perl:
#!/usr/bin/perl
use Modern::Perl;
use TestBed::XMLRPC::Client::Emulab;
use Test::More tests => 3;
use Time::Local;
use Data::Dumper;
use Tools;
use RPC::XML qw(time2iso8601);
my $emuclient = TestBed::XMLRPC::Client::Emulab->new();
ok($emuclient);
isa_ok($emuclient, 'TestBed::XMLRPC::Client::Emulab');
my $time = timegm(0,0,0,1,0,2008);
my $resp = $emuclient->news('starting' => time2iso8601($time));
ok($resp);
#!/usr/bin/perl
use Modern::Perl;
use TestBed::TestSuite::Experiment tests => 3;
use Test::More;
use Data::Dumper;
my $teststr = "hello there";
like(echo($teststr), qr/$teststr/, "Experiment echo test");
ok(list_brief(), "Experiment getlist brief");
ok(list_full(), "Experiment getlist full");
#/usr/bin/perl
use Modern::Perl;
use TAP::Harness;
use Data::Dumper;
my %args = (
verbosity => 1,
lib => [ 'lib', 'blib/lib' ],
);
my $harness = TAP::Harness->new( \%args );
my @default_tests = qw( t/*.t );
my @tests = map { glob($_) } (@ARGV ? @ARGV : @default_tests);
$harness->runtests(@tests);
# vim: ft=perl:
#!/usr/bin/perl
use Modern::Perl;
use TestBed::TestSuite::Experiment tests => 1;
use Test::More;
use Data::Dumper;
my $ns = <<'NSEND';
source tb_compat.tcl
set ns [new Simulator]
set node1 [$ns node]
set node2 [$ns node]
set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
$ns run
NSEND
ok(launchpingswapkill('tbres', 'tewkt', $ns));
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