Bug#857499: libsys-virt-perl: Invalid pointer exception in perl when calling $dom->get_job_stats

[Sten Kokel]

Package: libsys-virt-perl
Version: 3.0.0-1
Severity: normal

Dear Maintainer,

I created an external disk-only snapshot on a dom having one disk image. Then
I started an active block commit to merge snapshot back to original disk image.
My next call to get_job_stats() to check for completion of the commit  results 
in a segmentation fault.

See attached sample of perl script. The script implements the whole scenario from
creation of the external snapshot to the active commit to the call of get_job_stats()
on the last line that fails with segmentation fault.

-- System Information:
Debian Release: 9.0
  APT prefers testing
  APT policy: (500, 'testing')
Architecture: amd64 (x86_64)

Kernel: Linux 4.9.0-1-amd64 (SMP w/4 CPU cores)
Locale: LANG=de_DE.UTF-8, LC_CTYPE=de_DE.UTF-8 (charmap=UTF-8)
Shell: /bin/sh linked to /bin/dash
Init: systemd (via /run/systemd/system)

Versions of packages libsys-virt-perl depends on:
ii  libc6                       2.24-9
ii  libvirt0                    3.0.0-3
ii  perl                        5.24.1-1
ii  perl-base [perlapi-5.24.1]  5.24.1-1

libsys-virt-perl recommends no packages.

libsys-virt-perl suggests no packages.

-- no debconf information
-------------- next part --------------
#!/usr/bin/perl
use strict;
use Sys::Virt;
use XML::Simple;
use Data::Dumper;

# find qcow2-Disks for backup
sub getListOfDisksForSnapshot {
	my $domConfig = shift;
	my @disks;
	
	if(ref($domConfig) eq 'HASH') {
		foreach my $disk (@{$domConfig->{'devices'}->[0]->{'disk'}}) {
			my $diskSnap = { 'name' => $disk->{'target'}->[0]->{'dev'} };
			
			if($disk->{'driver'}->{'qemu'}->{'type'} eq 'qcow2') {
				# qcow2-disc for snapshot
				$diskSnap->{'snapshot'} = 'external';
				$diskSnap->{'driver'}->{'type'} = 'qcow2'; 
			} else {
				# non qcow2-disc to exclude from snapshot
				$diskSnap->{'snapshot'} = 'no';
			}
			
			push(@disks, $diskSnap);
		}		
	} else {
		die('(getListOfDisksForSnapshot) - Missing dom-config.');
	}
	
	return \@disks;
}

### Main
my $host = Sys::Virt->new(uri => "qemu:///system");
my $dom = $host->get_domain_by_name('Gateway');

# deserialize XML-domconfig
my $domConfig = XMLin($dom->get_xml_description(), 'ForceArray' => 1);

# get list of qcow2-images from $domConfig
my $disksForSnapshot = getListOfDisksForSnapshot($domConfig);

# Preparation: create disk-only snapshot vor vm if there is no backing chain active.
if(not defined($domConfig->{'devices'}->[0]->{'disk'}->[0]->{'backingStore'}->[0]->{'index'})) {

	my $snapshotConf = {  'name' => { '_text' => 'Snapshot' }
						, 'description' => { '_text' => 'Vom Backup-Skript automatisch am ' . time . ' erstellter Snapshot.' }
						, 'memory' => { 'snapshot' => 'no' }
						, disks => { 'disk' => $disksForSnapshot }
						};

	print "###### Config for snapshot:\n" . XMLout($snapshotConf, 'RootName' => 'domainsnapshot', 'ContentKey' => '_text') . "####### End of snapshot config\n";

	# create snapshot
	my $flags =	Sys::Virt::DomainSnapshot::CREATE_ATOMIC
			+ Sys::Virt::DomainSnapshot::CREATE_NO_METADATA
			+ Sys::Virt::DomainSnapshot::CREATE_DISK_ONLY;

	my $snapshot = $dom->create_snapshot(XMLout($snapshotConf, 'RootName' => 'domainsnapshot', 'ContentKey' => '_text'), $flags);

	print "New snapshot created.\n";
} else {
	print "Skip creation of new snapshot. Found active backing chain.\n";
}

# Start active block commit for the first disk
	# renew dom config
	$domConfig = XMLin($dom->get_xml_description(), 'ForceArray' => 1);
	
	my $path = $disksForSnapshot->[0]->{'name'};
	my $base = '';
	my $top = '';
	
	foreach my $disk (@{$domConfig->{'devices'}->[0]->{'disk'}}) {
		# search for disk $path in $domConfig
		if($disk->{'target'}->[0]->{'dev'} eq $path) {
			$base = $disk->{'backingStore'}->[0]->{'source'}->[0]->{'file'};
			$top = $disk->{'source'}->[0]->{'file'};
			
			last();
		}
	}
	
	if($base ne '' && $top ne '') {
	
		my $flags =	  Sys::Virt::Domain::BLOCK_COMMIT_ACTIVE;
		
		print "Starting active block commit for $path from $top into $base ... ";

		eval {
			$dom->block_commit($path, $base, $top, 0, $flags)
		};

		if($@) {
			print "commit failed. $@\n";
		}
	} else {
		print "Could not resolve all params for commit";
		die();
	}


# get state of commit-job to see if it completed

	print "Get job state for Domain:\n";
	
 	print Dumper($dom->get_job_stats(Sys::Virt::Domain::JOB_STATS_COMPLETED));