Commit cf0c7fd4 authored by Daniel P. Berrange's avatar Daniel P. Berrange

Initial code for technology compatability kit

parents
.*~$
^pm_to_blib$
^Makefile$
^Makefile\.old$
#.*#$
^blib/
Sys-Virt-TCK-.*
^MANIFEST$
.*\.bak$
^results/
^data/
^META.yml$
This diff is collapsed.
pm_to_blib
.*\.old
.*\.bak
Sys-Virt-TCK-
blib
\.hg
.*~
\.#.*
#.*
^Makefile$
.*\.orig
data/
results/
# Copyright (C) 2008 Daniel Berrange <dan@berrange.com>
use strict;
use warnings;
die unless (scalar @ARGV == 1);
open SRC, "lib/Sys/Virt/TCK.pm"
or die "lib/Sys/Virt/TCK.pm: $!";
our $VERSION;
while (<SRC>) {
if (/\$VERSION\s*=\s*'(.*)'/) {
$VERSION=$1;
}
}
close SRC;
local $/ = undef;
$_ = <DATA>;
s/\@VERSION\@/$VERSION/g;
open SPEC, ">$ARGV[0]" or die "$!";
print SPEC $_;
close SPEC;
__DATA__
--- #YAML:1.0
name: Sys-Virt-TCK
version: @VERSION@
abstract: libvirt Technology Compatability Kit
license: GPLv2+
author:
- Daniel Berrange <dan@berrange.com>
generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
App::Prove: 3.11
Config::Record: 0
IO::String: 0
TAP::Formatter::HTML: 0
TAP::Harness: 3.11
TAP::Harness::Archive: 0
Sys::Virt: 0.2.0
XML::Twig: 0
XML::Writer: 0
build_requires:
Test::More: 0
Test::Pod: 0
Test::Pod::Coverage: 0
resources:
license: http://www.gnu.org/licenses/gpl.html
homepage: http://libvirt.org/
repository: http://libvirt.org/hg/libvirt-tck
MailingList: http://www.redhat.com/mailman/listinfo/libvir-list
meta-spec:
version: 1.4
url: http://module-build.sourceforge.net/META-spec-v1.4.html
#!/usr/bin/perl
#
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'Sys::Virt::TCK',
'VERSION_FROM' => 'lib/Sys/Virt/TCK.pm',
'PREREQ_PM' => {
'App::Prove' => 3.11,
'Config::Record' => 0,
'IO::String' => 0,
'Sys::Virt' => 0.2.0,
'TAP::Formatter::HTML' => 0,
'TAP::Harness' => 3.11,
'TAP::Harness::Archive' => 0,
'Test::More' => 0,
'XML::Twig' => 0,
'XML::Writer' => 0,
},
'AUTHOR' => 'Daniel Berrange <dan@berrange.com>',
'NO_META' => 1,
'depend' => {
Sys-Virt-TCK.spec => '$(VERSION_FROM)',
Makefile => '$(VERSION_FROM)',
},
'realclean' => {
FILES => 'Sys-Virt-TCK.spec',
},
);
package MY;
sub libscan
{
my ($self, $path) = @_;
($path =~ /\~$/ || $path =~ m,/CVS/,) ? undef : $path;
}
__END__
libvirt TCK : Technology Compatability Kit
===========================================
The libvirt TCK provides a framework for performing testing
of the integration between libvirt drivers, the underlying virt
hypervisor technology, related operating system services and system
configuration. The idea (and name) is motivated by the Java TCK
In particular the libvirt TCK is intended to address the following
scenarios
- Validate that a new libvirt driver is in compliance
with the (possibly undocumented!) driver API semantics
- Validate that an update to an existing driver does not
change the API semantics in a non-compliant manner
- Validate that a new hypervisor release is still providing
compatability with the corresponding libvirt driver usage
- Validate that an OS distro deployment consisting of a
hypervisor and libvirt release is configured correctly
Thus the libvirt TCK will allow developers, administrators and users
to determine the level of compatability of their platform, and
evaluate whether it will meet their needs, and get awareness of any
regressions that may have occurred since a previous test run
In relation to other libvirt testing, the split of responsibiity
will be
libvirt testsuite (aka $CHECKOUT/tests)
- unit testing of specific internal APIs
- functional testing of the libvirtd using the 'test' driver
- functional testing of the virsh command using the 'test' driver
libvirt TCK
- functional/integration testing of the 'live' drivers
#!/bin/sh
# -*- shell -*-
DATADIR=/usr/share/libvirt-tck
TESTDIR=$DATADIR/tests
CONFDIR=/etc/libvirt-tck
HOSTNAME=`hostname`
MODE=text
#MODE=html
CONFNAME=$1
help () {
echo "syntax: $0 CONFNAME [TESTDIR]"
}
if [ -z "$CONFNAME" ]; then
help
exit 1
fi
if [ -f "$CONFNAME.cfg" ]; then
CONFFILE="$CONFNAME.cfg"
else
if [ -f "./conf/$CONFNAME.cfg" ]; then
CONFFILE="./conf/$CONFNAME.cfg"
else
CONFFILE="$CONFDIR/$CONFNAME.cfg"
if [ ! -f "$CONFFILE" ]; then
echo "config file $CONFFILE does not exist"
exit 2
fi
fi
fi
ARCHIVE="libvirt-tck-$CONFNAME-$HOSTNAME.tar.gz"
EXTRAARGS=
if [ $MODE = "text" ]; then
OUTPUTFILE=libvirt-tck-$CONFNAME-$HOSTNAME.log
EXTRAARGS="-v"
else
OUTPUTFILE=libvirt-tck-$CONFNAME-$HOSTNAME.html
EXTRAARGS="-m -Q --formatter=TAP::Formatter::HTML"
fi
if [ ! -z "$2" ]; then
TESTDIR=$2
fi
export LIBVIRT_TCK_CONFIG=$CONFFILE
#exec prove -a $ARCHIVE $EXTRAARGS -r --norc $TESTDIR > $OUTPUTFILE
exec prove -a $ARCHIVE $EXTRAARGS -r --norc $TESTDIR
#uri = qemu:///system
uri = qemu:///session
kernel=/home/berrange/src/xen/libvirt-tck/data/vmlinuz
initrd=/home/berrange/src/xen/libvirt-tck/data/initrd.img
disk=/home/berrange/src/xen/libvirt-tck/data/disk.img
package Sys::Virt::TCK;
use strict;
use warnings;
use Sys::Virt;
use Sys::Virt::TCK::DomainBuilder;
use Config::Record;
our $VERSION = '0.0.1';
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
my %params = @_;
$self->{config} = $params{config} ? $params{config} :
Config::Record->new(file => ($ENV{LIBVIRT_TCK_CONFIG} || "/etc/tck.conf"));
bless $self, $class;
$self->setup;
return $self;
}
sub setup {
my $self = shift;
$self->{conn} = Sys::Virt->new(address => $self->config("uri", undef));
my $type = $self->{conn}->get_type();
$self->{type} = lc $type;
}
sub cleanup {
my $self = shift;
delete $self->{conn};
}
sub config {
my $self = shift;
my $key = shift;
my $default = shift;
return $self->{config}->get($key, $default);
}
sub conn {
my $self = shift;
return $self->{conn};
}
sub generic_domain {
my $self = shift;
my $b = $self->bare_domain(@_);
my $disk = $self->config("disk");
$b->disk(src =>$disk, dst => "hda", type => "file");
return $b;
}
sub bare_domain {
my $self = shift;
my $name = @_ ? shift : "test";
my $b = Sys::Virt::TCK::DomainBuilder->new(conn => $self->{conn},
name => $name);
$b->memory(64 * 1024);
my $kernel = $self->config("kernel");
my $initrd = $self->config("initrd");
$b->boot_kernel($kernel, $initrd);
return $b;
}
1;
package Sys::Virt::TCK::Capabilities;
use strict;
use warnings;
use XML::Twig;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my %params = @_;
my $self = {};
my $xml = $params{xml};
die "xml parameter is required" unless defined $xml;
bless $self, $class;
$self->parse($xml);
return $self;
}
sub parse {
my $self = shift;
my $xml = shift;
my $twig = XML::Twig->new();
$twig->parse($xml);
$self->{host} = {};
$self->{guests} = [];
$self->_parse_capabilities($twig->root);
}
sub _parse_capabilities {
my $self = shift;
my $node = shift;
my $host = $node->first_child("host");
$self->_parse_host($host) if $host;
foreach my $child ($node->children("guest")) {
$self->_parse_guest($child);
}
}
sub _parse_host {
my $self = shift;
my $node = shift;
my $cpu = $node->first_child("cpu");
$self->_parse_host_cpu($cpu) if $cpu;
my $mig = $node->first_child("migration_features");
$self->_parse_host_migration($mig) if $mig;
my $top = $node->first_child("topology");
$self->_parse_host_topology($top) if $top;
my $sec = $node->first_child("secmodel");
$self->_parse_host_secmodel($sec) if $sec;
}
sub _parse_host_cpu {
my $self = shift;
my $node = shift;
my $cpu = {};
my $arch = $node->first_child_text("arch");
$cpu->{arch} = $arch if $arch;
my $feat = $node->first_child("features");
if (defined $feat) {
$cpu->{features} = {};
foreach my $child ($feat->children()) {
my $name = $child->name;
$cpu->{features}->{$name} = 1;
}
}
$self->{host}->{cpu} = $cpu;
}
sub _parse_host_migration {
my $self = shift;
my $node = shift;
my $mig = {};
my $live = $node->first_child("live");
$mig->{live} = defined $live ? 1 : 0;
$mig->{transports} = [];
my $trans = $node->first_child("uri_transports");
foreach my $child ($trans->children("uri_transport")) {
push @{$mig->{transports}}, $child->text;
}
$self->{host}->{migration} = $mig;
}
sub _parse_host_topology {
my $self = shift;
my $node = shift;
my $top = [];
my $cells = $node->first_child("cells");
return unless $cells;
my @cells;
foreach my $cell ($cells->children("cell")) {
my $topcell = [];
push @{$top}, $topcell;
my $cpus = $cell->first_child("cpus");
next unless $cpus;
foreach my $cpu ($cpus->children("cpu")) {
my $id = $cpu->att("id");
push @{$topcell}, $id;
}
}
$self->{host}->{topology} = $top;
}
sub _parse_host_secmodel {
my $self = shift;
my $node = shift;
my $sec = {
model => $node->first_child_text("model"),
doi => $node->first_child_text("doi"),
};
$self->{host}->{secmodel} = $sec;
}
sub _parse_guest {
my $self = shift;
my $node = shift;
my $guest = {};
$guest->{os_type} = $node->first_child_text("os_type");
my $arch = $node->first_child("arch");
my $wordsize = $arch->first_child_text("wordsize");
$guest->{arch} = {
name => $arch->att("name"),
wordsize => $wordsize,
domains => {},
};
my $defemu = $arch->first_child("emulator") ? $arch->first_child_text("emulator") : undef;
my $defload = $arch->first_child("loader") ? $arch->first_child_text("loader") : undef;
my @defmachines = ();
foreach my $child ($arch->children("machine")) {
push @defmachines, $child->text;
}
foreach my $dom ($arch->children("domain")) {
my $emu = $dom->first_child("emulator") ? $dom->first_child_text("emulator") : undef;
my $load = $dom->first_child("loader") ? $dom->first_child_text("loader") : undef;
my @machines = ();
foreach my $child ($dom->children("machine")) {
push @machines, $child->text;
}
$emu = $defemu unless $emu;
$load = $defload unless $load;
@machines = @defmachines unless @machines;
my $type = $dom->att("type");
$guest->{arch}->{domains}->{$type} = {
emulator => $emu,
loader => $load,
machines => \@machines,
};
}
$guest->{features} = {};
my $features = $node->first_child("features");
if ($features) {
foreach my $child ($features->children) {
$guest->{features}->{$child->name} = 1;
}
}
push @{$self->{guests}}, $guest;
}
sub host_cpu_arch {
my $self = shift;
return $self->{host}->{cpu}->{arch};
}
sub host_cpu_features {
my $self = shift;
return keys %{$self->{host}->{cpu}->{features}};
}
sub host_live_migration {
my $self = shift;
return $self->{host}->{migration}->{live};
}
sub host_migration_transports {
my $self = shift;
return @{$self->{host}->{migration}->{transports}};
}
sub host_topology_num_cells {
my $self = shift;
return $#{$self->{host}->{topology}} + 1;
}
sub host_topology_cpus_for_cell {
my $self = shift;
my $cell = shift;
return @{$self->{host}->{topology}->[$cell]};
}
sub host_secmodel {
my $self = shift;
return undef unless exists $self->{host}->{secmodel};
return $self->{host}->{secmodel}->{model};
}
sub host_secmodel_doi {
my $self = shift;
return $self->{host}->{secmodel}->{doi};
}
sub num_guests {
my $self = shift;
return $#{$self->{guests}} + 1;
}
sub guest_os_type {
my $self = shift;
my $guest = shift;
return $self->{guests}->[$guest]->{os_type};
}
sub guest_arch_name {
my $self = shift;
my $guest = shift;
return $self->{guests}->[$guest]->{arch}->{name};
}
sub guest_arch_wordsize {
my $self = shift;
my $guest = shift;
return $self->{guests}->[$guest]->{arch}->{wordsize};
}
sub guest_domain_types {
my $self = shift;
my $guest = shift;
return keys %{$self->{guests}->[$guest]->{arch}->{domains}};
}
sub guest_domain_emulator {
my $self = shift;
my $guest = shift;
my $domain = shift;
return $self->{guests}->[$guest]->{arch}->{domains}->{$domain}->{emulator};
}
sub guest_domain_loader {
my $self = shift;
my $guest = shift;
my $domain = shift;
return $self->{guests}->[$guest]->{arch}->{domains}->{$domain}->{loader};
}
sub guest_domain_machines {
my $self = shift;
my $guest = shift;
my $domain = shift;
return @{$self->{guests}->[$guest]->{arch}->{domains}->{$domain}->{machines}};
}
1;
package Sys::Virt::TCK::DomainBuilder;
use strict;
use warnings;
use Sys::Virt;
use IO::String;
use XML::Writer;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my %params = @_;
my $conn = $params{conn} ? $params{conn} : die "conn parameter is required";
my $type = $conn->get_type();
my $domtype;
if ($type eq "QEMU") {
$domtype = "qemu";
} else {
$domtype = "xen";
}
my $self = {
name => $params{name} ? $params{name} : "test" ,
type => $domtype,
boot => { type => "disk" },
lifecycle => {},
features => {},
disks => [],
interfaces => [],
serials => [],
parallels => [],
consoles => [],
inputs => [],
graphics => [],
hostdevs => []
};
bless $self, $class;
return $self;
}
sub memory {
my $self = shift;
my $mem = shift;
$self->{memory} = $mem
unless defined $self->{memory};
$self->{currentMemory} = $mem;
return $self;
}
sub maxmem {
my $self = shift;
$self->{memory} = shift;
return $self;
}
sub vcpu {
my $self = shift;
$self->{vcpu} = shift;
return $self;
}
sub uuid {
my $self = shift;
$self->{uuid} = shift;
return $self;
}
sub boot_network {
my $self = shift;
$self->{boot} = {
type => "network"
};
return $self;
}
sub boot_disk {
my $self = shift;
$self->{boot} = {
type => "disk"
};
return $self;