Commit 89cfb775 authored by Kevin Tew's avatar Kevin Tew

testsuite/testswap Parameterization polish

parent f4a1938d
......@@ -12,7 +12,7 @@ our $XMLRPC_VERSION = "0.1";
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 = 'tbtest';
our $DEFAULT_PID = 'tbres';
our $DEFAULT_GID = '';
our $DEBUG_XML_CLIENT = $ENV{TBTS_DEBUG} || 0;
......
our $VERSION = '1.00';
use 5.008_000;
use strict;
use warnings;
our $VERSION = '1.00';
package SemiModern::Perl;
use IO::Handle;
use Scalar::Util 'openhandle';
......
......@@ -7,7 +7,84 @@ use Tools;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(e ep dpe dpge CartProd CartProdRunner concretize defaults);
our @EXPORT = qw(ee e pge dpe dpge CartProd CartProdRunner concretize defaults override);
sub ee { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid' => shift, 'eid' => shift) }
sub pge { TestBed::TestSuite::Experiment->new('pid' => shift, 'gid' => shift, 'eid' => shift) }
sub dpe { TestBed::TestSuite::Experiment->new('pid' => $TBConfig::DEFAULT_PID, 'eid' => shift) }
sub dpge { TestBed::TestSuite::Experiment->new(
'pid' => $TBConfig::DEFAULT_PID,
'gid' => ($TBConfig::DEFAULT_GID || $TBConfig::DEFAULT_PID),
'eid' => shift);
}
sub CartProd {
my $config = shift;
my %options;
if (@_ == 1) {
$options{'filter'} = $_[0];
}
else {
%options = @_;
}
#say Dumper($config);
my @a;
while (my ($k, $v) = each %$config) {
if ( @a ) {
my @b;
#say "induct";
map {
my $c = {$k => $_};
push @b, map {{ %$_, %$c}} @a;
} @$v;
#say Dumper(\@b);
@a = @b;
}
else {
#say "basis";
@a = map {{$k => $_}} @$v;
#say Dumper(\@a);
}
}
if (exists $options{'filter'}) {
my @newa;
@a = map {
my $result = $options{'filter'}->($_);
if ( defined $result ) {
if ( ref $result ) {
push @newa, $result;
}
elsif ( $result ) {
push @newa, $_;
}
}
} @a;
@a = @newa;
}
if (exists $options{'generator'}) {
@a = map &{$options{'generator'}}, @a;
}
@a;
}
sub CartProdRunner {
my $proc = shift;
for (CartProd(@_)) { $proc->($_); }
}
sub defaults {
my ($params, %defaults) = @_;
return { %defaults, %{($params || {})} };
}
sub override {
my ($params, %overrides) = @_;
return { %{($params || {})}, %overrides };
}
=head1 NAME
......@@ -23,12 +100,22 @@ creates a new empty experiment, for calling experiement "class methods" on
creates a new experiment with pid and eid
=item C<pge($pid, $gid, $eid)>
creates a new experiment with pid, gid, and eid
=item C<dpe($eid)>
new experiement takes one arg a eid and uses the default pid in TBConfig
=item C<dpge($eid)>
new experiement takes one arg a eid and uses the default pid and gid in TBConfig
=item C<CartProd($hashref)> Cartesian Product Runner
=item C<CartProd($hashref, &filter_gen_func)> Cartesian Product Runner
my $config = {
'OS' => [qw( AOS BOS COS )],
'HARDWARE' => [qw( AHW BHW CHW )],
......@@ -40,6 +127,9 @@ returns [ { OS => 'AOS', HARDWARE => 'AHW', LINKTYPE => 'ALT' },
...
]
takes an optional sub ref that acts as a filter
if &filter_gen_func returns undef or 0 the case is dropped from the result.
if &filter_gen_func returns a hash ref the has ref becomes the new case resutl.
=item C<CartProdRunner($sub, $hashref)> Cartesian Product Runner
......@@ -51,65 +141,16 @@ my $config = {
CartProdRunner(\&VNodeTest::VNodeTest, $config);
=back
=cut
=item C<defaults($hashref, %defaults)> provides default hash entries for a params hash ref
sub ep { TestBed::TestSuite::Experiment->new }
sub e { TestBed::TestSuite::Experiment->new('pid'=> shift, 'eid' => shift) }
sub dpe { TestBed::TestSuite::Experiment->new('pid'=> $TBConfig::DEFAULT_PID, 'eid' => shift) }
sub dpge {
my $gid = (!defined($TBConfig::DEFAULT_GID)
|| $TBConfig::DEFAULT_GID eq '')
? $TBConfig::DEFAULT_PID : $TBConfig::DEFAULT_GID;
TestBed::TestSuite::Experiment->new('pid' => $TBConfig::DEFAULT_PID,
'gid' => $gid,
'eid' => shift)
}
returns a modified hash ref
sub CartProd {
my ($config, %options) = @_;
#say Dumper($config);
my @a;
while (my ($k, $v) = each %$config) {
if ( @a ) {
my @b;
#say "induct";
map {
my $c = {$k => $_};
push @b, map {{ %$_, %$c}} @a;
} @$v;
#say Dumper(\@b);
@a = @b;
}
else {
#say "basis";
@a = map {{$k => $_}} @$v;
#say Dumper(\@a);
}
}
=item C<override($hashref, %overrides)> provides hash entry overrides for a params hash ref
if (exists $options{'filter'}) {
my @newa;
@a = map { if ($options{'filter'}->($_)) {
push @newa, $_;}
} @a;
@a = @newa;
}
returns a modified hash ref
if (exists $options{'generator'}) {
@a = map &{$options{'generator'}}, @a;
}
@a;
}
=back
sub CartProdRunner {
my ($proc, $config, %options) = @_;
for (CartProd($config, %options)) { $proc->($_); }
}
=cut
sub defaults {
my ($params, %defaults) = @_;
+{ %defaults, %{($params || {})} };
}
1;
......@@ -12,14 +12,14 @@ use TestBed::TestSuite;
use TestBed::TestSuite::Experiment;
use Test::More;
sub echo { ep()->echo(@_); }
sub echo { ee()->echo(@_); }
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 list { ee()->getlist; }
sub list_brief { ee()->getlist_brief; }
sub list_full { ee()->getlist_full; }
sub plistexps { pretty_listexp(list_full); }
=head1 NAME
......
......@@ -15,13 +15,10 @@ has 'eid' => ( isa => 'Str', is => 'rw');
sub args {
my $self = shift;
if (defined($self->gid) && $self->gid ne '') {
return { 'pid' => $self->pid, 'gid' => $self->gid,
'eid' => $self->eid, @_ };
}
else {
return { 'pid' => $self->pid, 'eid' => $self->eid, @_ };
}
my $args = { 'pid' => $self->pid, 'eid' => $self->eid };
my $gid = $self->gid;
$args->{'gid'} = $gid if $gid;
return { %$args, @_ };
}
sub echo { shift->augment_output( 'str' => shift ); }
......@@ -89,10 +86,6 @@ TestBed::XMLRPC::Client::Experiment
experiment pid
=item C<gid>
experiment gid
=item C<eid>
experiment eid
......
......@@ -22,7 +22,7 @@ sub pretty_listexp {
while(my ($gk, $v) = each %$v) {
for my $e (@$v) {
my $eid;
if ( exists $e->{'name'} ) { $eid = sprintf("%s %s", $e->{'name'}, $e->{'state'});}
if ( ref $e && exists $e->{'name'} ) { $eid = sprintf("%s %s", $e->{'name'}, $e->{'state'});}
else { $eid = $e; }
say "$pk :: $gk :: $eid";
}
......
......@@ -23,6 +23,7 @@ NSEND
sub usage {
say <<"END"
ShortCut
./sc CMD EID ARGS
CMD = start
......
......@@ -2,7 +2,7 @@
use SemiModern::Perl;
use TestBed::TestSuite;
use Data::Dumper;
use Test::More tests => 1;
use Test::More tests => 5;
my $a = {
'a' => [qw(a1 a2 a3)],
......@@ -10,8 +10,18 @@ my $a = {
'c' => [qw(c1 c2 c3)],
};
my $b = {
'a' => [qw(a1 a2)],
'b' => [qw(b1 b2)],
};
our $filter = sub {
($_->{'a'} eq 'a1');
return undef if ($_->{'a'} eq 'a1');
$_
};
our $filter2 = sub {
!($_->{'a'} eq 'a1');
};
our $gen = sub {
......@@ -22,7 +32,37 @@ our $gen = sub {
$_;
}
};
for (CartProd($a, 'filter' => $filter, 'generator' => $gen)) {
say Dumper($_);
sub hash_equals {
my ($a1, $a2) = @_;
while (my ($k, $v) = each %$a1) {
if ($a2->{$k} ne $v) {
say "$k $v " . $a2->{$k};
return 0;
}
}
return 1;
}
ok(1);
sub array_of_hash_equals {
my ($a1, $a2) = @_;
return 0 if ((scalar @$a1) != (scalar @$a2));
for (0 .. (@$a2 - 1)) {
return 0 unless hash_equals($a1->[$_], $a2->[$_]);
}
return 1;
}
my $expected1 = [ { 'a' => 'COOL', 'b' => 'b1' }, { 'a' => 'a2', 'b' => 'b2' } ];
my $expected2 = [ { 'a' => 'a2', 'b' => 'b1' }, { 'a' => 'a2', 'b' => 'b2' } ];
my @result1 = CartProd($b, 'filter' => $filter, 'generator' => $gen);
ok(array_of_hash_equals( $expected1, \@result1), 'CartProd($config, filter => $f, generator => $g)');
#say Dumper($_) for (@result);
my @result2 = CartProd($b, 'filter' => $filter2);
ok(array_of_hash_equals( $expected2, \@result2), 'CartProd($config, filter => $f_and_gen)');
@result2 = CartProd($b, $filter2);
ok(array_of_hash_equals( $expected2, \@result2), 'CartProd($config, $filter_and_gen)');
#say Dumper($_) for (@result2);
ok(hash_equals( defaults({ 'a' => 'B' }, 'a' => 'A', b => 'B'), { 'a' => 'B', 'b' => 'B' } ), 'defaults1');
ok(hash_equals( override({ 'a' => 'B' }, 'a' => 'A', b => 'B'), { 'a' => 'A', 'b' => 'B' } ), 'override1');
......@@ -51,16 +51,30 @@ my $THARNESS = 'perl t/harness';
sub usage {
our $ts;
sub wanted {
our $tpms;
sub wanted_t {
if (-f && /\.t$/) {
$ts .= " " . $File::Find::name . "\n";
}
}
sub wanted_tests {
if (-f && /\.pm$/) {
$tpms .= " " . $File::Find::name . "\n";
}
}
use File::Find;
find(\&wanted, 't');
find(\&wanted_t, 't');
find(\&wanted_tests, 'tests');
print <<"USAGE";
./tbts
TestBed TestSwap
./tbts OPTIONS TESTSUITE|TESTFILE
-j --jobs=i parallel jobs
-d --debug
-t --timing
-v --verbose
TESTSUITES:
test - all topology tests
sanity - all framework utility and xmlrpc client modules test
lib - all framework utility tests
......@@ -69,25 +83,25 @@ sub usage {
critic - runs perl critic on framework code
coding -
TESTFILES:
USAGE
print $ts;
print $tpms;
}
if (@ARGV) {
my $cmd = $ARGV[0];
$_ = $cmd;
chomp $_;
if (/.*\.t$/ || /.*\.pm/) {
exec "$THARNESS $cmd";
}
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 (/critic/) { exec 'perlcritic lib t'; }
elsif (/codingtests/) { }
elsif (/sanity/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t t/xmlrpc/*.t "; }
elsif (/lib/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t"; }
elsif (/xmlrpc/) { exec "$THARNESS t/xmlrpc/*.t"; }
elsif (/test/) { exec "$THARNESS t/topologies/*.t"; }
if (/.*\.t$/ || /.*\.pm/) { exec "$THARNESS $cmd"; }
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 (/critic/) { exec 'perlcritic lib t'; }
elsif (/codingtests/) { }
elsif (/sanity/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t t/xmlrpc/*.t "; }
elsif (/lib/) { exec "$THARNESS t/lib/*.t t/lib/*/*.t"; }
elsif (/xmlrpc/) { exec "$THARNESS t/xmlrpc/*.t"; }
elsif (/test/) { exec "$THARNESS t/topologies/*.t"; }
}
else {
print usage();
......
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