Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
[perl] Add syntactic sugar for creating test cases
Signed-off-by: Michael Brown <mbrown@fensystems.co.uk>
  • Loading branch information
mcb30 committed Dec 18, 2013
1 parent 9a6ca38 commit 8721027
Show file tree
Hide file tree
Showing 4 changed files with 152 additions and 21 deletions.
24 changes: 18 additions & 6 deletions perl/lib/qPXE/Test.pm
Expand Up @@ -21,6 +21,24 @@ use warnings;
=over
=item C<lab>
The C<qPXE::Lab> object representing the virtual test laboratory
in which the test is running.
=cut

has "lab" => (
is => "ro",
isa => "qPXE::Lab",
required => 1,
weak_ref => 1,
);

=item C<uuid_bin>
The test UUID, as a raw binary value.
=cut

has _uuidobj => (
Expand All @@ -35,12 +53,6 @@ method _build_uuidobj {
return Data::UUID->new();
}

=item C<uuid_bin>
The test UUID, as a raw binary value.
=cut

has uuid_bin => (
is => "ro",
isa => "Str",
Expand Down
24 changes: 24 additions & 0 deletions perl/lib/qPXE/Test/BasicDhcpHttp.pm
@@ -0,0 +1,24 @@
package qPXE::Test::BasicDhcpHttp;

use qPXE::Test::Sugar;
extends qw ( qPXE::Test );
has_machine qw ( cartman );
has_dut qw ( butters );

method execute () {

# Create DHCP reservation
$self->cartman->dhcpd->reserve (
$self->butters->name,
[ "hardware ethernet ".$self->butters->mac ( "primary" ).";",
"filename \"http://cartman/boot/demo.ipxe\";",
"option ipxe.testid ".$self->uuid_colons.";" ] );

# Start DUT
$self->butters->domain->create();

}

__PACKAGE__->meta->make_immutable();

1;
107 changes: 107 additions & 0 deletions perl/lib/qPXE/Test/Sugar.pm
@@ -0,0 +1,107 @@
package qPXE::Test::Sugar;

=head1 NAME
qPXE::Test::Sugar - Syntactic sugar for constructing test cases
=head1 SYNOPSIS
use qPXE::Test::Sugar;
extends qw ( qPXE::Test );
has_machine qw ( cartman );
has_dut qw ( butters );
method execute () {
$self->butters->domain->create();
}
=cut

use Moose ();
use MooseX::StrictConstructor ();
use MooseX::Method::Signatures;
use MooseX::MarkAsMethods autoclean => 1;
use Moose::Exporter;
use strict;
use warnings;

Moose::Exporter->setup_import_methods (
with_meta => [ 'has_machine', 'has_dut' ],
also => [ 'Moose', 'MooseX::StrictConstructor' ],
);

sub init_meta {
my $class = shift;
my %params = @_;
my $for_class = $params{for_class};

Moose->init_meta ( @_ );
MooseX::Method::Signatures->setup_for ( $for_class, {} );
MooseX::MarkAsMethods->import ( { into => $for_class }, autoclean => 1 );
}

=head1 EXPORTED FUNCTIONS
=over
=item C<< has_machine ( @machines ) >>
Creates attributes for each machine named in C<@machines>, providing a
shortcut for C<< $self->lab->machine($machine) >>.
=cut

sub has_machine {
my $meta = shift;
my @machines = @_;

foreach my $machine ( @machines ) {
my $builder = "_build_".$machine;

$meta->add_method ( $builder => method () {
return $self->lab->machine ( $machine );
} );

$meta->add_attribute ( $machine => ( is => "ro",
isa => "qPXE::Machine",
lazy => 1,
builder => $builder,
init_arg => undef ) );
}
}

=item C<< has_dut ( @duts ) >>
Creates attributes for each machine named in C<@duts>, as with
C<has_machine()>. Each machine is forced into an initial power-off
state.
=cut

sub has_dut {
my $meta = shift;
my @duts = @_;

foreach my $dut ( @duts ) {
my $builder = "_build_".$dut;

$meta->add_method ( $builder => method () {
# Ensure DUT starts out powered off
my $machine = $self->lab->machine ( $dut );
$machine->domain->destroy() if $machine->domain->is_active();
return $machine;
} );

$meta->add_attribute ( $dut => ( is => "ro",
isa => "qPXE::Machine",
lazy => 1,
builder => $builder,
init_arg => undef ) );
}
}

=back
=cut

1;
18 changes: 3 additions & 15 deletions perl/script/qpxe-demo
@@ -1,23 +1,11 @@
#!/usr/bin/perl -w

use qPXE::Lab;
use qPXE::Test;
use qPXE::Test::BasicDhcpHttp;
use strict;
use warnings;

my $lab = qPXE::Lab->new ( uri => "qemu:///system" );
my $cartman = $lab->machine ( "cartman" );
my $butters = $lab->machine ( "butters" );
my $test = qPXE::Test->new();
my $test = qPXE::Test::BasicDhcpHttp->new ( lab => $lab );

$butters->domain->destroy() if $butters->domain->is_active();

my $mac = $butters->mac ( "primary" );
my $testid = $test->uuid_colons;
$cartman->dhcpd->reserve ( $butters->name, <<"EOF" );
hardware ethernet $mac;
filename "http://cartman/boot/demo.ipxe";
option ipxe.testid $testid;
EOF

$butters->domain->create();
$test->execute();

0 comments on commit 8721027

Please sign in to comment.