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
1bd26823
Commit
1bd26823
authored
May 14, 2009
by
Kevin Tew
Browse files
testsuite/testswap added ensure_swaped_ns, simplifying parallel run
parent
4bce536a
Changes
18
Hide whitespace changes
Inline
Side-by-side
testsuite/testswap/TODO
View file @
1bd26823
...
...
@@ -10,6 +10,10 @@ TODO
convert more old tests
general result code handling framework
STILL MESSY
XMLRPC/Client/Experiment TestSuite/Experiment return codes, exceptions, composability
Calling parallel tests
EXPAND CURRENT IMPLEMENTATION
event subsystem
parallel support (custom test harness)
...
...
@@ -23,12 +27,13 @@ LATER
create BSD virtual machine for testing
possibly collapse tbts and t/harness
Parallel TODOS
retry
clean up FFF, Roles, constructors
CartProd teste - image test example
DONE
POD function documentation
better general result code handling (ping_test single_node_test)
ForkFramework Constants
Parallel TODOS
retry
clean up FFF, Roles, constructors
CartProd teste - image test example
testsuite/testswap/lib/TestBed/ForkFramework.pm
View file @
1bd26823
...
...
@@ -102,6 +102,8 @@ sub workloop {
redo
LOOP
;
}
}
waitpid
(
$_
,
0
)
for
@
{
$self
->
workers
};
my
@results
=
(
scalar
@
{
$self
->
errors
},
$self
->
results
,
$self
->
errors
);
return
wantarray
?
@results
:
\
@results
;
}
...
...
testsuite/testswap/lib/TestBed/
TestExperiment
.pm
→
testsuite/testswap/lib/TestBed/
ParallelRunner
.pm
View file @
1bd26823
...
...
@@ -26,18 +26,14 @@ sub _initialize {
}
package
TestBed::
TestExperiment
;
package
TestBed::
ParallelRunner
;
use
SemiModern::
Perl
;
use
TestBed::
TestExperiment
::
Test
;
use
TestBed::
ParallelRunner
::
Test
;
use
TestBed::
ForkFramework
;
use
Data::
Dumper
;
my
$ExperimentTests
=
[]
;
require
Exporter
;
our
@ISA
=
qw(Exporter)
;
our
@EXPORT
=
qw(teste runtests)
;
my
$teste_desc
=
<<'END';
Not enough arguments to teste
teste(eid, $ns, $sub, $test_count, $desc);
...
...
@@ -45,13 +41,7 @@ Not enough arguments to teste
teste($pid, $gid, $eid, $ns, $sub, $test_count, $desc);
END
sub
teste
{
if
(
@
_
==
4
)
{
push
@$ExperimentTests
,
TestBed::TestExperiment::Test::
tn
('',
'',
'',
@
_
);
}
elsif
(
@
_
==
5
)
{
push
@$ExperimentTests
,
TestBed::TestExperiment::Test::
tn
('',
'',
@
_
);
}
elsif
(
@
_
==
6
)
{
push
@$ExperimentTests
,
TestBed::TestExperiment::Test::
tn
(
shift
,
'',
@
_
);
}
elsif
(
@
_
==
7
)
{
push
@$ExperimentTests
,
TestBed::TestExperiment::Test::
tn
(
@
_
);
}
else
{
die
$teste_desc
;
}
}
sub
add_experiment
{
push
@$ExperimentTests
,
TestBed::ParallelRunner::Test::
tn
(
@
_
);
}
sub
runtests
{
#prep step
...
...
@@ -62,7 +52,7 @@ sub runtests {
},
$ExperimentTests
);
if
(
$result
->
[
0
])
{
sayd
(
$result
->
[
2
]);
die
'
TestBed::
TestExperiment
::runtests died during test prep
';
die
'
TestBed::
ParallelRunner
::runtests died during test prep
';
}
#create schedule step
...
...
@@ -96,6 +86,15 @@ sub reset_test_builder {
else
{
$b
->
no_plan
;
}
}
sub
setup_test_builder_ouputs
{
my
(
$out
,
$err
)
=
@_
;
use
Test::
Builder
;
my
$b
=
Test::
Builder
->
new
;
$b
->
output
(
$out
);
$b
->
fail_output
(
$out
);
$b
->
todo_output
(
$out
);
}
use
Carp
;
$SIG
{
__DIE__
}
=
sub
{
Carp::
confess
(
@
_
)
};
...
...
@@ -117,6 +116,7 @@ sub tap_wrapper {
},
sub
{
reset_test_builder
(
$te
->
test_count
)
if
$SUBTESTS
;
setup_test_builder_ouputs
(
*STDOUT
,
*STDERR
);
$te
->
run_ensure_kill
;
});
}
...
...
testsuite/testswap/lib/TestBed/
TestExperiment
/Test.pm
→
testsuite/testswap/lib/TestBed/
ParallelRunner
/Test.pm
View file @
1bd26823
#!/usr/bin/perl
package
TestBed::
TestExperiment
::
Test
;
package
TestBed::
ParallelRunner
::
Test
;
use
SemiModern::
Perl
;
use
TestBed::TestSuite::
Experiment
;
use
Mouse
;
...
...
@@ -12,12 +12,8 @@ has 'proc' => ( isa => 'CodeRef', is => 'rw');
has
'
test_count
'
=>
(
isa
=>
'
Any
',
is
=>
'
rw
');
sub
tn
{
my
(
$pid
,
$gid
,
$eid
,
$ns
,
$sub
,
$test_count
,
$desc
)
=
@_
;
my
$e
=
TestBed::TestSuite::
Experiment
->
new
(
'
pid
'
=>
$pid
,
'
gid
'
=>
$gid
,
'
eid
'
=>
$eid
);
return
TestBed::TestExperiment::
Test
->
new
(
my
(
$e
,
$ns
,
$sub
,
$test_count
,
$desc
)
=
@_
;
return
TestBed::ParallelRunner::
Test
->
new
(
'
e
'
=>
$e
,
'
ns
'
=>
$ns
,
'
desc
'
=>
$desc
,
...
...
@@ -27,7 +23,9 @@ sub tn {
sub
prep
{
my
$self
=
shift
;
$self
->
e
->
create_and_get_metadata
(
$self
->
ns
);
my
$r
=
$self
->
e
->
create_and_get_metadata
(
$self
->
ns
);
#sayd($r);
$r
;
}
sub
run
{
...
...
testsuite/testswap/lib/TestBed/TestSuite.pm
View file @
1bd26823
...
...
@@ -2,14 +2,26 @@
package
TestBed::
TestSuite
;
use
SemiModern::
Perl
;
use
TestBed::TestSuite::
Experiment
;
use
TestBed::
ParallelRunner
;
use
Data::
Dumper
;
use
Tools
;
require
Exporter
;
our
@ISA
=
qw(Exporter)
;
our
@EXPORT
=
qw(e
dpge
CartProd CartProdRunner concretize defaults override)
;
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
();
}
elsif
(
@
_
==
5
)
{
$e
=
e
(
shift
);
}
elsif
(
@
_
==
6
)
{
$e
=
e
(
shift
,
shift
);
}
elsif
(
@
_
==
7
)
{
$e
=
e
(
shift
,
shift
,
shift
);
}
else
{
die
'
Too many args to rege
';
}
return
TestBed::ParallelRunner::
add_experiment
(
$e
,
@
_
);
}
sub
runtests
{
TestBed::ParallelRunner::
runtests
;
}
sub
_build_e_from_positionals
{
if
(
@
_
==
0
)
{
return
{};
}
...
...
testsuite/testswap/lib/TestBed/TestSuite/Experiment.pm
View file @
1bd26823
...
...
@@ -11,13 +11,7 @@ use TestBed::TestSuite;
use
TestBed::TestSuite::
Node
;
use
TestBed::TestSuite::
Link
;
extends
'
Exporter
',
'
TestBed::XMLRPC::Client::Experiment
';
has
'
ns
'
=>
(
isa
=>
'
Str
',
is
=>
'
rw
');
require
Exporter
;
our
@EXPORT
;
push
@EXPORT
,
qw(launchpingkill launchpingswapkill)
;
extends
'
TestBed::XMLRPC::Client::Experiment
';
=head1 NAME
...
...
@@ -156,7 +150,7 @@ sub startrun {
=item C<launchpingkill($e, $ns)>
class
method that starts an experiment, runs a ping_test, and ends the experiment
method that starts an experiment, runs a ping_test, and ends the experiment
=cut
sub
launchpingkill
{
my
(
$e
,
$ns
)
=
@_
;
...
...
@@ -170,7 +164,7 @@ sub launchpingkill {
=item C<launchpingkill($e, $ns)>
class
method that starts an experiment, runs a ping_test,
method that starts an experiment, runs a ping_test,
swaps the experiment out and then back in, runs a ping test, and finally
ends the experiment
=cut
...
...
@@ -187,6 +181,24 @@ trytest {
}
$e
;
}
=item C<pingkill($e)>
method that runs a ping_test,
swaps the experiment out and then back in, runs a ping test, and finally
ends the experiment
=cut
sub
pingswapkill
{
my
(
$e
)
=
@_
;
my
$eid
=
$e
->
eid
;
trytest
{
$e
->
ping_test
&&
die
"
connectivity test
$eid
failed
";
$e
->
swapout_wait
&&
die
"
swap out
$eid
failed
";
$e
->
swapin_wait
&&
die
"
swap in
$eid
failed
";
$e
->
ping_test
&&
die
"
connectivity test
$eid
failed
";
$e
->
end
&&
die
"
exp end
$eid
failed
";
}
$e
;
}
=back
=cut
...
...
testsuite/testswap/lib/TestBed/XMLRPC/Client/Experiment.pm
View file @
1bd26823
...
...
@@ -33,21 +33,14 @@ sub args {
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
modify_ns
{
shift
->
augment
(
'
nsfilestr
'
=>
shift
,
@
_
);
}
sub
batchexp_ns
{
shift
->
augment
_code
(
'
nsfilestr
'
=>
shift
,
@
_
);
}
sub
modify_ns
{
shift
->
augment
_code
(
'
nsfilestr
'
=>
shift
,
@
_
);
}
sub
swapin
{
shift
->
augment_func_code
(
'
swapexp
',
'
direction
'
=>
'
in
'
);
}
sub
swapout
{
shift
->
augment_func_code
(
'
swapexp
',
'
direction
'
=>
'
out
'
);
}
sub
end
{
shift
->
augment_func_code
(
'
endexp
'
);
}
sub
nodeinfo
{
parseNodeInfo
(
shift
->
augment_func_output
('
expinfo
',
'
show
'
=>
'
nodeinfo
'));
}
sub
waitforactive
{
my
$self
=
shift
;
$self
->
augment_code
(
@
_
)
&&
die
sprintf
("
wait for swapin %s failed
",
$self
->
eid
);
}
sub
waitforswapped
{
my
$self
=
shift
;
$self
->
augment_func_code
(
'
statewait
',
'
state
'
=>
'
swapped
'
)
&&
die
sprintf
("
wait for swapin %s failed
",
$self
->
eid
);
}
sub
waitforactive
{
shift
->
augment_code
(
@
_
)
}
sub
waitforswapped
{
shift
->
augment_func_code
(
'
statewait
',
'
state
'
=>
'
swapped
'
)
}
sub
startexp_ns
{
batchexp_ns
(
@
_
,
'
batch
'
=>
0
);
}
sub
startexp_ns_wait
{
batchexp_ns_wait
(
@
_
,
'
batch
'
=>
0
);
}
...
...
@@ -60,14 +53,25 @@ sub create_and_get_metadata {
sub
batchexp_ns_wait
{
my
$self
=
shift
;
$self
->
batchexp_ns
(
@
_
);
my
$rc
=
$self
->
batchexp_ns
(
@
_
);
if
(
$rc
)
{
return
$rc
}
$self
->
waitforactive
;
}
use
constant
EXPERIMENT_NAME_ALREADY_TAKEN
=>
2
;
sub
ensure_active_ns
{
my
$self
=
shift
;
my
$rc
=
$self
->
batchexp_ns
(
@
_
);
if
(
$rc
&&
$rc
!=
EXPERIMENT_NAME_ALREADY_TAKEN
)
{
return
$rc
}
$self
->
waitforactive
;
}
sub
swapin_wait
{
my
$self
=
shift
;
$self
->
augment_func_code
(
'
swapexp
',
'
direction
'
=>
'
in
',
'
wait
'
=>
1
);
$self
->
waitforactive
;
}
sub
swapout_wait
{
my
$self
=
shift
;
$self
->
augment_func_code
(
'
swapexp
',
'
direction
'
=>
'
out
',
'
wait
'
=>
1
);
...
...
testsuite/testswap/t/examples/parallel.t
View file @
1bd26823
#! /usr/bin/perl
use
TestBed::
Test
Experiment
;
use
TestBed::
Test
Suite
;
use
RateLimitParallelExample
;
# run all the test
methods in
Example
::Test
TestBed::
TestExperiment
->
runtests
;
# run all the test
s in RateLimitParallel
Example
runtests
;
testsuite/testswap/t/livetests/ensure_active.t
0 → 100644
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TestBed::
TestSuite
;
use
Test::
More
tests
=>
3
;
use
Data::
Dumper
;
use
BasicNSs
;
my
$e
=
e
('
ensureactive
');
=pod
ok(!$e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'first start');
ok($e->startexp_ns_wait($BasicNSs::TwoNodeLan), 'failed second start');
ok(!$e->ensure_active_ns($BasicNSs::TwoNodeLan), 'ensure active_start');
ok(!$e->end);
=cut
sleep
(
5
);
system
('
./sc
');
ok
(
!
$e
->
ensure_active_ns
(
$
BasicNSs::
TwoNodeLan
),
'
ensure active_start
');
ok
(
$e
->
startexp_ns_wait
(
$
BasicNSs::
TwoNodeLan
),
'
failed second start
');
ok
(
!
$e
->
end
);
testsuite/testswap/t/old/old.t
View file @
1bd26823
...
...
@@ -21,5 +21,5 @@ for (@who_knows) {
my
$ns
=
$
Testbed::OldTestSuite::
data
->
{
$_
}
->
{'
nsfile
'};
say
"
Running
"
.
$_
;
say
$ns
;
ok
(
launchpingkill
(
e
(
$_
),
$ns
),
$_
);
ok
(
e
(
$_
)
->
launchpingkill
(
$ns
),
$_
);
}
testsuite/testswap/t/parallel/basic_topologies.t
0 → 100644
View file @
1bd26823
#! /usr/bin/perl
use
TestBed::
TestSuite
;
use
BasicTopologies
;
# run all the tests in RateLimitParallelExample
runtests
;
testsuite/testswap/t/topologies/link_up_link_down.t
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TBConfig
;
use
TestBed::
TestSuite
;
use
Test::
More
tests
=>
5
;
use
Data::
Dumper
;
...
...
testsuite/testswap/t/topologies/simple_two_node_linktest.t
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TBConfig
;
use
TestBed::
TestSuite
;
use
Test::
More
tests
=>
1
;
use
Data::
Dumper
;
...
...
testsuite/testswap/t/topologies/single_node.t
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TestBed::
TestSuite
;
use
TestBed::TestSuite::
Experiment
;
use
Test::
More
tests
=>
1
;
use
Data::
Dumper
;
...
...
@@ -15,4 +14,4 @@ set node1 [$ns node]
$ns run
NSEND
ok
(
launchpingswapkill
(
e
('
tewkt
'),
$ns
));
ok
(
e
('
tewkt
')
->
launchpingswapkill
(
$ns
));
testsuite/testswap/t/topologies/two_node_lan.t
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TestBed::
TestSuite
;
use
TestBed::TestSuite::
Experiment
;
use
Test::
More
tests
=>
1
;
use
Data::
Dumper
;
...
...
@@ -17,4 +16,4 @@ set lan1 [$ns make-lan "$node1 $node2" 100Mb 0ms]
$ns run
NSEND
ok
(
launchpingswapkill
(
e
('
tewkt
'),
$ns
));
ok
(
e
('
tewkt
')
->
launchpingswapkill
(
$ns
));
testsuite/testswap/tests/BasicNSs.pm
View file @
1bd26823
...
...
@@ -10,7 +10,42 @@ set ns [new Simulator]
set
node1
[
$ns
node
]
set
node2
[
$ns
node
]
set
lan1
[
$ns
make
-
lan
"
$node1
$node2
"
100
Mb
0
ms
]
$ns
run
END
our
$TwoNodeLan5Mb
=
<<
'
END
';
source
tb_compat
.
tcl
set
ns
[
new
Simulator
]
set
node1
[
$ns
node
]
set
node2
[
$ns
node
]
set
lan1
[
$ns
make
-
lan
"
$node1
$node2
"
5
Mb
20
ms
]
$ns
run
END
our
$SingleNode
=
<<
'
END
';
source
tb_compat
.
tcl
set
ns
[
new
Simulator
]
set
node1
[
$ns
node
]
$ns
run
END
our
$TwoNodeLanWithLink
=
<<
'
END
';
source
tb_compat
.
tcl
set
ns
[
new
Simulator
]
set
node1
[
$ns
node
]
set
node2
[
$ns
node
]
set
lan1
[
$ns
make
-
lan
"
$node1
$node2
"
5
Mb
20
ms
]
set
link1
[
$ns
duplex
-
link
$node1
$node2
100
Mb
50
ms
DropTail
]
$ns
run
END
...
...
testsuite/testswap/tests/BasicTopologies.pm
0 → 100644
View file @
1bd26823
#!/usr/bin/perl
use
SemiModern::
Perl
;
use
TestBed::
TestSuite
;
use
BasicNSs
;
use
Test::
More
tests
=>
4
;
use
Data::
Dumper
;
my
$linkupdowntest
=
sub
{
my
(
$e
)
=
@_
;
my
$eid
=
$e
->
eid
;
ok
(
$e
->
linktest
,
"
$eid
linktest
");
ok
(
$e
->
link
("
link1
")
->
down
,
"
link down
");
sleep
(
2
);
my
$n1ssh
=
$e
->
node
("
node1
")
->
ssh
;
ok
(
$n1ssh
->
cmdfailuredump
("
ping -c 5 10.1.2.3
"));
ok
(
$e
->
link
("
link1
")
->
up
,
"
link up
");
sleep
(
2
);
ok
(
$n1ssh
->
cmdsuccessdump
("
ping -c 5 10.1.2.3
"));
};
rege
('
linkupdown
',
$
BasicNSs::
TwoNodeLanWithLink
,
$linkupdowntest
,
5
,
'
link up and down with ping on link
');
my
$twonodelan5Mbtest
=
sub
{
my
(
$e
)
=
@_
;
my
$eid
=
$e
->
eid
;
ok
(
$e
->
linktest
,
"
$eid
linktest
");
};
rege
('
2nodelan5Mb
',
$
BasicNSs::
TwoNodeLan5Mb
,
$twonodelan5Mbtest
,
1
,
'
two node 5mb lan pingswapkill
');
rege
('
singlenode
',
$
BasicNSs::
SingleNode
,
sub
{
ok
(
shift
->
pingswapkill
);
},
1
,
'
single node pingswapkill
');
rege
('
2nodelan
',
$
BasicNSs::
TwoNodeLan
,
sub
{
ok
(
shift
->
pingswapkill
);
},
1
,
'
two node lan pingswapkill
');
1
;
testsuite/testswap/tests/RateLimitParallelExample.pm
View file @
1bd26823
#!/usr/bin/perl
package
RateLimitParallelExample
;
use
TestBed::
Test
Experiment
;
use
TestBed::
Test
Suite
;
use
BasicNSs
;
use
Test::
More
;
...
...
@@ -9,6 +9,6 @@ my $test_body = sub {
ok
(
!
(
$e
->
ping_test
),
'
Ping Test
');
};
#$eid, $ns, $test_desc, $ns, $desc)
teste
("
k
$_
",
$
BasicNSs::
TwoNodeLan
,
$test_body
,
1
,
"
k
$_
desc
"
)
for
(
1
..
2
);
rege
("
k
$_
",
$
BasicNSs::
TwoNodeLan
,
$test_body
,
1
,
"
k
$_
desc
"
)
for
(
1
..
2
);
1
;
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