Commit c0d56d03 authored by Kevin Tew's avatar Kevin Tew

testsuite / testswap link up link down demo

parent a6337bb1
......@@ -7,11 +7,9 @@ perl_version '5.008';
author 'Kevin Tew <tewk@flux.utah.edu>';
version '0.01';
#requires 'Test::Exception' => '0.27';
requires 'Mouse' => '';
requires 'RPC::XML::Client' => '1.24';
requires 'RPC::XML' => '1.41';
requires 'Sys::Hostname' => '1.11';
requires 'Test::More' => '0.86';
requires 'Time::Local' => '1.1901';
requires 'TAP::Harness' => '3.16';
......
package TBConfig;
use SemiModern::Perl;
use Sys::Hostname;
use Crypt::X509;
use Tools qw(slurp);
use Data::Dumper;
......@@ -14,7 +13,7 @@ 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 $DEBUG_XML_CLIENT = (hostname() =~ /tan/);
our $DEBUG_XML_CLIENT = $ENV{TBTS_DEBUG} || 0;
sub get_emulab_user {
my $cert = slurp($SSL_CLIENT_CERT);
......
......@@ -8,6 +8,7 @@ use TestBed::Wrap::linktest;
use Tools::TBSSH;
use Data::Dumper;
use TestBed::TestSuite::Node;
use TestBed::TestSuite::Link;
extends 'Exporter', 'TestBed::XMLRPC::Client::Experiment';
require Exporter;
......@@ -22,6 +23,24 @@ framwork class for starting and testing experiments
=over 4
=item C<< $e->node($nodename) >>
returns a node object representing node $nodename in the experiment
=cut
sub node {
my ($e, $nodename) = @_;
TestBed::TestSuite::Node->new('experiment' => $e, 'name' => $nodename);
}
=item C<< $e->link($linkname) >>
returns a link object representing link $linkname in the experiment
=cut
sub link {
my ($e, $linkname) = @_;
TestBed::TestSuite::Link->new('experiment' => $e, 'name' => $linkname);
}
=item C<nodes()>
returns a list of node objects representing each node in the experiment
......@@ -73,6 +92,24 @@ sub tevc {
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, @_);
}
=item C<< $e->linkup($linkname) >>
uses tevc to bring down a link
=cut
sub linkup {
my ($e, $link) = @_;
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, "now $link up");
}
=item C<< $e->linkdown($linkname) >>
uses tevc to bring up a link
=cut
sub linkdown {
my ($e, $link) = @_;
TestBed::Wrap::tevc::tevc($e->pid, $e->eid, "now $link down");
}
=item C<trytest { code ... } $e>
catches exceptions while a test is running and cleans up the experiment
......@@ -106,6 +143,13 @@ sub startrunkill {
} $e;
}
sub startrun {
my ($e, $ns, $worker) = @_;
my $eid = $e->eid;
$e->startexp_ns_wait($ns) && die "batchexp $eid failed";
$worker->($e) || die "worker function failed";
}
=item C<launchpingkill($pid, $eid, $ns)>
class method that starts an experiment, runs a ping_test, and ends the experiment
......
#!/usr/bin/perl
package TestBed::TestSuite::Link;
use SemiModern::Perl;
use Mouse;
#use TestBed::XMLRPC::Client::Link;
use Tools::Network;
use Tools::TBSSH;
use Data::Dumper;
use TestBed::Wrap::tevc;
has 'name' => ( isa => 'Str', is => 'rw');
has 'experiment' => ( is => 'rw');
=head1 NAME
TestBed::TestSuite::Link
=over 4
=item C<< $l->up >>
uses tevc to bring up a link
=cut
sub up { shift->tevc("up"); }
=item C<< $l->down >>
uses tevc to bring down a link
=cut
sub down { shift->tevc("down"); }
=item C<< $l->tevc($cmd) >>
uses tevc to control link
=cut
sub tevc {
my ($self, $cmd) = @_;
my $name = $self->name;
TestBed::Wrap::tevc::tevc($self->experiment->pid, $self->experiment->eid, "now $name $cmd");
}
=back
=cut
1;
......@@ -42,7 +42,8 @@ returns a $ssh connection to the node
=cut
sub ssh {
my $self = shift;
my $ssh = Tools::TBSSH::instance($self->name);
my $fqname = $self->name . "." . $self->experiment->eid . "." . $self->experiment->pid . ".emulab.net";
my $ssh = Tools::TBSSH::instance($fqname);
}
=back
......
......@@ -44,7 +44,7 @@ sub tevc {
my ($pid, $eid, @args) = @_;
my $cmd = 'PATH=/usr/testbed/bin:$PATH tevc ' . "-e $pid/$eid " . join(" ", @args);
say $cmd;
Tools::TBSSH::cmdsuccessdump($TBConfig::OPS_SERVER, $cmd);
Tools::TBSSH::cmdsuccess($TBConfig::OPS_SERVER, $cmd);
}
1;
......@@ -61,9 +61,17 @@ sub single_request {
my ($self, $command, @args) = @_;
$logger->debug(toperl($command, @args));
$logger->debug("Sent");
if ($TBConfig::DEBUG_XML_CLIENT) {
say("Sent");
sayperl($command, @args)
}
my $resp = $self->client->send_request($command, $TBConfig::XMLRPC_VERSION, @args);
$logger->debug("Received");
$logger->debug( sub { Dumper($resp); } );
if ($TBConfig::DEBUG_XML_CLIENT) {
say("Received");
say Dumper($resp);
}
$resp;
}
......
......@@ -53,6 +53,16 @@ sub cmdsuccessdump {
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { print Dumper(\@_); $_[2] == 0; } );
}
sub cmdfailure {
my ($host, $cmd) = @_;
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { $_[2] != 0; } );
}
sub cmdfailuredump {
my ($host, $cmd) = @_;
return wrapped_ssh($host, $TBConfig::EMULAB_USER, $cmd, sub { print Dumper(\@_); $_[2] != 0; } );
}
=head1 NAME
Tools::TBSSH
......
......@@ -28,11 +28,9 @@ sub automate_module_install {
sub install_deps_from_cpan {
my @deps = qw(
Test::Exception
Mouse
RPC::XML::Client
RPC::XML
Sys::Hostname
Test::More
Time::Local
TAP::Harness
......
......@@ -30,6 +30,9 @@ say <<"END"
swapout
end
ping
tevc
linktest
single_node_tests
ni // nodeinfo
li // linkinfo
END
......
#!/usr/bin/perl
use SemiModern::Perl;
use TBConfig;
use TestBed::TestSuite;
use Test::More tests => 5;
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" 5Mb 20ms]
set link1 [$ns duplex-link $node1 $node2 100Mb 50ms DropTail]
$ns run
NSEND
my $eid='linkupdown';
my $e = dpe($eid);
$e->startrunkill($ns,
sub {
my ($e) = @_;
ok($e->linktest, "$eid linktest");
ok($e->link("link1")->down, "link down");
sleep(2);
my $nlssh = $e->node("node1")->ssh;
ok($nlssh->cmdfailuredump("ping -c 5 10.1.2.3"));
ok($e->link("link1")->up, "link up");
sleep(2);
ok($nlssh->cmdsuccessdump("ping -c 5 10.1.2.3"));
}
);
......@@ -23,11 +23,13 @@ use Data::Dumper;
my $logging = 0;
my $timing;
my $verbose;
my $debug;
my $result = GetOptions (
"jobs=i" => \$pjobs,
"logging=i" => \$logging,
"timing" => \$timing,
"verbose" => \$verbose);
"verbose" => \$verbose,
"debug" => \$debug);
if ($pjobs > 1) {
$ENV{'HARNESS_OPTIONS'} = "j$pjobs";
......@@ -39,6 +41,9 @@ use Data::Dumper;
$ENV{'HARNESS_VERBOSE'} = 1;
$ENV{HARNESS_COLOR} = 1;
}
if ($debug) {
$ENV{TBTS_DEBUG} = 1;
}
}
my $THARNESS = 'perl t/harness';
......
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