testswap beginnings of tevc

testsuite/testswap/TBConfig.pm

@@ -8,6 +8,7 @@ use Data::Dumper;
 use MIME::Base64;
 
 our $XMLRPC_SERVER    = "https://boss.emulab.net:3069/usr/testbed";
+our $OPS_SERVER       = "users.emulab.net";
 our $XMLRPC_VERSION   = "0.1";
 our $SSL_CLIENT_CERT  = glob("~/.ssl/emulab.cert");
 our $SSL_CLIENT_KEY   = glob("~/.ssl/emulabkeyout.pem");

testsuite/testswap/TODO

 test groupings
 linkinfo
+linktest
 event system
-tests
+convert more old tests
 
 THINKING ABOUT IT
   Test::Class
@@ -11,4 +12,4 @@ MOSTLY DONE
 
 LATER
   Client.pm duplicate code elimination - Maybe this would make the code too unreadable
-  Work on TestSuite::Experiment::Macros
+  TestSuite::Experiment::Macros should be a monadic language like JQuery

testsuite/testswap/lib/TestBed/TestSuite/Experiment/Macros.pm

@@ -2,23 +2,24 @@
 use SemiModern::Perl;
 
 package TestBed::TestSuite::Experiment::Macros;
+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 ep echo newexp batchexp list list_brief list_full
+      plistexps);
 
 use TestBed::TestSuite::Experiment;
 use Test::More;
 
 sub echo          { ep()->echo(@_); }
-sub _newexp       { my $e = e(shift, shift); $e->batchexp_ns(shift, @_); $e }
-sub _newexp_wait  { my $e = e(shift, shift); $e->batchexp_ns_wait(shift, @_); $e }
-sub newexp        { _newexp(@_); }
-sub newexp_wait   { _newexp_wait(@_); }
-sub batchexp      { _newexp(@_); }
-sub batchexp_wait { _newexp_wait(@_); }
+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          { ep()->getlist; }
 sub list_brief    { ep()->getlist_brief; }
 sub list_full     { ep()->getlist_full; }
+sub plistexps     { pretty_listexp(list_full); }
 
 1;

testsuite/testswap/lib/TestBed/Wrap/tevc.pm

+#!/usr/bin/perl
+
+package TestBed::Wrap::tevc;
+use SemiModern::Perl;
+use TBConfig;
+use Data::Dumper;
+use Tools;
+use Tools::TBSSH;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(tevc);
+
+my $loglevel = "INFO";
+$loglevel = "DEBUG";
+my $logger = init_tbts_logger("Wrap::tevc", undef, "INFO", "SCREEN");
+
+=pod
+tevc -e proj/expt time objname event [args ...]
+
+where the time parameter is one of:
+
+* now
+* +seconds (floating point or integer)
+* [[[[yy]mm]dd]HH]MMss 
+
+For example, you could issue this sequence of events.
+
+tevc -e testbed/myexp now cbr0 set interval_=0.2
+tevc -e testbed/myexp +10 cbr0 start
+tevc -e testbed/myexp +15 link0 down
+tevc -e testbed/myexp +17 link0 up
+tevc -e testbed/myexp +20 cbr0 stop
+=cut
+
+sub tevc {
+  my ($args) = @_;
+  $args ||= '';
+  my $ssh = Tools::TBSSH::sshtty($TBConfig::OPS_SERVER, $TBConfig::EMULAB_USER);
+  my $cmd = 'PATH=/usr/testbed/bin:$PATH tevc ' . $args;
+  say $cmd;
+  $ssh->cmdcatout($cmd);
+}
+
+1;

testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm

@@ -35,6 +35,10 @@ sub waitforswapped {
   $self->augment_func_code( 'statewait', 'state' => 'swapped' )
      && die sprintf("wait for swapin %s failed", $self->eid);
 }
