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

#!/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));