testsuite/testswap subroutine documentation

testsuite/testswap/lib/SemiModern/Perl.pm

@@ -19,8 +19,6 @@ ensures perl version >= 5.008
 
 implements a perl5.10 like say for perl < 5.10
 
-=back
-
 =cut
 
 sub say {
@@ -40,11 +38,22 @@ sub say {
     croak $warning;
 }
 
+=item sayd
+
+dumps args and prints result with say
+
+=cut
+
 sub sayd {
   use Data::Dumper;
   say Dumper(@_);
 }
 
+=back
+
+=cut
+
+
 if (1 || $] < 5.010) {
   *IO::Handle::say = \&say if ! defined &IO::Handle::say;
 }

testsuite/testswap/lib/TestBed/ForkFramework.pm

@@ -307,8 +307,8 @@ extends 'TestBed::ForkFramework::Scheduler';
 
 has 'maxnodes'  => ( isa => 'Int'      , is => 'rw');
 has 'currnodes' => ( isa => 'Int'      , is => 'rw');
-has 'schedule' => ( isa => 'ArrayRef', is => 'rw');
-has 'weight' => ( isa => 'ArrayRef', is => 'rw');
+has 'schedule'  => ( isa => 'ArrayRef' , is => 'rw');
+has 'weight'    => ( isa => 'ArrayRef' , is => 'rw');
 
 sub work {
   my ($max_nodes, $proc, $weight, $items) = @_;

testsuite/testswap/lib/TestBed/Harness.pm

@@ -37,8 +37,33 @@ sub runharness {
 
   my $harness = TAP::Harness->new( \%harness_args );
   $harness->callback('parser_args', \&parser_args_callback);
-  push @$ts, TestBed::ParallelRunner->new() if @$pms;
+  push @$ts, [TestBed::ParallelRunner->new(), 'Parallel Tests'] if @$pms;
   $harness->runtests(@$ts);
 }
 
+=head1 NAME
+
+TestBed::Harness
+
+=over 4
+
+=item C<< runharness(@test_file_names) >>
+
+ex. runharness( 't/lib/*.t', 't/xmlrpc/*.t' 'test/BasicTopologies.pm' ) 
+
+runs the specified test in a TAP::harness
+pushes a ParallelRunner on if .pm parallel test modules are specified
+
+=item C<< split_t_pm(@test_file_names) >>
+
+splits test filenames into to lists based on .t and .pm extensions
+
+=item C<< parser_args_callback >>
+
+TAP::Harness parser_args callback that allow for special processing (pre_running) of parallel tests
+
+=back
+
+=cut
+
 1;

testsuite/testswap/lib/TestBed/ParallelRunner.pm

@@ -142,4 +142,38 @@ sub build_TAP_stream {
   return TAP::Parser::Iterator::StdOutErr->new($out, $err, $pid);
 }
 
+=head1 NAME
+
+TestBed::ParallelRunner
+
+=over 4
+
+=item C<< add_experiment >>
+
+helper function called by rege.
+creates a TestBed::ParallelRunner::Test job and pushes it onto @$ExperimentTests
+
+=item C<< runtests >>
+
+kicks off execution of parallel tests.
+
+=item C<< set_test_builder_to_end_state >>
+=item C<< reset_test_builder >>
+=item C<< setup_test_builder_ouputs >>
+
+B<INTERNAL> functions to get Test::Builder to behave correctly with parallel tests
+
+=item C<< tap_wrapper >>
+
+wraps two different ways of executing parallel tests and wrapping their TAP output stream
+
+=item C<< build_TAP_stream >>
+
+given a TestBed::ParallelRunner returns a TAP stream
+
+=back
+
+=cut
+
 1;
+

testsuite/testswap/lib/TestBed/ParallelRunner/Test.pm

@@ -56,4 +56,38 @@ sub kill {
   $self->e->end;
 }
 
+=head1 NAME
+
+TestBed::ParallelRunner::Test
+
+Represents a ParallelRunner Job
+
+=over 4
+
+=item C<< tn($e, $ns, $sub, $test_count, $desc) >>
+
+constructs a TestBed::ParallelRunner::Test job
+
+=item C<< $prt->prep >>
+
+executes the pre_running phase of experiment and determines min and max node counts.
+
+=item C<< $prt->run >>
+
+swaps in the experiment and runs the specified test
+
+=item C<< $prt->run_ensure_kill >>
+
+swaps in the experiment and runs the specified test
+it kills the experiment unconditionaly after the test returns
+
+=item C<< $prt->kill >>
+
+kills the experiment
+
+=back
+
+=cut
+
+
 1;

testsuite/testswap/lib/TestBed/TestSuite.pm

@@ -11,6 +11,7 @@ our @ISA = qw(Exporter);
 our @EXPORT = qw(e CartProd CartProdRunner concretize defaults override rege runtests);
 
 sub e { TestBed::TestSuite::Experiment->new(_build_e_from_positionals(@_)); }
+
 sub rege {
   my $e;
   if (@_ == 4)    { $e = e(); }
@@ -20,7 +21,7 @@ sub rege {
   else { die 'Too many args to rege'; }
   return TestBed::ParallelRunner::add_experiment($e, @_);
 }
-sub runtests { TestBed::ParallelRunner::runtests; }
+sub runtests { TestBed::ParallelRunner::runtests(@_); }
 
 
 sub _build_e_from_positionals {
@@ -119,6 +120,20 @@ creates a new experiment with pid and eid and uses the default gid in TBConfig
 
 creates a new experiment with pid, gid, and eid
 
+=item C<rege($ns_contents, &test_sub, $test_count, $desc)>
+=item C<rege($eid, $ns_contents, &test_sub, $test_count, $desc)>
+=item C<rege($pid, $eid, $ns_contents, &test_sub, $test_count, $desc)>
+=item C<rege($pid, $gid, $eid, $ns_contents, &test_sub, $test_count, $desc)>
+
+registers experiement with parallel test running engine
+
+=item C<runtests($concurrent_pre_runs, $concurrent_node_count_usage) >
+
+allows a maximum of $concurrent_pre_runs during parallel execution
+allows a maximum of $concurrent_nodes during parallel execution
+
+start the execution of parallel tests, not needed 
+
 =item C<CartProd($hashref)> Cartesian Product Runner
 
 =item C<CartProd($hashref, &filter_gen_func)> Cartesian Product Runner

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

@@ -132,6 +132,7 @@ sub parallel_tevc {
 
 =item C<< $e->loghole($cmd) >>
 
+runs loghole on ops
 =cut
 sub loghole {
   my ($e) = shift;
@@ -140,6 +141,7 @@ sub loghole {
 
 =item C<< $e->loghole_sync_allnodes($cmd) >>
 
+runs loghole sync all hostnames on ops
 =cut
 sub loghole_sync_allnodes {
   my ($e) = shift;
@@ -147,8 +149,9 @@ sub loghole_sync_allnodes {
   TestBed::Wrap::loghole::loghole($e, "sync @hostnames");
 }
 
-=item C<< $e->splat($cmd) >>
+=item C<< $e->splat($data, $filename) >>
 
+splats $data to $filename on each node
 =cut
 sub splat {
   my ($e, $data, $fn) = @_;
@@ -219,6 +222,11 @@ sub startrunkill {
   } $e;
 }
 
+=item C<< $e->startrun($ns_contents, $worker_sub) >>
+
+starts an experiment given a $ns file and a $worker
+call the $worker passing in the experiment $e
+=cut
 sub startrun {
   my ($e, $ns, $worker) = @_;
   my $eid = $e->eid;
@@ -240,7 +248,7 @@ sub launchpingkill {
   } $e;
 }
 
-=item C<launchpingkill($e, $ns)>
+=item C<launchpingswapkill($e, $ns)>
 
 method that starts an experiment, runs a ping_test, 
 swaps the experiment out and then back in, runs a ping test, and finally

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

@@ -26,6 +26,30 @@ B<EXPERIMENTAL>
 
 provides some common used class methods as global functions in the current package namespace
 
+=over 4
+
+=item echo
+
+deprecated
+
+=item list
+
+deprecated
+
+=item list_brief
+
+deprecated
+
+=item list_full
+
+deprecated
+
+=item plistexps
+
+deprecated
+
+=back
+
 =cut
 
 1;

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

@@ -165,6 +165,10 @@ B<INTERNAL:> reaches up the caller chain three levels and returns the XMLRPC pac
 
 B<INTERNAL:> executes a single XMLRPC $command with @args and returns a XMLRPC response
 
+=item C<< $client->xmlrpc_req(@args) >>
+
+B<INTERNAL:> returns the response of a XMLRPC call with @args 
+
 =item C<< $client->xmlrpc_req_value(@args) >>
 
 B<INTERNAL:> returns the value member of a XMLRPC call with @args 
@@ -207,6 +211,23 @@ returns XMLRPC reponse output
 executes xmlrpc request divining the XMLRPC package from the current perl package
 returns XMLRPC reponse code
 
+=item C<< $client->augment_code0($funcname, @other_args) >>
+
+executes xmlrpc request divining the XMLRPC package from the current perl package
+prints the output if response code is nonzero
+returns XMLRPC reponse code
+
+=item C<< $client->augment_func_code($funcname, @other_args) >>
+
+executes xmlrpc request divining the XMLRPC package from the current perl package
+returns XMLRPC reponse code
+
+=item C<< $client->augment_func_code0($funcname, @other_args) >>
+
+executes xmlrpc request divining the XMLRPC package from the current perl package
+prints the output if response code is nonzero
+returns XMLRPC reponse code
+
 =back
 
 =cut

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

@@ -229,6 +229,35 @@ returns experiment linkinfo
 
 returns experiment link shaping
 
+=item C<< $e->create_and_get_metadata($ns) >>
+
+creates the experiment and returns the create metadata
+i.e. min and max nodes, as well as a bunch of other stuff
+
+=item C<< $e->ensure_active_ns($ns) >>
+
+creates the experiment if it doesn't already exist and ensures that the experiement is swapped in
+
+=item C<< $e->gen_random_eid >>
+
+hook for generating a random $eid if desired
+
+=item C<< $e->modify_ns($ns) >>
+
+modifies the current experiment with the give $ns file
+
+=item C<< $e->noemail >>
+
+B<INTERNAL>: generates the noemail attribute for xmlrpc calls if so configured in TBConfig
+
+=item C<< gen_expinfo_funcs >>
+
+B<INTERNAL>: generates expinfo subs 
+
+=item C<< retry_on_TIMEOUT(&sub, $messag) >>
+
+B<INTERNAL>: catches socket timeout exceptions and rexecutes &sub after printing $message
+
 =back 
 
 =cut

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

@@ -8,24 +8,6 @@ extends 'TestBed::XMLRPC::Client';
 
 #autoloaded/autogenerated/method_missings/etc available getlist typeinfo
 
-=head1 NAME
-
-TestBed::XMLRPC::Client::Node
-
-=over 4
-
-=item C<available>
-
-returns a list of available nodes
-
-=item C<getlist>
-
-returns a list of available nodes
-
-=back
-
-=cut
-
 sub filter_hash {
   my ($hash, $proc) = @_;
   my %new_hash;
@@ -51,4 +33,35 @@ sub get_free {
 sub get_free_names {
   keys %{shift->get_free(@_)};
 }
+
+=head1 NAME
+
+TestBed::XMLRPC::Client::Node
+
+=over 4
+
+=item C<available>
+
+returns a list of available nodes
+
+=item C<getlist>
+
+returns a list of available nodes
+
+=item C<filter_hash($hash, $proc)>
+
+returns a new has containing key,value pairs that $proce returned true for
+
+=item C<get_free()>
+
+given a list of nodeshashes return nodehashes for nodes that are free
+
+=item C<get_free_names()>
+
+given a list of nodeshashes returns a list of node names that are free
+
+=back
+
+=cut
+
 1;

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

@@ -71,7 +71,7 @@ sub splitlines {
   \@lines;
 }
 
-=item beforeaftermatch
+=item C< beforeaftermatch($pattern, $array) >
 
 Return lines from $array before and after matching $pattern
 =cut
@@ -92,6 +92,10 @@ sub beforeaftermatch {
   (\@before, \@after);
 }
 
+=item C< aftermatch($pattern, $array) >
+
+Return lines from $array after matching $pattern
+=cut
 sub aftermatch { 
   [beforeaftermatch(@_)]->[1]
 }

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

@@ -6,18 +6,6 @@ our @ISA = qw(Exporter);
 our @EXPORT = qw(pretty_listexp experiments_hash_to_list);
 use Data::Dumper;
 
-=head1 NAME
-
-TestBed::XMLRPC::Client::Pretty;
-
-=over 4
-
-=item C<pretty_listexp>
-
-pretty prints the XMLRPC response from listexp
-
-=cut
-
 sub pretty_listexp {
   for my $ed (experiments_hash_to_list(@_)) {
     my ($pid, $gid, $eid,) = @{ $ed->[0] };
@@ -46,6 +34,20 @@ sub experiments_hash_to_list {
   return wantarray ? @exper_list : \@exper_list;
 }
 
+=head1 NAME
+
+TestBed::XMLRPC::Client::Pretty;
+
+=over 4
+
+=item C<pretty_listexp>
+
+pretty prints the XMLRPC response from listexp
+
+=item C<experiments_hash_to_list>
+
+converts the nested explist hash to an array of [ [$pid, $gid, $pid] $e] 
+
 =back
 
 =cut

testsuite/testswap/lib/Tools.pm

@@ -43,6 +43,7 @@ sub slurp {
   close($fh);
   return $data;
 }
+
 =item C<splat($filename, $file_data)>
 
 writes $file_data out to $filename
@@ -74,7 +75,7 @@ sub timestamp {
   sprintf "%4d%02d%02d%02d%02d%02d", $year+1900,$mon+1,$mday,$hour,$min,$sec;
 }
 
-=item C<saysts($msg)>
+=item C<sayts($msg)>
 
 prints "2009-01-30T10:10:20 $msg\n"
 =cut
@@ -190,7 +191,7 @@ sub getyn {
   lc($key) eq 'y';
 }
 
-=item C<yn($prompt)>
+=item C<yn_prompt($prompt)>
 
 prints $prompt
 returns 1 if user types Y or y 0 otherwise
@@ -204,6 +205,12 @@ sub yn_prompt {
   return $r;
 }
 
+=item C<splat_to_temp($data)>
+
+writes $data to tempfile and returns a File::Temp object
+
+=cut
+
 sub splat_to_temp {
  my $data = shift;
   use File::Temp;

testsuite/testswap/lib/Tools/TBSSH.pm

@@ -5,6 +5,7 @@ use Data::Dumper;
 use Mouse;
 
 eval{
+  #force use of 'Tools::WrappedSSH'
   require BOZO;
 };
 if ($@) {
@@ -85,6 +86,20 @@ Tools::TBSSH
 
 =over 4
 
+=item C< instance($host, %options) >
+
+creates a new $ssh object with $host, $user = $TBConfig::EMULAB_USER, and %options
+
+=item C<< $ssh->wrapped_ssh($user, $cmd, $checker) >>
+
+=item C<< $host->wrapped_ssh($user, $cmd, $checker) >>
+
+=item C<< $ssh->wrapped_scp($user, @files) >>
+
+=item C<< $host->wrapped_scp($user, #files) >>
+
+=item C<< $host->scp($host, #files) >>
+
 =item C<cmdcheckoutput($host, $cmd, $checker = sub { my ($out, $err, $resultcode) = @_; ... }>
 
 executes $cmd as $TBConfig::EMULAB_USER on $host and calls checker with ($out, $err, $resultcode)
@@ -97,6 +112,14 @@ returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER
 
 returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER and dumps the ssh stdout, stderr, resultcode
 
+=item C<cmdfailure($host, $cmd)>
+
+returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER
+
+=item C<cmdfailuredump($host, $cmd)>
+
+returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER and dumps the ssh stdout, stderr, resultcode
+
 =back
 
 =cut

testsuite/testswap/lib/Tools/WrappedSSH.pm

@@ -42,21 +42,13 @@ Tools::TBSSH
 
 =over 4
 
-=item C< wrapped_ssh($host, $user, $cmd, $checker)>
+=item C<< $ssh->cmd($cmd) >>
 
-B<LOWLEVEL SUB> execute $cmd on $host as $user and check result with $checker sub
+B<LOWLEVEL SUB> execute $cmd on $host as $user by wrapping cmdline ssh
 
-=item C<cmdcheckoutput($host, $cmd, $checker = sub { my ($out, $err, $resultcode) = @_; ... }>
+=item C<< $ssh->scp_worker(@files)  >>
 
-executes $cmd as $TBConfig::EMULAB_USER on $host and calls checker with ($out, $err, $resultcode)
-
-=item C<cmdsuccess($host, $cmd)>
-
-returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER
-
-=item C<cmdsuccessdump($host, $cmd)>
-
-returns the ssh result code of executing $cmd as $TBConfig::EMULAB_USER and dumps the ssh stdout, stderr, resultcode
+B<LOWLEVEL SUB> execute $scp with $files as arguments
 
 =back
 

testsuite/testswap/t/coding/pod_coverage.t

+#!/usr/bin/perl
+use Test::More;
+eval "use Test::Pod::Coverage 1.00";
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
+all_pod_coverage_ok();

testsuite/testswap/tbts

@@ -90,6 +90,15 @@ if (@ARGV) {
   if (/.*\.t$/ || /.*\.pm$/) { runharness(@ARGV); }
   elsif ($_ eq 'podc')      { system 'for x in `find lib -iname "*.pm"`; do podchecker $x 2>&1 |grep contain; done; '; }
   elsif ($_ eq 'pode')      { system 'for x in `find lib -iname "*.pm"`; do podchecker $x 2>&1 |grep ERROR; done;'; }
+
+  elsif ($_ eq 'pode')      {
+  eval { use Pod::Coverage; };
+  unless ($@) {
+    my $pc = Pod::Coverage->new(package => 'Pod::Coverage');
+    print "We rock!" if $pc->coverage == 1;
+  }
+
+}
   elsif (/critic/)          { exec 'perlcritic lib t'; }
   elsif (/sanity/)          { runharness( qw(t/lib/*.t t/lib/*/*.t t/xmlrpc/*.t)); }
   elsif (/lib/)             { runharness qw(t/lib/*.t t/lib/*/*.t); }