...
 
Commits (36)
......@@ -3,7 +3,10 @@
*.orig
*~
Build
META.json
META.yml
MYMETA.json
MYMETA.yml
Makefile
Makefile.PL
Makefile.old
......
......@@ -61,6 +61,9 @@ EOF
my $b = $class->new(
module_name => "Sys::Virt::TCK",
license => 'gpl',
configure_requires => {
'Module::Build' => 0,
},
dist_author => 'Daniel Berrange <dan@berrange.com>',
dist_abstract => 'libvirt Technology Compatability Kit',
requires => {
......@@ -95,24 +98,24 @@ my $b = $class->new(
},
build_requires => {
'Test::Pod' => '0',
'Test::Pod::Coverage' => '0',
'Test::Pod::Coverage' => '0',
'Test::CPAN::Changes' => '0',
},
script_files => [
"bin/libvirt-tck",
],
create_makefile_pl => 'passthrough',
meta_add => {
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",
license => "https://www.gnu.org/licenses/gpl.html",
homepage => "https://libvirt.org/",
repository => "https://libvirt.org/git/?p=libvirt-tck.git;a=summary",
MailingList => "https://www.redhat.com/mailman/listinfo/libvir-list",
},
},
conf_files => {
'conf/default.cfg' => 'conf/default.cfg',
},
PL_files => [ 'perl-Sys-Virt-TCK.spec.PL' ],
PL_files => { 'perl-Sys-Virt-TCK.spec.PL' => 'perl-Sys-Virt-TCK.spec' },
);
$b->add_build_element("conf");
$b->add_build_element("pkgdata");
......
Revision history for perl module Sys::Virt
1.0.0 2018-06-11
- Too many changes to list
0.1.0 2009-07-22
- Initial release
This program is free software; you can redistribute it and/or modify
it under the terms of either:
a) the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any
later version
or
b) the "Artistic License"
The text of both licenses follows below...
---------------------------------------------------------------------------
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
......@@ -294,148 +279,3 @@ PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
---------------------------------------------------------------------------
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions
"Package"
refers to the collection of files distributed by the Copyright
Holder, and derivatives of that collection of files created through
textual modification.
"Standard Version"
refers to such a Package if it has not been modified, or has been
modified in accordance with the wishes of the Copyright Holder as
specified below.
"Copyright Holder"
is whoever is named in the copyright or copyrights for the package.
"You"
is you, if you're thinking about copying or distributing this Pack-
age.
"Reasonable copying fee"
is whatever you can justify on the basis of media cost, duplication
charges, time of people involved, and so on. (You will not be
required to justify it to the Copyright Holder, but only to the
computing community at large as a market that must bear the fee.)
"Freely Available"
means that no fee is charged for the item itself, though there may
be fees involved in handling the item. It also means that recipi-
ents of the item may redistribute it under the same conditions they
received it.
Conditions
1. You may make and give away verbatim copies of the source form of
the Standard Version of this Package without restriction, provided
that you duplicate all of the original copyright notices and asso-
ciated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A
Package modified in such a way shall still be considered the Stan-
dard Version.
3. You may otherwise modify your copy of this Package in any way, pro-
vided that you insert a prominent notice in each changed file stat-
ing how and when you changed that file, and provided that you do at
least ONE of the following:
a) place your modifications in the Public Domain or otherwise make
them Freely Available, such as by posting said modifications to
Usenet or an equivalent medium, or placing the modifications on
a major archive site such as uunet.uu.net, or by allowing the
Copyright Holder to include your modifications in the Standard
Version of the Package.
b) use the modified Package only within your corporation or orga-
nization.
c) rename any non-standard executables so the names do not con-
flict with standard executables, which must also be provided,
and provide a separate manual page for each non-standard exe-
cutable that clearly documents how it differs from the Standard
Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the follow-
ing:
a) distribute a Standard Version of the executables and library
files, together with instructions (in the manual page or equiv-
alent) on where to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent),
together with instructions on where to get the Standard Ver-
sion.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of
this Package. You may charge any fee you choose for support of
this Package. You may not charge a fee for this Package itself.
However, you may distribute this Package in aggregate with other
(possibly commercial) programs as part of a larger (possibly com-
mercial) software distribution provided that you do not advertise
this Package as a product of your own. You may embed this Pack-
age's interpreter within an executable of yours (by linking); this
shall be construed as a mere form of aggregation, provided that the
complete Standard Version of the interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever gener-
ated them, and may be sold commercially, and may be aggregated with
this Package. If such scripts or library files are aggregated with
this Package via the so-called "undump" or "unexec" methods of pro-
ducing a binary executable image, then distribution of such an
image shall neither be construed as a distribution of this Package
nor shall it fall under the restrictions of Paragraphs 3 and 4,
provided that you do not represent such an executable image as a
Standard Version of this Package.
7. C subroutines (or comparably compiled subroutines in other lan-
guages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines
do not change the language in any way that would cause it to fail
the regression tests for the language.
8. Aggregation of this Package with a commercial distribution is
always permitted provided that the use of this Package is embedded;
that is, when no overt attempt is made to make this Package's
interfaces visible to the end user of the commercial distribution.
Such use shall not be construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or pro-
mote products derived from this software without specific prior
written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES
OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End
---------------------------------------------------------------------------
bin/libvirt-tck
Build.PL
Changes
conf/default.cfg
docs/intro.pod
docs/writing-tests.pod
......@@ -8,14 +9,12 @@ lib/Sys/Virt/TCK/Capabilities.pm
lib/Sys/Virt/TCK/DomainBuilder.pm
lib/Sys/Virt/TCK/Hooks.pm
lib/Sys/Virt/TCK/NetworkBuilder.pm
lib/Sys/Virt/TCK/NetworkHelpers.pm
lib/Sys/Virt/TCK/SELinux.pm
lib/Sys/Virt/TCK/StoragePoolBuilder.pm
lib/Sys/Virt/TCK/StorageVolBuilder.pm
lib/Sys/Virt/TCK/TAP/XMLFormatter.pm
lib/Sys/Virt/TCK/TAP/XMLFormatterSession.pm
LICENSE
Makefile.PL
MANIFEST
META.json
META.yml
......
......@@ -49,7 +49,7 @@ images = (
hvm
xen
)
osname = fedora-27
osname = fedora-28
}
)
......@@ -75,25 +75,25 @@ images = (
# empty sparse root FS will be created
#
kernels = (
# Fedora 15 i686 PAE has pv_ops, so one kernel can do both Xen and KVM guests here
# Fedora 28 i686 PAE has pv_ops, so one kernel can do both Xen and KVM guests here
{
arch = i686
ostype = (
hvm
xen
)
kernel = http://dl.fedoraproject.org/pub/fedora/linux/releases/27/Everything/i386/os/images/pxeboot/vmlinuz-PAE
initrd = http://dl.fedoraproject.org/pub/fedora/linux/releases/27/Everything/i386/os/images/pxeboot/initrd-PAE.img
kernel = http://dl.fedoraproject.org/pub/fedora-secondary/releases/28/Everything/i386/os/images/pxeboot/vmlinuz
initrd = http://dl.fedoraproject.org/pub/fedora-secondary/releases/28/Everything/i386/os/images/pxeboot/initrd.img
}
# Fedora 15 x86_64 has pv_ops, so one kernel can do both Xen and KVM guests here
# Fedora 28 x86_64 has pv_ops, so one kernel can do both Xen and KVM guests here
{
arch = x86_64
ostype = (
hvm
xen
)
kernel = http://dl.fedoraproject.org/pub/fedora/linux/releases/27/Everything/x86_64/os/images/pxeboot/vmlinuz
initrd = http://dl.fedoraproject.org/pub/fedora/linux/releases/27/Everything/x86_64/os/images/pxeboot/initrd.img
kernel = http://dl.fedoraproject.org/pub/fedora/linux/releases/28/Everything/x86_64/os/images/pxeboot/vmlinuz
initrd = http://dl.fedoraproject.org/pub/fedora/linux/releases/28/Everything/x86_64/os/images/pxeboot/initrd.img
}
# User mode linux i686 needs custom kernel + root filesystem
{
......
......@@ -34,16 +34,19 @@ use IO::Uncompress::Bunzip2 qw(bunzip2);
use XML::XPath;
use Carp qw(cluck carp);
use Fcntl qw(O_RDONLY SEEK_END);
use NetAddr::IP qw(:lower);
use Test::Builder;
use Test::More;
use Sub::Uplevel qw(uplevel);
use base qw(Exporter);
our @EXPORT = qw(ok_error ok_domain ok_domain_snapshot ok_pool
ok_volume ok_network ok_interface ok_node_device
xpath err_not_implemented);
xpath err_not_implemented get_first_macaddress
get_first_interface_target_dev get_network_ip
get_ip_from_leases shutdown_vm_gracefully);
our $VERSION = 'v0.1.0';
our $VERSION = 'v1.1.0';
sub new {
my $proto = shift;
......@@ -782,6 +785,7 @@ sub generic_machine_domain {
my $caps = exists $params{caps} ? $params{caps} : die "caps parameter is required";
my $ostype = exists $params{ostype} ? $params{ostype} : "hvm";
my $fullos = exists $params{fullos} ? $params{fullos} : 0;
my $shareddisk = exists $params{shareddisk} ? $params{shareddisk} : 0;
my $filterref = exists $params{filterref} ? $params{filterref} : undef;
my %filterparams = exists $params{filterparams} ? %{$params{filterparams}} : ();
......@@ -820,11 +824,12 @@ sub generic_machine_domain {
$dom->create();
# Wait for the first boot to reach network setting
my $iface = get_first_interface_target_dev($dom);
my $stats;
my $tries = 0;
do {
sleep(10);
$stats = $dom->interface_stats("vnet0");
$stats = $dom->interface_stats($iface);
$tries++;
} while ($stats->{"tx_packets"} < 10 && $tries < 10);
......@@ -857,7 +862,8 @@ sub generic_machine_domain {
$b->disk(src => $config{root},
dst => $config{dev},
type => "file");
type => "file",
shareable => $shareddisk);
return $b;
}
}
......@@ -915,6 +921,7 @@ sub generic_domain {
my $ostype = exists $params{ostype} ? $params{ostype} : "hvm";
my $fullos = exists $params{fullos} ? $params{fullos} : 0;
my $netmode = exists $params{netmode} ? $params{netmode} : undef;
my $shareddisk = exists $params{shareddisk} ? $params{shareddisk} : 0;
my $filterref = exists $params{filterref} ? $params{filterref} : undef;
my %filterparams = exists $params{filterparams} ? %{$params{filterparams}} : ();
......@@ -936,6 +943,7 @@ sub generic_domain {
$b = $self->generic_machine_domain(name => $name,
caps => $caps,
ostype => $ostype,
shareddisk => $shareddisk,
fullos => $fullos,
filterref => $filterref,
filterparams => \%filterparams);
......@@ -1030,8 +1038,6 @@ sub _try_as_caller {
};
my $Tester = Test::Builder->new;
sub ok_object($$$;$) {
my $coderef = shift;
my $class = shift;
......@@ -1047,16 +1053,16 @@ sub ok_object($$$;$) {
$ret && ref($ret) && $ret->isa($class) &&
(!defined $name || ($ret->get_name() eq $name));
$Tester->ok($ok, $description);
ok($ok, $description);
unless ($ok) {
$Tester->diag("expected $class object" . ($name ? " with name $name" : ""));
diag("expected $class object" . ($name ? " with name $name" : ""));
if ($exception) {
$Tester->diag("found '$exception'");
diag("found '$exception'");
} else {
if ($ret && ref($ret) && $ret->isa($class)) {
$Tester->diag("found $class object with name " . $ret->get_name);
diag("found $class object with name " . $ret->get_name);
} else {
$Tester->diag("found '$ret'");
diag("found '$ret'");
}
}
}
......@@ -1132,10 +1138,10 @@ sub ok_error(&$;$) {
my $ok = ref($exception) && $exception->isa("Sys::Virt::Error") &&
(!defined $code || ($exception->code() == $code));
$Tester->ok($ok, $description);
ok($ok, $description);
unless ($ok) {
$Tester->diag("expecting Sys::Virt::Error object" . ($code ? " with code $code" : ""));
$Tester->diag("found '$exception'");
diag("expecting Sys::Virt::Error object" . ($code ? " with code $code" : ""));
diag("found '$exception'");
}
$@ = $exception;
return $ok;
......@@ -1227,4 +1233,70 @@ sub get_host_network_device {
return $self->config("host_network_devices/[$devindex]", undef);
}
sub get_first_macaddress {
my $dom = shift;
my $mac = xpath($dom, "string(/domain/devices/interface[1]/mac/\@address)");
utf8::encode($mac);
return $mac;
}
sub get_first_interface_target_dev {
my $dom = shift;
my $targetdev = xpath($dom, "string(/domain/devices/interface[1]/target/\@dev)");
return $targetdev;
}
sub get_network_ip {
my $conn = shift;
my $netname = shift;
diag "getting ip for network $netname";
my $net = $conn->get_network_by_name($netname);
my $net_ip = xpath($net, "string(/network/ip[1]/\@address");
my $net_mask = xpath($net, "string(/network/ip[1]/\@netmask");
my $net_prefix = xpath($net, "string(/network/ip[1]/\@prefix");
my $ip;
if ($net_mask) {
$ip = NetAddr::IP->new($net_ip, $net_mask);
} elsif ($net_prefix) {
$ip = NetAddr::IP->new("$net_ip/$net_prefix");
} else {
$ip = NetAddr::IP->new("$net_ip");
}
return $ip;
}
sub get_ip_from_leases{
my $conn = shift;
my $netname = shift;
my $mac = shift;
my $net = $conn->get_network_by_name($netname);
if ($net->can('get_dhcp_leases')) {
my @leases = $net->get_dhcp_leases($mac);
return @leases ? $leases[0]->{'ipaddr'} : undef;
}
my $tmp = `grep $mac /var/lib/libvirt/dnsmasq/default.leases`;
my @fields = split(/ /, $tmp);
my $ip = $fields[2];
return $ip;
}
sub shutdown_vm_gracefully {
my $dom = shift;
my $target = time() + 30;
$dom->shutdown;
while ($dom->is_active()) {
sleep(1);
diag ".. waiting for virtual machine to shutdown.. ";
$dom->destroy() if time() > $target;
}
sleep(1);
diag ".. shutdown complete.. ";
}
1;
......@@ -409,11 +409,14 @@ sub as_xml {
$w->emptyTag("source",
file => $disk->{src});
}
if ($disk->{shareable}) {
$w->emptyTag("shareable");
}
$w->emptyTag("target",
dev => $disk->{dst},
$disk->{bus} ? (bus => $disk->{bus}) : ());
if ($disk->{secret}) {
$w->startTag("encryption", format => "qcow");
if ($disk->{encryption_format}) {
$w->startTag("encryption", format => $disk->{encryption_format});
$w->emptyTag("secret", type => "passphrase", uuid => $disk->{secret});
$w->endTag("encryption");
}
......
......@@ -71,11 +71,10 @@ sub expect_result {
sub libvirtd_status {
my $self = shift;
my $status = `service libvirtd status`;
my $_ = $status;
if (/stopped|unused|inactive/) {
if ($status =~ /stopped|unused|inactive/) {
$self->{libvirtd_status} = 'stopped';
} elsif (/running|active/) {
} elsif ($status =~ /running|active/) {
$self->{libvirtd_status} = 'running';
}
......
use Sys::Virt::TCK qw(xpath);
use NetAddr::IP qw(:lower);
use strict;
use utf8;
sub get_first_macaddress {
my $dom = shift;
my $mac = xpath($dom, "string(/domain/devices/interface[1]/mac/\@address)");
utf8::encode($mac);
return $mac;
}
sub get_network_ip {
my $conn = shift;
my $netname = shift;
diag "getting ip for network $netname";
my $net = $conn->get_network_by_name($netname);
my $net_ip = xpath($net, "string(/network/ip[1]/\@address");
my $net_mask = xpath($net, "string(/network/ip[1]/\@netmask");
my $net_prefix = xpath($net, "string(/network/ip[1]/\@prefix");
my $ip;
if ($net_mask) {
$ip = NetAddr::IP->new($net_ip, $net_mask);
} elsif ($net_prefix) {
$ip = NetAddr::IP->new("$net_ip/$net_mask");
} else {
$ip = NetAddr::IP->new("$net_ip");
}
return $ip;
}
sub get_ip_from_leases{
my $conn = shift;
my $netname = shift;
my $mac = shift;
my $net = $conn->get_network_by_name($netname);
if ($net->can('get_dhcp_leases')) {
my @leases = $net->get_dhcp_leases($mac);
return @leases ? @leases[0]->{'ipaddr'} : undef;
}
my $tmp = `grep $mac /var/lib/libvirt/dnsmasq/default.leases`;
my @fields = split(/ /, $tmp);
my $ip = $fields[2];
return $ip;
}
sub shutdown_vm_gracefully {
my $dom = shift;
my $target = time() + 30;
$dom->shutdown;
while ($dom->is_active()) {
sleep(1);
diag ".. waiting for virtual machine to shutdown.. ";
$dom->destroy() if time() > $target;
}
sleep(1);
diag ".. shutdown complete.. ";
}
1;
......@@ -60,6 +60,14 @@ sub format {
return $self;
}
sub encryption_format {
my $self = shift;
$self->{encformat} = shift;
return $self;
}
sub secret {
my $self = shift;
......@@ -95,13 +103,13 @@ sub as_xml {
$w->dataElement("capacity", $self->{capacity});
$w->dataElement("allocation", $self->{allocation});
if ($self->{format} || $self->{secret}) {
if ($self->{format} || $self->{encformat}) {
$w->startTag("target");
if ($self->{format}) {
$w->emptyTag("format", type => $self->{format});
}
if ($self->{secret}) {
$w->startTag("encryption", format => "qcow");
if ($self->{encformat}) {
$w->startTag("encryption", format => $self->{encformat});
$w->emptyTag("secret", type => "passphrase", uuid => $self->{secret});
$w->endTag("encryption");
}
......@@ -114,8 +122,8 @@ sub as_xml {
if ($self->{backingFormat}) {
$w->emptyTag("format", type => $self->{backingFormat});
}
if ($self->{secret}) {
$w->startTag("encryption", format => "qcow");
if ($self->{encformat}) {
$w->startTag("encryption", format => $self->{encformat});
$w->emptyTag("secret", type => "passphrase", uuid => $self->{secret});
$w->endTag("encryption");
}
......
......@@ -24,26 +24,21 @@ close SPEC;
__DATA__
# Automatically generated by perl-Sys-Virt-TCK.spec.PL
%define perlvendorarch %(perl -e 'use Config; print $Config{installvendorarch}')
%define perlvendorlib %(perl -e 'use Config; print $Config{installvendorlib}')
%define perlvendorprefix %(perl -e 'use Config; print $Config{vendorprefix}')
%define perlvendorman1 %{perlvendorprefix}/share/man/man1
%define perlvendorman3 %{perlvendorprefix}/share/man/man3
%define perlversion %(perl -e 'use Config; print $Config{version}')
%define appname Sys-Virt-TCK
Summary: Sys::Virt::TCK - libvirt Technology Compatibility Kit
Name: perl-%{appname}
Version: @VERSION@
Release: 1
Release: 1%{?dist}
License: GPLv2
Group: Development/Tools
Source: http://libvirt.org/sources/tck/%{appname}-v%{version}.tar.gz
Url: http://libvirt.org/
BuildRoot: %{_tmppath}/%{appname}-%{version}-%{release}-root-%(%{__id_u} -n)
Requires: perl >= %{perlversion}
Requires: libvirt >= 0.6.2
Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version))
Requires: libvirt >= 4.4.0
%if 0%{?fedora} || 0%{?rhel} > 7
BuildRequires: perl-interpreter
BuildRequires: perl-generators
%endif
BuildRequires: perl(accessors)
BuildRequires: perl(App::Prove)
BuildRequires: perl(Config::Record)
......@@ -64,9 +59,12 @@ BuildRequires: perl(TAP::Harness::Archive)
BuildRequires: perl(Test::Builder)
BuildRequires: perl(Test::More)
BuildRequires: perl(Sub::Uplevel)
BuildRequires: perl(Sys::Virt) >= 0.2.0
BuildRequires: perl(Sys::Virt) >= 0.2.1
BuildRequires: perl(XML::Twig)
BuildRequires: perl(XML::Writer)
BuildRequires: perl(XML::XPath)
BuildRequires: perl(Test::Pod)
BuildRequires: perl(Test::Pod::Coverage)
# RPM autoprovides misses these 3
Requires: perl(Test::Exception)
Requires: perl(TAP::Formatter::HTML)
......@@ -76,6 +74,8 @@ Requires: perl(Net::OpenSSH)
Requires: perl(IO::Pty)
Requires: libguestfs-tools
Requires: /usr/bin/mkisofs
# Want to force this minimal version, so don't rely on RPM autoprov
Requires: perl(Sys::Virt) >= 0.2.1
BuildArchitectures: noarch
%description
......@@ -103,27 +103,18 @@ find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
%__install -m 0755 -d $RPM_BUILD_ROOT%{_localstatedir}/cache/libvirt-tck
%clean
rm -rf $RPM_BUILD_ROOT
%files
%defattr(-,root,root)
#%doc AUTHORS
%doc LICENSE
%doc README
#%doc INSTALL
%license LICENSE
%doc README Changes
%dir %{_sysconfdir}/libvirt-tck
%config(noreplace) %{_sysconfdir}/libvirt-tck/default.cfg
%{_bindir}/libvirt-tck
%dir %{_datadir}/libvirt-tck
%{_datadir}/libvirt-tck/*
%{perlvendorman1}/*
#%{perlvendorman3}/*
%{perlvendorlib}/Sys/Virt/TCK.pm
%{perlvendorlib}/Sys/Virt/TCK/
%{_mandir}/man1/*
%{perl_vendorlib}/Sys/Virt/TCK.pm
%{perl_vendorlib}/Sys/Virt/TCK/
%dir %{_localstatedir}/cache/libvirt-tck
%changelog
* Fri Mar 24 2006 <berrange@redhat.com> - 0.0.1-1
- Initial build
......@@ -16,7 +16,7 @@ NAME=Sys-Virt-TCK
set -e
rm -rf blib _build Build
rm -rf blib _build Build perl-Sys-Virt-TCK.spec
perl Build.PL install_base=$HOME/builder
......
......@@ -54,13 +54,13 @@ my $uuid1 = "11111111-1111-1111-1111-111111111111";
my $uuid2 = "22222222-1111-1111-1111-111111111111";
# The initial config
my $xml = $tck->generic_domain(name => $name1)->uuid($uuid1)->as_xml;
my $xml = $tck->generic_domain(name => $name1, shareddisk => 1)->uuid($uuid1)->as_xml;
# One with a different UUID, matching name
my $xml_diffuuid = $tck->generic_domain(name => $name1)->uuid($uuid2)->as_xml;
# One with a matching UUID, different name
my $xml_diffname = $tck->generic_domain(name => $name2)->uuid($uuid1)->as_xml;
# One with a different UUID, different name
my $xml_diffboth = $tck->generic_domain(name => $name2)->uuid($uuid2)->as_xml;
my $xml_diffboth = $tck->generic_domain(name => $name2, shareddisk => 1)->uuid($uuid2)->as_xml;
diag "Defining persistent domain config";
my ($dom, $dom1);
......
......@@ -28,8 +28,7 @@ transient domains to/from a file.
use strict;
use warnings;
use Test::More skip_all => "Until RHBZ 518032 is fixed";
#use Test::More tests => 5;
use Test::More tests => 5;
use Sys::Virt::TCK;
use Test::Exception;
......
......@@ -99,7 +99,7 @@ $xml = $dom->get_xml_description();
is($dom->get_block_info($dst2,0)->{capacity}, 1024*1024*50, "Get disk capacity info");
is($dom->get_block_info($dst2,0)->{allocation}, 1024*1024, "Get disk allocation info");
is($dom->get_block_info($dst2,0)->{physical}, 1024*1024, "Get disk physical info");
is($dom->get_block_info($dst2,0)->{physical}, 1024*1024*50, "Get disk physical info");
is($dom->get_block_info($dst,0)->{capacity}, 1024*1024*50, "Get disk capacity info");
......@@ -124,8 +124,7 @@ my $date = "test";
system("echo $date > $path");
is($dom->block_peek($path,0,4,0), $date, "Get date from raw image");
#qcow2 file start with hexadecimal:0x51 0x46 0x49 (ASCII: "QFI")
is($dom->block_peek($path3,0,3,0), "QFI", "Get date from qcow2 image");
dies_ok(sub { $dom->block_peek($path3,0,3,0) }, "Get date from qcow2 image");
lives_ok(sub { $vol->delete(0) }, "deleted volume");
......
......@@ -59,12 +59,13 @@ diag "Set/Get interface parameters";
my %params = (Sys::Virt::Domain::BANDWIDTH_IN_AVERAGE=>1000, Sys::Virt::Domain::BANDWIDTH_IN_PEAK=>1001,
Sys::Virt::Domain::BANDWIDTH_IN_BURST=>1002, Sys::Virt::Domain::BANDWIDTH_OUT_AVERAGE=>1003,
Sys::Virt::Domain::BANDWIDTH_OUT_PEAK=>1004, Sys::Virt::Domain::BANDWIDTH_OUT_BURST=>1005);
lives_ok(sub {$dom->set_interface_parameters("vnet0", \%params)}, "Set vnet0 parameters");
my $iface = get_first_interface_target_dev($dom);
lives_ok(sub {$dom->set_interface_parameters($iface, \%params)}, "Set $iface parameters");
for my $key (sort keys %params) {
diag "Set $key => $params{$key} ";
}
my $param = $dom->get_interface_parameters("vnet0", 0);
my $param = $dom->get_interface_parameters($iface, 0);
my $in_average = $param->{Sys::Virt::Domain::BANDWIDTH_IN_AVERAGE};
my $in_burst = $param->{Sys::Virt::Domain::BANDWIDTH_IN_BURST};
my $in_peak = $param->{Sys::Virt::Domain::BANDWIDTH_IN_PEAK};
......
......@@ -41,12 +41,14 @@ END {
}
my $xml = $tck->generic_domain(name => "tck")->as_xml;
my $xml = $tck->generic_domain(name => "tck", fullos => 1)->as_xml;
diag "Creating a new transient domain";
my $dom;
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
diag "Waiting 30 seconds for guest to finish booting";
sleep(30);
my $path = $tck->create_sparse_disk("200-disk-hotplug", "extra.img", 100);
......
......@@ -41,12 +41,15 @@ END {
}
my $xml = $tck->generic_domain(name => "tck")->as_xml;
my $xml = $tck->generic_domain(name => "tck", fullos => 1)->as_xml;
diag "Creating a new transient domain";
my $dom;
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
diag "Waiting 30 seconds for guest to finish booting";
sleep(30);
my $supported = 1;
foreach my $dev (qw/vdb sdb/) {
my $path = $tck->create_sparse_disk("200-disk-hotplug", "extra-$dev.img", 100);
......
......@@ -41,12 +41,15 @@ END {
}
my $xml = $tck->generic_domain(name => "tck")->as_xml;
my $xml = $tck->generic_domain(name => "tck", fullos => 1)->as_xml;
diag "Creating a new transient domain";
my $dom;
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
diag "Waiting 30 seconds for guest to finish booting";
sleep(30);
my $mac = "00:11:22:33:44:55";
my $model = "virtio";
......
......@@ -41,15 +41,18 @@ END {
}
my $xml = $tck->generic_domain(name => "tck")->as_xml;
my $xml = $tck->generic_domain(name => "tck", fullos => 1)->as_xml;
diag "Creating a new transient domain";
my $dom;
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
my $mac1 = "01:11:22:33:44:55";
my $mac2 = "02:11:22:33:44:55";
my $mac3 = "03:11:22:33:44:55";
diag "Waiting 30 seconds for guest to finish booting";
sleep(30);
my $mac1 = "02:11:22:33:44:55";
my $mac2 = "02:12:22:33:44:55";
my $mac3 = "02:13:22:33:44:55";
my $model = "virtio";
my $netxml1 = <<EOF;
......
......@@ -51,7 +51,7 @@ SKIP: {
log_name => '/tmp/daemon.log');
$hook->libvirtd_status();
BAIL_OUT "libvirtd is not running, Exit..."
skip "libvirtd is not running, Exit...", 12
if ($hook->{libvirtd_status} eq 'stopped');
eval { $hook->prepare(); };
......
......@@ -49,17 +49,21 @@ SKIP: {
skip "NOT using QEMU/LXC driver", 12 unless
$uri eq "qemu:///system" or $uri eq "lxc:///";
my $hook_type = $uri eq "qemu:///system" ? 'qemu' : 'lxc';
my $hook = Sys::Virt::TCK::Hooks->new(type => $hook_type,
conf_dir => '/etc/libvirt/hooks',
expect_result => 0);
$hook->libvirtd_status();
skip "libvirtd is not running, Exit...", 12
if ($hook->{libvirtd_status} eq 'stopped');
my $xml = $tck->generic_domain(name => "tck")->as_xml;
diag "Creating a new persistent domain";
my $dom;
ok_domain(sub { $dom = $conn->define_domain($xml) }, "created persistent domain object");
my $hook_type = $uri eq "qemu:///system" ? 'qemu' : 'lxc';
my $hook = Sys::Virt::TCK::Hooks->new(type => $hook_type,
conf_dir => '/etc/libvirt/hooks',
expect_result => 0);
eval { $hook->prepare(); };
BAIL_OUT "failed to setup hooks testing ENV: $@" if $@;
......
......@@ -12,7 +12,7 @@ uri=$(sed -n '/^uri[ ]*=[ ]*/ {
$ {
x
p
}' < "$LIBVIRT_TCK_CONFIG")
}' < "$LIBVIRT_TCK_CONFIG" | sed -e 's/"//g')
: "${uri:=qemu:///system}"
LIBVIRT_URI=${uri}
......
......@@ -9,7 +9,7 @@ ACCEPT all -- 0.0.0.0/0 10.1.2.0/24 state RELATED,ESTAB
ACCEPT all -- 10.1.2.0/24 0.0.0.0/0
#ip -o route show dev tck-testbr | gawk '{print $1" "$7}'
10.1.2.0/24 10.1.2.1
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p'
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p' | head -1
/dnsmasq/tck-testnet.conf
#grep bind-dynamic `ps aux | sed -n '0,/dnsmasq .*tck-testnet/ s|.*--conf-file=\(.*tck-testnet.conf\).*|\1|p'`
bind-dynamic
......
......@@ -4,7 +4,7 @@ ACCEPT all -- 10.1.2.0/24 0.0.0.0/0
#iptables -t nat -L -n | grep ' 10\.1\.2\.'
#ip -o route show dev tck-testbr | gawk '{print $1" "$7}'
10.1.2.0/24 10.1.2.1
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p'
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p' | head -1
/dnsmasq/tck-testnet.conf
#grep bind-dynamic `ps aux | sed -n '0,/dnsmasq .*tck-testnet/ s|.*--conf-file=\(.*tck-testnet.conf\).*|\1|p'`
bind-dynamic
......
......@@ -12,7 +12,7 @@ ACCEPT all ::/0 2001:db8:ac10:fd01::/64
ACCEPT all 2001:db8:ac10:fd01::/64 ::/0
ACCEPT all ::/0 2001:db8:ac10:fe01::/64
ACCEPT all 2001:db8:ac10:fe01::/64 ::/0
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p'
#ps aux | sed -n '/dnsmasq .*tck-testnet/ s|.*\(\/dnsmasq\/tck-testnet.conf\).*|\1|p' | head -1
/dnsmasq/tck-testnet.conf
#grep bind-dynamic `ps aux | sed -n '0,/dnsmasq .*tck-testnet/ s|.*--conf-file=\(.*tck-testnet.conf\).*|\1|p'`
bind-dynamic
......@@ -22,7 +22,7 @@ dhcp-range=2001:db8:ac10:fe01::1,ra-only
dhcp-range=2001:db8:ac10:fd01::1,ra-only
#brctl show | grep tck-testbr | gawk '{print $1" "$3}'
tck-testbr yes
#ip -o addr show dev tck-testbr | gawk '{print $4" "$6}'
#ip -o addr show dev tck-testbr | gawk '{print $4" "$6}' | grep -v link
10.1.2.1/24 10.1.2.255
192.168.123.1/24 192.168.123.255
172.28.255.241/28 172.28.255.255
......
......@@ -30,7 +30,6 @@ use warnings;
use Test::More tests => 4;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use File::Spec::Functions qw(catfile catdir rootdir);
......@@ -55,11 +54,12 @@ $dom->create;
ok($dom->get_id() > 0, "running domain has an ID > 0");
diag "Waiting for guest to finish booting";
my $iface = get_first_interface_target_dev($dom);
my $stats;
my $tries = 0;
do {
sleep(10);
$stats = $dom->interface_stats("vnet0");
$stats = $dom->interface_stats($iface);
$tries++;
} while ($stats->{"tx_packets"} < 10 && $tries < 10);
......
......@@ -29,7 +29,6 @@ use warnings;
use Test::More tests => 5;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use Net::OpenSSH;
......@@ -59,11 +58,12 @@ $dom->create;
ok($dom->get_id() > 0, "running domain has an ID > 0");
diag "Waiting for guest to finish booting";
my $iface = get_first_interface_target_dev($dom);
my $stats;
my $tries = 0;
do {
sleep(10);
$stats = $dom->interface_stats("vnet0");
$stats = $dom->interface_stats($iface);
$tries++;
} while ($stats->{"tx_packets"} < 10 && $tries < 10);
......@@ -96,7 +96,8 @@ diag "ssh'ing into $guestip";
my $ssh = Net::OpenSSH->new($guestip,
user => "root",
password => $tck->root_password(),
master_opts => [-o => "StrictHostKeyChecking=no"]);
master_opts => [-o => "UserKnownHostsFile=/dev/null",
-o => "StrictHostKeyChecking=off"]);
# now bring eth0 down, change MAC and bring it up again
diag "fiddling with mac";
......
......@@ -29,7 +29,6 @@ use warnings;
use Test::More tests => 4;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use Net::OpenSSH;
......@@ -91,7 +90,8 @@ diag "ssh'ing into $guestip";
my $ssh = Net::OpenSSH->new($guestip,
user => "root",
password => $tck->root_password(),
master_opts => [-o => "StrictHostKeyChecking=no"]);
master_opts => [-o => "UserKnownHostsFile=/dev/null",
-o => "StrictHostKeyChecking=no"]);
# now bring eth0 down, change IP and bring it up again
diag "preparing ip spoof";
......
......@@ -29,7 +29,6 @@ use warnings;
use Test::More tests => 4;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use Net::OpenSSH;
use File::Spec::Functions qw(catfile catdir rootdir);
......@@ -85,11 +84,12 @@ $dom->create;
ok($dom->get_id() > 0, "running domain has an ID > 0");
diag "Waiting for guest to finish booting";
my $iface = get_first_interface_target_dev($dom);
my $stats;
my $tries = 0;
do {
sleep(10);
$stats = $dom->interface_stats("vnet0");
$stats = $dom->interface_stats($iface);
$tries++;
} while ($stats->{"tx_packets"} < 10 && $tries < 10);
......@@ -118,7 +118,8 @@ diag "ssh'ing into $guestip";
my $ssh = Net::OpenSSH->new($guestip,
user => "root",
password => $tck->root_password(),
master_opts => [-o => "StrictHostKeyChecking=no"]);
master_opts => [-o => "UserKnownHostsFile=/dev/null",
-o => "StrictHostKeyChecking=no"]);
# now generate a mac broadcast paket
diag "generate mac broadcast";
......
......@@ -29,7 +29,6 @@ use warnings;
use Test::More tests => 4;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use Net::OpenSSH;
use File::Spec::Functions qw(catfile catdir rootdir);
......@@ -58,11 +57,12 @@ $dom->create;
ok($dom->get_id() > 0, "running domain has an ID > 0");
diag "Waiting for guest to finish booting";
my $iface = get_first_interface_target_dev($dom);
my $stats;
my $tries = 0;
do {
sleep(10);
$stats = $dom->interface_stats("vnet0");
$stats = $dom->interface_stats($iface);
$tries++;
} while ($stats->{"tx_packets"} < 10 && $tries < 10);
......@@ -99,7 +99,8 @@ diag "ssh'ing into $guestip";
my $ssh = Net::OpenSSH->new($guestip,
user => "root",
password => $tck->root_password(),
master_opts => [-o => "StrictHostKeyChecking=no"]);
master_opts => [-o => "UserKnownHostsFile=/dev/null",
-o => "StrictHostKeyChecking=no"]);
# now generate a arp spoofing packets
diag "generate arpspoof script";
......
......@@ -29,7 +29,6 @@ use warnings;
use Test::More;
use Sys::Virt::TCK;
use Sys::Virt::TCK::NetworkHelpers;
use Test::Exception;
use File::Spec::Functions qw(catfile catdir rootdir);
......
......@@ -16,7 +16,7 @@ VIRSH=virsh
$ {
x
p
}' < "$LIBVIRT_TCK_CONFIG")
}' < "$LIBVIRT_TCK_CONFIG" | sed -e 's/"//g')
: "${uri:=qemu:///system}"
LIBVIRT_URI=${uri}
......
......@@ -12,7 +12,7 @@ uri=$(sed -n '/^uri[ ]*=[ ]*/ {
$ {
x
p
}' < "$LIBVIRT_TCK_CONFIG")
}' < "$LIBVIRT_TCK_CONFIG" | sed -e 's/"//g')
: "${uri:=qemu:///system}"
LIBVIRT_URI=${uri}
......
......@@ -42,6 +42,7 @@ END { $tck->cleanup if $tck; }
SKIP: {
skip "Only relevant to QEMU driver", 8 unless $conn->get_type() eq "QEMU";
skip "Libvirt LUKS support isn't ready", 8;
my $dir = $tck->bucket_dir("300-disk-encryption");
my $disk = catfile($dir, "demo.qcow2");
......@@ -76,6 +77,7 @@ lives_ok(sub { $pool = $conn->create_storage_pool($poolXML) }, "pool created");
my $volXML = Sys::Virt::TCK::StorageVolBuilder->new(name => "demo.qcow2")
->capacity(1024*1024*1024)
->format("qcow2")
->encryption_format("luks")
->secret($secretUUID)
->as_xml();
......@@ -86,6 +88,7 @@ lives_ok(sub { $vol = $pool->create_volume($volXML) }, "volume created");
my $xml = $tck->generic_domain(name => "tck")
->disk(format => { name => "qemu", type => "qcow2" },
encryption_format => "luks",
secret => $secretUUID,
type => "file",
src => $disk,
......
......@@ -62,9 +62,9 @@ SKIP: {
my $dom;
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
my $domainlabel = xpath($dom, "string(/domain/seclabel/label)");
my $domainlabel = xpath($dom, "string(/domain/seclabel[\@model='selinux']/label)");
diag "domainlabel $domainlabel";
my $imagelabel = xpath($dom, "string(/domain/seclabel/imagelabel)");
my $imagelabel = xpath($dom, "string(/domain/seclabel[\@model='selinux']/imagelabel)");
diag "imagelabel $imagelabel";
is($origdomainlabel, $domainlabel, "static label is $domainlabel");
......
......@@ -28,7 +28,7 @@ and files can be relabelled
use strict;
use warnings;
use Test::More tests => 5;
use Test::More tests => 6;
use Sys::Virt::TCK;
use Sys::Virt::TCK::SELinux;
......@@ -62,9 +62,9 @@ SKIP: {
ok_domain(sub { $dom = $conn->create_domain($xml) }, "created transient domain object");
diag $dom->get_xml_description();
my $domainlabel = xpath($dom, "string(/domain/seclabel/label)");
my $domainlabel = xpath($dom, "string(/domain/seclabel[\@model='selinux']/label)");
diag "domainlabel $domainlabel";
my $imagelabel = xpath($dom, "string(/domain/seclabel/imagelabel)");
my $imagelabel = xpath($dom, "string(/domain/seclabel[\@model='selinux']/imagelabel)");
diag "imagelabel $imagelabel";
my $imagetype = selinux_get_type($imagelabel);
my $imagemcs = selinux_get_mcs($imagelabel);
......
......@@ -28,7 +28,7 @@ with a filesystem pool.
use strict;
use warnings;
use Test::More tests => 33;
use Test::More tests => 29;
use Sys::Virt::TCK;
use Test::Exception;
......@@ -56,7 +56,6 @@ lives_ok(sub { $pool->create }, "started storage pool");
my $volsparsexml = $tck->generic_volume("tck1", "raw", 1024*1024*50)->allocation(0)->as_xml;
my $volallocxml = $tck->generic_volume("tck2", "raw", 1024*1024*50)->allocation(1024*1024*50)->as_xml;
my $volcowxml = $tck->generic_volume("tck3", "cow", 1024*1024*50)->as_xml;
my $volqcow1xml = $tck->generic_volume("tck4", "qcow", 1024*1024*50)->as_xml;
my $volqcow2xml = $tck->generic_volume("tck5", "qcow2", 1024*1024*50)->as_xml;
my $volvmdkxml = $tck->generic_volume("tck6", "vmdk", 1024*1024*50)->as_xml;
......@@ -100,22 +99,6 @@ lives_ok(sub { $vol->delete(0) }, "deleted volume");
ok_volume { $vol = $pool->create_volume($volcowxml) } "create cow volume";
$path = xpath($vol, "string(/volume/target/path)");
$st = stat($path);
ok($st, "path $path exists");
# Don't know exactly how large a cow empty file is, but it
# should be quite small :-)
ok($st->size < 1024*1024, "basic cow header is allocated");
lives_ok(sub { $vol->delete(0) }, "deleted volume");
ok_volume(sub { $vol = $pool->create_volume($volqcow1xml) }, "create qcow volume");
$path = xpath($vol, "string(/volume/target/path)");
......
......@@ -31,7 +31,7 @@ checksummed and validated
use strict;
use warnings;
use Test::More tests => 61;
use Test::More tests => 52;
use Sys::Virt::TCK;
use Test::Exception;
......@@ -103,7 +103,7 @@ my $srcdigest = &digest($path);
diag "Now testing cloning of various formats";
my @formats = qw(raw cow qcow qcow2 vmdk vpc);
my @formats = qw(raw qcow qcow2 vmdk vpc);
foreach my $format (@formats) {
diag "Cloning source volume to $format format";
......
# -*- perl -*-
use strict;
use warnings;
use Test::More;
eval 'use Test::CPAN::Changes';
plan skip_all => 'Test::CPAN::Changes required for this test' if $@;
changes_ok();
......@@ -54,7 +54,11 @@ my $conn = Sys::Virt->new(address => "test:///default");
my $b = Sys::Virt::TCK::DomainBuilder->new(conn => $conn, domain => "xen", ostype => 'hvm')
->with_acpi->memory(500*1025)->vcpu(3)
->disk(format => { name => "qemu", type => "qcow2" }, type => 'block', src => "/dev/hda1", dst => "/dev/xvda", bus => "xen", secret => "0a81f5b2-8403-7b23-c8d6-21ccc2f80d6f")
->disk(format => { name => "qemu", type => "qcow2" },
type => 'block', src => "/dev/hda1",
dst => "/dev/xvda", bus => "xen",
secret => "0a81f5b2-8403-7b23-c8d6-21ccc2f80d6f",
encryption_format => "qcow")
->seclabel(model => "selinux", relabel => "flat", type => "hybrid", baselabel => "system_u:system_r:svirt_t:s0")
->as_xml;
......
......@@ -37,6 +37,7 @@ chomp $xml;
my $b = Sys::Virt::TCK::StorageVolBuilder->new()
->capacity(1000000)->allocation(1000000)
->format("qcow2")
->encryption_format("qcow")
->secret("0a81f5b2-8403-7b23-c8d6-21ccc2f80d6f")
->as_xml;
......