[PATCH] libvirt-tck: Add testcase to test snapshot functionality.

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

 



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


[Index of Archives]     [Virt Tools]     [Libvirt Users]     [Lib OS Info]     [Fedora Users]     [Fedora Desktop]     [Fedora SELinux]     [Big List of Linux Books]     [Yosemite News]     [KDE Users]     [Fedora Tools]