Hi,
I got a bit confused how snapshotting/reverting is supposed to work now
so I added some tests. O.k. to apply?
This requires Sys::Virt 0.9.5.
Cheers,
-- Guido
---
Build.PL | 2 +-
perl-Sys-Virt-TCK.spec.PL | 2 +-
scripts/domain/400-snapshots.t | 127 ++++++++++++++++++++++++++++++++++++++++
3 files changed, 129 insertions(+), 2 deletions(-)
create mode 100644 scripts/domain/400-snapshots.t
diff --git a/Build.PL b/Build.PL
index b0c53a2..0b373bf 100644
--- a/Build.PL
+++ b/Build.PL
@@ -85,7 +85,7 @@ my $b = $class->new(
'Test::Builder' => 0,
'Test::More' => 0,
'Sub::Uplevel' => 0,
- 'Sys::Virt' => '0.2.0',
+ 'Sys::Virt' => '0.9.5',
'XML::Twig' => 0,
'XML::Writer' => 0,
'XML::XPath' => 0,
diff --git a/perl-Sys-Virt-TCK.spec.PL b/perl-Sys-Virt-TCK.spec.PL
index b6a989e..4ebbcd0 100644
--- a/perl-Sys-Virt-TCK.spec.PL
+++ b/perl-Sys-Virt-TCK.spec.PL
@@ -63,7 +63,7 @@ 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.9.5
BuildRequires: perl(XML::Twig)
BuildRequires: perl(XML::Writer)
# RPM autoprovides misses these 3
diff --git a/scripts/domain/400-snapshots.t b/scripts/domain/400-snapshots.t
new file mode 100644
index 0000000..4c3a636
--- /dev/null
+++ b/scripts/domain/400-snapshots.t
@@ -0,0 +1,127 @@
+# -*- perl -*-
+#
+# Copyright (C) 2011 Univention GmbH
+# Author: Guido Guenther <agx@xxxxxxxxxxx>
+#
+# This program is free software; You can redistribute it and/or modify
+# it under the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any
+# later version
+#
+# The file "LICENSE" distributed along with this file provides full
+# details of the terms and conditions
+#
+
+=pod
+
+=head1 NAME
+
+domain/400-snapshot.t - Check snapshot operations
+
+=head1 DESCRIPTION
+
+Check if snapshots can be created and deleted. Check if a snapshot gets
+associated with the right vm metadata when reverting snapshots.
+
+=cut
+
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+
+use Sys::Virt::TCK;
+use Test::Exception;
+
+my $tck = Sys::Virt::TCK->new();
+my $conn = eval { $tck->setup(); };
+BAIL_OUT "failed to setup test harness: $@" if $@;
+END { $tck->cleanup if $tck; }
+
+SKIP: {
+ my ($pool, $vol, $dom, $snap1, $snap2);
+ my $minmem = 64 * 1024;
+ my $maxmem = $minmem * 2;
+ my $snapshots = 0;
+
+ my $poolxml = $tck->generic_pool("dir")
+ ->mode("0755")->as_xml;
+
+ diag "Defining transient storage pool $poolxml";
+ ok_pool(sub { $pool = $conn->define_storage_pool($poolxml) }, "define transient storage pool");
+ lives_ok(sub { $pool->build(0) }, "built storage pool");
+ lives_ok(sub { $pool->create }, "started storage pool");
+
+ my $volxml = $tck->generic_volume("tck.img", "qcow2", 1024*1024*50)
+ ->allocation(0)->as_xml;
+ ok_volume(sub { $vol = $pool->create_volume($volxml) }, "creating qcow2 volume $volxml");
+ my $pathvol = xpath($vol, "string(/volume/target/path)");
+
+ my $gd = $tck->generic_domain("tck")
+ ->memory($minmem);
+ $gd->rmdisk;
+ my $domxml = $gd->disk(format => { name => "qemu", type => "qcow2" },
+ type => "file",
+ src => $pathvol,
+ dst => "vda")->as_xml;
+
+ ok_domain(sub { $dom = $conn->define_domain($domxml) }, "defined persistent domain");
+ lives_ok(sub {$dom->create() }, "started domain");
+
+ my $currmem = int(xpath($dom, "number(/domain/currentMemory)"));
+ is($currmem, $minmem, "XML description has memory set to $minmem");
+
+ my $snap1xml = <<EOF;
+<domainsnapshot>
+ <name>Snapshot1</name>
+ <description>First snapshot</description>
+</domainsnapshot>
+EOF
+ diag "Create first snapshot";
+ eval { $snap1 = $dom->create_snapshot($snap1xml); };
+ skip "Snapshots not implemented", 16 if $@ && err_not_implemented($@);
+ ok(!$@, "Snapshot created");
+ die $@ if $@;
+ $snapshots++;
+
+ lives_ok( sub { $dom->destroy() }, "Domain destroyed");
+ lives_ok(sub { $dom->set_max_memory($maxmem) }, "Doubled memory to $maxmem");
+ lives_ok(sub {$dom->create() }, "started domain");
+
+ $currmem = int(xpath($dom, "number(/domain/currentMemory)"));
+ is($currmem, $maxmem, "XML description has memory set to $maxmem");
+
+ my $snap2xml = <<EOF;
+<domainsnapshot>
+ <name>Snapshot2</name>
+ <description>Second snapshot</description>
+</domainsnapshot>
+EOF
+ ok_domain_snapshot( sub { $snap2 = $dom->create_snapshot($snap2xml) }, "create second snapshot $snap2xml");
+ $snapshots++;
+ is($dom->num_of_snapshots(), $snapshots, "We have $snapshots snapshots");
+
+ # Reverting to the same vm configuration is o.k.
+ lives_ok( sub { $snap2->revert_to() }, "Reverting to snapshot snapshot 2");
+
+ # Reverting to another vm configuration would involve killing qemu so this
+ # is rejected:
+ ok_error( sub { $snap1->revert_to() }, "Reverting to changed vm configuration not supported", Sys::Virt::Error::ERR_CONFIG_UNSUPPORTED);
+
+ # Reverting to another vm configiguration while shut off is o.k.:
+ lives_ok( sub { $dom->destroy() }, "Domain destroyed");
+ lives_ok( sub { $snap1->revert_to() }, "Reverting to snapshot snapshot 1 with vm shutoff");
+ $currmem = int(xpath($dom, "number(/domain/currentMemory)"));
+ is($currmem, $minmem, "Memory is $minmem");
+
+ is($dom->num_of_snapshots(), $snapshots, "We have $snapshots snapshots");
+
+ $snap1->delete();
+ $snapshots--;
+ is($dom->num_of_snapshots(), $snapshots, "We have $snapshots snapshots");
+
+ $snap2->delete();
+ $snapshots--;
+ is($dom->num_of_snapshots(), $snapshots, "We have $snapshots snapshots");
+ is($snapshots, 0, "All snapshots are gone");
+}
--
1.7.6.3
--
libvir-list mailing list
libvir-list@xxxxxxxxxx
https://www.redhat.com/mailman/listinfo/libvir-list