[perl] Initial commit

Add base functionality for creating abstractions of the virtual test
laboratory, test machines, test networks, and test cases, along with a
proof of concept demo which extracts the MAC address from the DUT,
creates a DHCP reservation, and boots the DUT.

Signed-off-by: Michael Brown <mbrown@fensystems.co.uk>

.gitignore

@@ -0,0 +1,11 @@
+Makefile
+META.yml
+MYMETA.yml
+MYMETA.json
+inc
+blib
+pm_to_blib
+MANIFEST
+*.bak
+*.old
+*.tar.gz

perl/Makefile.PL

@@ -0,0 +1,25 @@
+use inc::Module::Install;
+
+name "qPXE";
+license "perl";
+all_from "lib/qPXE.pm";
+build_requires "Test::More";
+build_requires "Test::Exception";
+build_requires "Test::Pod";
+install_script "qpxe-dhcpd", "qpxe-demo";
+
+requires "Carp";
+requires "Carp::Clan";
+requires "Moose";
+requires "Moose::Util::TypeConstraints";
+requires "MooseX::StrictConstructor";
+requires "MooseX::Method::Signatures";
+requires "MooseX::MarkAsMethods";
+requires "Class::Load";
+requires "Sys::Virt";
+requires "XML::LibXML";
+requires "Net::SSH::Perl";
+requires "Net::SFTP";
+requires "Data::UUID";
+
+WriteAll;

perl/lib/qPXE.pm

@@ -0,0 +1,25 @@
+package qPXE;
+
+=head1 NAME
+
+qPXE - Automated QA testing for iPXE (http://ipxe.org)
+
+=head1 AUTHOR
+
+Michael Brown <mbrown@fensystems.co.uk>
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+use namespace::autoclean;
+use strict;
+use warnings;
+
+use 5.010;
+our $VERSION = "0.1";
+
+1;

perl/lib/qPXE/Dhcpd.pm

@@ -0,0 +1,124 @@
+package qPXE::Dhcpd;
+
+=head1 NAME
+
+qPXE::Dhcpd - An instance of ISC DHCPD
+
+=head1 SYNOPSIS
+
+    use qPXE::Lab;
+
+    my $lab = qPXE::Lab->new ( uri => "qemu:///system" );
+    my $machine = $lab->machine ( "cartman" );
+    my $dhcpd = $cartman->dhcpd;
+
+    $dhcpd->reserve ( "butters", [
+      "hardware ethernet 52:54:00:12:34:56;",
+      "filename \"pxelinux.0\";",
+    ] );
+
+=cut
+
+use Moose;
+use MooseX::StrictConstructor;
+use MooseX::Method::Signatures;
+use MooseX::MarkAsMethods autoclean => 1;
+use File::Temp;
+use Carp;
+use strict;
+use warnings;
+
+=head1 ATTRIBUTES
+
+=over
+
+=item C<machine>
+
+The <qPXE::Machine> object representing the machine running DHCPD.
+
+=cut
+
+has "machine" => (
+  is => "ro",
+  isa => "qPXE::Machine",
+  required => 1,
+  weak_ref => 1,
+);
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item C<< reserve ( $host, $config ) >>
+
+Create a reservation for the specified C<$host>, containing the raw
+configuration data C<$config> (which can be a single string or an
+array of strings).
+
+=cut
+
+method _reservation_filename ( Str $host ) {
+  return "/etc/dhcpd.d/".$host.".conf";
+}
+
+method reserve ( Str $host, Str | ArrayRef[Str] $config ) {
+
+  # Construct reservation fragment
+  my $reservation = "host ".$host. " {";
+  if ( ref $config ) {
+    $reservation .= join ( "", map { "\n\t".$_ } @$config );
+  } else {
+    $reservation .= "\n\t".$config;
+  }
+  $reservation .= "\n};\n";
+
+  # Generate temporary file containing the reservation
+  my $tempfile = File::Temp->new();
+  $tempfile->print ( $reservation );
+  $tempfile->flush();
+
+  # Copy reservation fragment to server
+  $self->machine->upload ( $tempfile, $self->_reservation_filename ( $host ) );
+
+  # Reload DHCPD configuration
+  $self->reload();
+}
+
+=item C<< release ( $host ) >>
+
+Delete the reservation (if any) for the specified C<$host>.
+
+=cut
+
+method release ( Str $host ) {
+
+  # Remove reservation fragment
+  $self->machine->upload ( undef, $self->_reservation_filename ( $host ) );
+
+  # Reload DHCPD configuration
+  $self->reload();
+}
+
+=item C<< reload() >>
+
+Reload the DHCPD configuration.
+
+=cut
+
+method reload () {
+
+  # Use qpxe-dhcpd script to regenerate /etc/dhcpd.d.conf and restart DHCPD
+  ( my $out, my $err, my $rc ) =
+      $self->machine->ssh->cmd ( "/usr/sbin/qpxe-dhcpd" );
+  die "Could not reload DHCPD configuration: $rc\n" if $rc;
+}
+
+=back
+
+=cut
+
+__PACKAGE__->meta->make_immutable();
+
+1;

perl/lib/qPXE/Lab.pm

@@ -0,0 +1,145 @@
+package qPXE::Lab;
+
+=head1 NAME
+
+qPXE::Lab - The virtual test laboratory
+
+=head1 SYNOPSIS
+
+    use qPXE::Lab;
+
+    my $lab = qPXE::Lab->new ( uri => "qemu:///system" );
+    my $machine = $lab->machine ( "butters" );
+
+=cut
+
+use Moose;
+use MooseX::StrictConstructor;
+use MooseX::Method::Signatures;
+use MooseX::MarkAsMethods autoclean => 1;
+use Class::Load qw ( :all );
+use Sys::Virt;
+use qPXE::Machine;
+use qPXE::Network;
+use strict;
+use warnings;
+
+=head1 ATTRIBUTES
+
+=over
+
+=item C<uri>
+
+URI of the virtual machine monitor, as used by C<< Sys::Virt->new() >>.
+
+=cut
+
+has uri => (
+  is => "ro",
+  isa => "Str",
+  required => 1,
+);
+
+=item C<vmm>
+
+The C<Sys::Virt> object representing the virtual machine monitor.
+
+=cut
+
+has vmm => (
+  is => "ro",
+  isa => "Sys::Virt",
+  lazy => 1,
+  builder => "_build_vmm",
+  init_arg => undef,
+);
+
+method _build_vmm () {
+  return Sys::Virt->new ( uri => $self->uri );
+}
+
+=item C<domainname>
+
+The DNS domain name used for constructing hostnames via the
+C<hostname()> method.
+
+=cut
+
+has domainname => (
+  is => "ro",
+  isa => "Maybe[Str]",
+  required => 1,
+  default => undef,
+);
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item C<< machine ( $name ) >>
+
+Obtain a C<qPXE::Machine> object representing the machine named
+C<$name>.
+
+If the machine-specific subclass C<< qPXE::Machine::C<$name> >>
+exists, the returned object will automatically be created with that
+subclass.
+
+=cut
+
+method machine ( Str $name ) {
+
+  # Look for an optional machine-specific class
+  my $baseclass = "qPXE::Machine";
+  my $subclass = $baseclass."::".$name;
+  my $class = ( load_optional_class ( $subclass ) ?
+		$subclass : $baseclass );
+
+  # Construct machine
+  return $class->new (
+    lab => $self,
+    domain => $self->vmm->get_domain_by_name ( $name ),
+  );
+}
+
+=item C<< network ( $name ) >>
+
+Obtain a C<qPXE::Network> object representing the network named
+C<$name>.
+
+=cut
+
+method network ( Str $name ) {
+  return qPXE::Network->new (
+    lab => $self,
+    network => $self->vmm->get_network_by_name ( $name ),
+  );
+}
+
+=item C<< hostname ( $machine ) >>
+
+Construct a hostname which can be used for direct access to the
+specified machine (which can be a C<qPXE::Machine> object or a machine
+name).
+
+=cut
+
+method hostname ( qPXE::Machine | Str $machine ) {
+
+  # Allow calling with either a machine object or a machine name, and
+  # ensure that the machine exists within the laboratory.
+  $machine = $self->machine ( $machine ) unless blessed ( $machine );
+
+  return ( $self->domainname ?
+	   $machine->name.".".$self->domainname : $machine->name );
+}
+
+=back
+
+=cut
+
+__PACKAGE__->meta->make_immutable();
+
+1;