+
+sub startexp_ns { batchexp_ns(@_, 'batch' => 0); }
+sub startexp_ns_wait { batchexp_ns_wait(@_, 'batch' => 0); }
+
 sub batchexp_ns_wait { 
   my $self = shift;
   $self->batchexp_ns(@_);
@@ -61,7 +65,7 @@ sub gen_expinfo_funcs {
   my ($package) = caller();
   for my $funcname (qw(mapping linkinfo shaping) ) {
     my $sub = sub {
-      shift->augment_func('expinfo', 'show' => $funcname );
+      shift->augment_func_output('expinfo', 'show' => $funcname );
     };
     inject_sub($package . '::' . $funcname, $sub);
   }

testsuite/testswap/lib/TestBed/XMLRPC/Client/Pretty.pm

+#!/usr/bin/perl
+
+package TestBed::XMLRPC::Client::Pretty;
+use SemiModern::Perl;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(pretty_listexp);
+use Data::Dumper;
+
+sub pretty_listexp {
+  my ($h) = @_;
+  while(my ($pk, $v) = each %$h) {
+    while(my ($gk, $v) = each %$v) {
+      for my $e (@$v) {
+        my $eid;
+        if ( exists $e->{'name'} )  { $eid = sprintf("%s %s", $e->{'name'}, $e->{'state'});}
+        else { $eid = $e; }
+        say "$pk :: $gk :: $eid";
+      }
+    }
+  }
+}
+
+1;

testsuite/testswap/lib/Tools/TBSSH.pm

@@ -25,11 +25,19 @@ sub path_to_last_part {
   }
 }
 
-
+sub sshtty {
+  ssh(@_, use_tty => 1);
+}
+sub ssh {
+  my ($host, $user, @options) = @_;
+  my $ssh = Net::SSH::Perl->new($host, protocol => "2", options => [ "ForwardAgent yes" ], @options);
+  $ssh->login($user);
+  return $ssh
+}
 sub sshhostname {
   my ($host, $user) = @_;
-  my $ssh = Net::SSH::Perl->new($host, protocol => "2", options => [ "ForwardAgent yes" ]);
-  $ssh->login($user);
+  
+  my $ssh = ssh($host, $user);
   print [$ssh->cmd('uname -a')]->[0];
   return $ssh
 }
@@ -51,9 +59,16 @@ sub pulldirastar {
 }
 
 package Net::SSH::Perl::SSH2;
-use strict;
+use SemiModern::Perl;
 use Net::SSH::Perl::Constants qw( :protocol :msg2 CHAN_INPUT_CLOSED CHAN_INPUT_WAIT_DRAIN );
 
+sub cmdcatout {
+  my $ssh = shift;
+  my @results = $ssh->cmd(@_);
+  say $results[1];
+  say "DONE ttycmdcatout";
+}
+
 sub cmd_debug {
     my $ssh = shift;
     my($cmd, $stdin) = @_;

testsuite/testswap/sc

@@ -4,10 +4,7 @@ use SemiModern::Perl;
 use TestBed::TestSuite::Experiment::Macros;
 use Data::Dumper;
 use Tools::TBSSH;
-
-sub listexps {
-  output(list_full)
-}
+use TestBed::Wrap::tevc;
 
 my $ns = <<'NSEND';
 source tb_compat.tcl
@@ -18,28 +15,29 @@ set node1 [$ns node]
 set node2 [$ns node]
 
 set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
+set link1 [$ns duplex-link $node1 $node2 100Mb 50ms DropTail]
 $ns run
 NSEND
 
-sub output {
-  my ($h) = @_;
-  while(my ($pk, $v) = each %$h) {
-    while(my ($gk, $v) = each %$v) {
-      for my $e (@$v) {
-        my $eid;
-        if ( exists $e->{'name'} )  { $eid = sprintf("%s %s", $e->{'name'}, $e->{'state'});}
-        else { $eid = $e; }
-        say "$pk :: $gk :: $eid";
-      }
-    }
-  }
+sub usage {
+say <<"END"
+./sc
+     start eid
+     end   eid
+     ping  eid
+     ni    eid  // nodeinfo
+     li    eid  // linkinfo
+END
 }
+
 my $pid = 'tbres';
+
 if (@ARGV) {
   $_ = $ARGV[0];
   my $eid = $ARGV[1];
   my $e = e($pid, $eid);
-  if (/end/) { $e->end(); }
+  if (/--help/) { usage; } 
+  elsif (/end/) { $e->end(); }
   elsif ( /ping/ ) {
     my $nodes = $e->nodeinfo();
     for (@$nodes) {
@@ -48,10 +46,14 @@ if (@ARGV) {
      ping($_);
     }
   }
-  elsif (/start/) { $e->batchexp_ns_wait($ns); }
+  elsif (/start/) { $e->startexp_ns_wait($ns); }
+  elsif (/ni/) { say Dumper($e->nodeinfo) ;}
+  elsif (/li/) { say Dumper($e->linkinfo) ;}
+  elsif (/tevc/) { tevc("-e $pid/$eid now link1 down"); }
 }
 else {
-  listexps();
+  usage;
+  plistexps;
 }
 
 # vim: ft=perl: