Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
emulab
emulab-devel
Commits
25229e6c
Commit
25229e6c
authored
Jun 04, 2009
by
Kevin Tew
Browse files
testsuite/testswap subroutine documentation
parent
340f10a4
Changes
18
Hide whitespace changes
Inline
Side-by-side
testsuite/testswap/lib/SemiModern/Perl.pm
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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<launchping
swap
kill($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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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<say
s
ts($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
View file @
25229e6c
...
...
@@ -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
View file @
25229e6c
...
...
@@ -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
0 → 100644
View file @
25229e6c
#!/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
View file @
25229e6c
...
...
@@ -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)
;
}
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment