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(a)sigxcpu.org&gt; +# +# 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