[Libguestfs] [PATCH 6/6] Fix application installation by GuestOS

9 Feb 2010

Rewrite the code to create the transfer ISO to use the new XML config file
format, and move it out of GuestOS in to virt-v2v.pl
---
 lib/Sys/VirtV2V/GuestOS.pm        |  217 +++++++++++++++-------------
 lib/Sys/VirtV2V/GuestOS/RedHat.pm |  294 ++++++++++++++++---------------------
 v2v/virt-v2v.pl                   |   94 +++++++++++-
 3 files changed, 328 insertions(+), 277 deletions(-)

diff --git a/lib/Sys/VirtV2V/GuestOS.pm b/lib/Sys/VirtV2V/GuestOS.pm
index 1db7590..539659e 100644
--- a/lib/Sys/VirtV2V/GuestOS.pm
+++ b/lib/Sys/VirtV2V/GuestOS.pm
@@ -43,7 +43,7 @@ Sys::VirtV2V::GuestOS - Manipulate and query a Guest OS
 
  use Sys::VirtV2V::GuestOS;
 
- $guestos = Sys::VirtV2V::GuestOS->instantiate($g, $desc);
+ $guestos = Sys::VirtV2V::GuestOS->new($g, $desc, $dom, $config);
 
 =head1 DESCRIPTION
 
@@ -57,25 +57,11 @@ implements methods to access backends.
 Sys::VirtV2V::GuestOS uses L<Module::Pluggable> to automatically discover
 backends under Sys::VirtV2V::GuestOS.
 
-=cut
-
-# A map of file labels to their paths relative to the transfer device
-my %files;
-
-# A map of file labels to their dependencies
-my %deps;
-
-# A map of file labels aliases
-my %aliases;
-
-# The path (on the host) to the transfer iso
-my $transferiso;
-
 =head1 METHODS
 
 =over
 
-=item instantiate(g, desc)
+=item new(g, desc, dom, config)
 
 Instantiate a GuestOS object capable of manipulating the target OS.
 
@@ -89,123 +75,162 @@ A L<Sys::Guestfs> handle.
 
 An OS description created by L<Sys::Guestfs::Lib>.
 
+=item dom
+
+An XML::DOM object containing the guest's libvirt domain XML prior to
+conversion.
+
+=item config
+
+An XML::DOM object containing the virt-v2v configuration.
+
 =back
 
-Returns a capable Sys::VirtV2V::GuestOS backend if one is found.
+Returns a capable Sys::VirtV2V::GuestOS if one is found.
 
 Returns undef otherwise.
 
 =cut
 
-sub instantiate
+sub new
 {
     my $class = shift;
 
-    my ($g, $desc) = @_;
-    defined($g) or carp("get_instance called without g argument");
-    defined($desc) or carp("get_instance called without desc argument");
+    my ($g, $desc, $dom, $config) = @_;
+    defined($g)      or carp("instantiate called without g argument");
+    defined($desc)   or carp("instantiate called without desc argument");
+    defined($dom)    or carp("instantiate called without dom argument");
+    defined($config) or carp("instantiate called without config argument");
+
+    my $self = {};
+
+    $self->{g}      = $g;
+    $self->{desc}   = $desc;
+    $self->{dom}    = $dom;
+    $self->{config} = $config;
 
     foreach my $module ($class->modules()) {
-        return $module->new($g, $desc, \%files, \%deps, \%aliases)
-                if($module->can_handle($desc));
+        return $module->new($self)
+            if($module->can_handle($desc));
     }
 
     return undef;
 }
 
-=item configure(config)
+=item get_ncpus
 
-=over
+Return the number of CPUS which are available to this guest
 
-=item config
+=cut
 
-The parsed virt-v2v config file, as returned by Config::Tiny.
+sub get_ncpus
+{
+    my $self = shift;
 
-=back
+    my ($ncpus) = $self->{dom}->findnodes('/domain/vcpu/text()');
+    if (defined($ncpus)) {
+        return $ncpus->getData();
+    } else {
+        return 1;
+    }
+}
+
+=item get_memory_kb
 
-Read the [files], [deps] and [aliases] sections of the virt-v2v config file.
-Create the transfer iso from the contents of [files].
+Return the amount of memory, in KB, which is available to this guest
 
 =cut
 
-sub configure
+sub get_memory_kb
 {
-    my $class = shift;
+    my $self = shift;
 
-    my $config = shift;
+    my ($mem_kb) = $self->{dom}->findnodes('/domain/memory/text()');
 
-    carp("configure called without config argument") unless(defined($config));
+    return $mem_kb->getData();
+}
 
-    # Lookup the [files] config section
-    my $files_conf = $config->{files};
+=item match_app
 
-    # Do nothing if there is no [files] config section
-    return unless(defined($files_conf));
+Return a matching app entry from the virt-v2v configuration. The entry is
+returned as a hashref containing 2 entries. I<path> contains the path to the
+application itself. I<deps> contains an arrayref containing the paths of all the
+app's listed dependencies.
 
-    # A hash, whose labels are filenames to be added to the transfer iso. We use
-    # a hash here to remove duplicates.
-    my %paths = ();
-    foreach my $label (keys(%$files_conf)) {
-        my $path = $files_conf->{$label};
+=cut
 
-        unless(-f $path && -r $path) {
-            print STDERR user_message(__x("WARNING: unable to access {path}.",
-                                          path => $path));
-            next;
-        }
+sub match_app
+{
+    my $self = shift;
 
-        $paths{$path} = 1;
+    my ($name, $arch) = @_;
 
-        # As transfer directory hierarchy is flat, remove all directory
-        # components from paths
-        my (undef, undef, $filename) = File::Spec->splitpath($path);
-        $files{$label} = $filename;
-    }
+    my $config = $self->{config};
 
-    # Do nothing if there are no files defined
-    return if(keys(%paths) == 0);
-
-    $transferiso = File::Temp->new(UNLINK => 1, SUFFIX => '.iso');
-    my $eh = Sys::VirtV2V::ExecHelper->run
-        ('mkisofs', '-o', $transferiso, '-r', '-J',
-         '-V', '__virt-v2v_transfer__', keys(%paths));
-    if($eh->status() != 0) {
-        print STDERR user_message(__x("Failed to create transfer iso. Command ".
-                                      "output was:\n{output}",
-                                      output => $eh->output()));
-    }
+    my $desc   = $self->{desc};
+    my $distro = $desc->{distro};
+    my $major  = $desc->{major_version};
+    my $minor  = $desc->{minor_version};
+
+    # Check we've got at least a distro from OS detection
+    die(user_message(__"Didn't detect OS distribution"))
+        unless (defined($distro));
+
+    # Create a list of xpath queries against the config which look for a
+    # matching <app> config entry in descending order of specificity
 
-    # Populate deps from the [deps] config section
-    my $deps_conf = $config->{deps};
+    my $prefix = "/virt-v2v/app[\@os='$distro' and \@name='$name'";
 
-    if(defined($deps_conf)) {
-        # Copy the deps_conf hash into %deps
-        foreach my $label (keys(%$deps_conf)) {
-            $deps{$label} = $deps_conf->{$label};
+    my @queries;
+    if (defined($major)) {
+        if (defined($minor)) {
+            push(@queries, $prefix." and \@major='$major' ".
+                                   "and \@minor='$minor' and \@arch='$arch']");
+            push(@queries, $prefix." and \@major='$major' ".
+                                   "and \@minor='$minor']");
         }
+
+        push(@queries, $prefix." and \@major='$major' and \@arch='$arch']");
+        push(@queries, $prefix." and \@major='$major']");
     }
 
-    # Populate aliases from the [aliases] config section
-    my $aliases_conf = $config->{aliases};
+    push(@queries, $prefix." and \@arch='$arch']");
+    push(@queries, $prefix."]");
 
-    if(defined($aliases_conf)) {
-        # Copy the aliases_conf hash into %aliases
-        foreach my $label (keys(%$aliases_conf)) {
-            $aliases{$label} = $aliases_conf->{$label};
-        }
+    # Use the results of the first query which returns a result
+    my $app;
+    foreach my $query (@queries) {
+        ($app) = $config->findnodes($query);
+        last if (defined($app));
     }
-}
 
-=item get_transfer_iso
+    unless (defined($app)) {
+        my $search = "distro='$distro' name='$name'";
+        $search .= " major='$major'" if (defined($major));
+        $search .= " minor='$minor'" if (defined($minor));
+        $search .= " arch='$arch'";
 
-Return the path (on the host) to the transfer iso image. L</configure> must have
-been called first.
+        die(user_message(__x("No app in config matches {search}",
+                             search => $search)));
+    }
 
-=cut
+    my %app;
+    my ($path) = $app->findnodes('path/text()');
+    die(user_message(__x("app entry in config doesn't contain a path: {xml}",
+                         xml => $app->toString()))) unless (defined($path));
+    $path = $path->getData();
 
-sub get_transfer_iso
-{
-    return $transferiso;
+    my @deps;
+    foreach my $dep ($app->findnodes('dep/text()')) {
+        push(@deps, $dep->getData());
+    }
+
+    # Return a hash containing the application path and its dependencies
+    my %ret;
+    $ret{path} = $path;
+    $ret{deps} = \@deps;
+
+    return \%ret;
 }
 
 =back
@@ -242,21 +267,15 @@ A L<Sys::Guestfs> handle.
 
 An OS description created by L<Sys::Guestfs::Lib>.
 
-=item files
-
-A hash containing 'label => filename' mappings. These mappings are consulted
-when a guest needs to install a specific application.
+=item dom
 
-=item deps
+A parsed XML::DOM containing the libvirt domain XML for this guest prior to any
+conversion.
 
-A hash containing 'label => C<space separated dependency list>'. The
-dependencies are given as labels rather than specific files. This is used to
-install dependencies when installing an application in the guest.
-
-=item aliases
+=item config
 
-A hack containing 'label => alias'. Aliases are given as labels rather than
-specific files. This is used to substitute packages during installation.
+A parsed XML::DOM containing the virt-v2v configuration, or undef if there is
+no config.
 
 =back
 
diff --git a/lib/Sys/VirtV2V/GuestOS/RedHat.pm b/lib/Sys/VirtV2V/GuestOS/RedHat.pm
index 920eea2..d6abe9b 100644
--- a/lib/Sys/VirtV2V/GuestOS/RedHat.pm
+++ b/lib/Sys/VirtV2V/GuestOS/RedHat.pm
@@ -17,9 +17,13 @@
 
 package Sys::VirtV2V::GuestOS::RedHat;
 
+our @ISA = ('Sys::VirtV2V::GuestOS');
+
 use strict;
 use warnings;
 
+use File::Spec;
+
 use Sys::Guestfs::Lib qw(inspect_linux_kernel);
 use Sys::VirtV2V::UserMessage qw(user_message);
 
@@ -65,7 +69,7 @@ sub can_handle
     return ($desc->{os} eq 'linux') && ($desc->{package_format} eq 'rpm');
 }
 
-=item Sys::VirtV2V::GuestOS::RedHat->new(g, desc, files, deps, aliases)
+=item Sys::VirtV2V::GuestOS::RedHat->new(self)
 
 See BACKEND INTERFACE in L<Sys::VirtV2V::GuestOS> for details.
 
@@ -75,27 +79,9 @@ sub new
 {
     my $class = shift;
 
-    my $self = {};
-
-    # Guest handle
-    my $g = $self->{g} = shift;
-    carp("new called without guest handle") unless defined($g);
-
-    # Guest description
-    $self->{desc} = shift;
-    carp("new called without guest description") unless defined($self->{desc});
-
-    # Guest file map
-    $self->{files} = shift;
-    carp("new called without files description") unless defined($self->{files});
-
-    # Guest dependency map
-    $self->{deps} = shift;
-    carp("new called without dependencies") unless defined($self->{deps});
-
-    # Guest alias map
-    $self->{aliases} = shift;
-    carp("new called without aliases") unless defined($self->{aliases});
+    # Self object
+    my $self = shift;
+    carp("new called without self object") unless defined($self);
 
     bless($self, $class);
 
@@ -475,32 +461,113 @@ sub add_kernel
 
     my ($kernel_pkg, $kernel_arch) = $self->_discover_kernel();
 
-    # Install the kernel's dependencies
-    $self->_install_rpms(1, $self->_resolve_deps($kernel_pkg));
+    # If the guest is using a Xen PV kernel, choose an appropriate normal kernel
+    # replacement
+    if ($kernel_pkg eq "kernel-xen" || $kernel_pkg eq "kernel-xenU") {
+        my $desc = $self->{desc};
+
+        # Make an informed choice about a replacement kernel for distros we know
+        # about
+
+        # RHEL 5
+        if ($desc->{distro} eq 'rhel' && $desc->{major_version} eq '5') {
+            if ($kernel_arch eq 'i686') {
+                # XXX: This assumes that PAE will be available in the
+                # hypervisor. While this is almost certainly true, it's
+                # theoretically possible that it isn't. The information we need
+                # is available in the capabilities XML.
+                # If PAE isn't available, we should choose 'kernel'.
+                $kernel_pkg = 'kernel-PAE';
+            }
+
+            # There's only 1 kernel package on RHEL 5 x86_64
+            else {
+                $kernel_pkg = 'kernel';
+            }
+        }
+
+        # RHEL 4
+        elsif ($desc->{distro} eq 'rhel' && $desc->{major_version} eq '4') {
+            my $ncpus = $self->get_ncpus();
+
+            if ($kernel_arch eq 'i686') {
+                # If the guest has > 10G RAM, give it a hugemem kernel
+                if ($self->get_memory_kb() > 10 * 1024 * 1024) {
+                    $kernel_pkg = 'kernel-hugemem';
+                }
+
+                # SMP kernel for guests with >1 CPU
+                elsif ($ncpus > 1) {
+                    $kernel_pkg = 'kernel-smp';
+                }
+
+                else {
+                    $kernel_pkg = 'kernel';
+                }
+            }
+
+            else {
+                if ($ncpus > 8) {
+                    $kernel_pkg = 'kernel-largesmp';
+                }
+
+                elsif ($ncpus > 1) {
+                    $kernel_pkg = 'kernel-smp';
+                }
+
+                else {
+                    $kernel_pkg = 'kernel';
+                }
+            }
+        }
 
-    my $filename;
+        # RHEL 3 didn't have a xen kernel
+
+        # XXX: Could do with a history of Fedora kernels in here
+
+        # For other distros, be conservative and just return 'kernel'
+        else {
+            $kernel_pkg = 'kernel';
+        }
+    }
+
+    my $app;
     eval {
-        # Get a matching rpm
-        $filename = $self->_match_file($kernel_pkg, $kernel_arch);
+        $app = $self->match_app($kernel_pkg, $kernel_arch);
     };
-
     # Return undef if we didn't find a kernel
+    if ($@) {
+        print STDERR $@;
+        return undef;
+    }
+
+    my $path = $app->{path};
+
+    my @install;
+    # Install any kernel dependencies which aren't already installed
+    foreach my $dep (@{$app->{deps}}) {
+        push(@install, $dep) unless($self->_is_installed($dep));
+    }
+    $self->_install_rpms(1, @install);
+
     return undef if($@);
 
     # Inspect the rpm to work out what kernel version it contains
     my $version;
     my $g = $self->{g};
-    foreach my $file ($g->command_lines(["rpm", "-qlp", $filename])) {
+    foreach my $file ($g->command_lines
+        (["rpm", "-qlp", $self->_transfer_path($path)]))
+    {
         if($file =~ m{^/boot/vmlinuz-(.*)$}) {
             $version = $1;
             last;
         }
     }
 
-    die(user_message(__x("{filename} doesn't contain a valid kernel",
-                         filename => $filename))) if(!defined($version));
+    die(user_message(__x("{path} doesn't contain a valid kernel",
+                         path => $path))) if(!defined($version));
 
-    $self->_install_rpms(0, ($filename));
+    $self->_install_rpms(0, ($path));
 
     # Make augeas reload so it'll find the new kernel
     $g->aug_load();
@@ -508,7 +575,7 @@ sub add_kernel
     return $version;
 }
 
-# Inspect the guest description to work out what kernel should be installed.
+# Inspect the guest description to work out what kernel package is in use
 # Returns ($kernel_pkg, $kernel_arch)
 sub _discover_kernel
 {
@@ -602,63 +669,21 @@ sub add_application
 
     my $user_arch = $self->{desc}->{arch};
 
-    # Get the rpm for this label
-    my $rpm = $self->_match_file($label, $user_arch);
+    my $app = $self->match_app($label, $user_arch);
 
     # Nothing to do if it's already installed
-    return if(_is_installed($rpm));
+    return if($self->_is_installed($app->{path}));
 
-    my @install = ($rpm);
+    my @install = ($app->{path});
 
-    # Add the dependencies to the install set
-    push(@install, $self->_resolve_deps($label));
+    # Add any dependencies which aren't already installed to the install set
+    foreach my $dep (@{$app->{deps}}) {
+        push(@install, $dep) unless ($self->_is_installed($dep));
+    }
 
     $self->_install_rpms(1, @install);
 }
 
-# Return a list of dependencies which must be installed before $label can be
-# installed. The list contains paths of rpm files. It does not contain the rpm
-# for $label itself. This is so _resolve_deps can be used to install kernel
-# dependencies with -U before the kernel itself is installed with -i.
-sub _resolve_deps
-{
-    my $self = shift;
-
-    my ($label, @path) = @_;
-
-    my $user_arch = $self->{desc}->{arch};
-
-    # Check for an alias for $label
-    $label = $self->_resolve_alias($label, $user_arch);
-
-    # Check that the dependency path doesn't include the given label. If it
-    # does, that's a dependency loop.
-    if(grep(/\Q$label\E/, @path) > 0) {
-        die(user_message(__x("Found dependency loop installing {label}: {path}",
-                             label => $label, path => join(' ', @path))));
-    }
-    push(@path, $label);
-
-    my $g = $self->{g};
-
-    my @depfiles = ();
-
-    # Find dependencies for $label
-    foreach my $dep ($self->_match_deps($label, $user_arch)) {
-        my $rpm = $self->_match_file($dep, $user_arch);
-
-        # Don't add the dependency if it's already installed
-        next if($self->_is_installed($rpm));
-
-        # Add the dependency
-        push(@depfiles, $rpm);
-
-        # Recursively add dependencies
-        push(@depfiles, $self->_resolve_deps($dep, @path));
-    }
-
-    return @depfiles;
-}
 
 # Return 1 if the requested rpm, or a newer version, is installed
 # Return 0 otherwise
@@ -669,6 +694,8 @@ sub _is_installed
 
     my $g = $self->{g};
 
+    $rpm = $self->_transfer_path($rpm);
+
     # Get NEVRA for the rpm to be installed
     my $nevra = $g->command(['rpm', '-qp', '--qf',
                              '%{NAME} %{EPOCH} %{VERSION} %{RELEASE} %{ARCH}',
@@ -828,94 +855,6 @@ sub get_application_owner
     die($@) if($@);
 }
 
-# Lookup a guest specific match for the given label
-sub _match
-{
-    my $self = shift;
-    my ($object, $label, $arch, $hash) = @_;
-
-    my $desc = $self->{desc};
-    my $distro = $desc->{distro};
-    my $major = $desc->{major_version};
-    my $minor = $desc->{minor_version};
-
-    if(values(%$hash) > 0) {
-        # Search for a matching entry in the file map, in descending order of
-        # specificity
-        for my $name ("$distro.$major.$minor.$arch.$label",
-                      "$distro.$major.$minor.$label",
-                      "$distro.$major.$arch.$label",
-                      "$distro.$major.$label",
-                      "$distro.$arch.$label",
-                      "$distro.$label") {
-            return $name if(defined($hash->{$name}));
-        }
-    }
-
-    die(user_message(__x("No {object} given matching {label}",
-                         object => $object,
-                         label => "$distro.$major.$minor.$arch.$label")));
-}
-
-# Return the path to an rpm for <label>.<arch>
-# Dies if no match is found
-sub _match_file
-{
-    my $self = shift;
-    my ($label, $arch) = @_;
-
-    # Check for an alias for $label
-    $label = $self->_resolve_alias($label, $arch);
-
-    my $files = $self->{files};
-
-    my $name = $self->_match(__"file", $label, $arch, $files);
-
-    # Ensure that whatever file is returned is accessible
-    $self->_ensure_transfer_mounted();
-
-    return $self->{transfer_mount}.'/'.$files->{$name};
-}
-
-# Look for an alias for this label
-sub _resolve_alias
-{
-    my $self = shift;
-    my ($label, $arch) = @_;
-
-    my $aliases = $self->{aliases};
-
-    my $alias;
-    eval {
-        $alias = $self->_match(__"alias", $label, $arch, $aliases);
-    };
-
-    return $aliases->{$alias} if(defined($alias));
-    return $label;
-}
-
-# Return a list of labels listed as dependencies of the given label.
-# Returns an empty list if no dependencies were specified.
-sub _match_deps
-{
-    my $self = shift;
-    my ($label, $arch) = @_;
-
-    my $deps = $self->{deps};
-
-    my $name;
-    eval {
-        $name = $self->_match(__"dependencies", $label, $arch, $deps);
-    };
-
-    # Return an empty list if there were no dependencies defined
-    if($@) {
-        return ();
-    } else {
-        return split(/\s+/, $deps->{$name});
-    }
-}
-
 # Install a set of rpms
 sub _install_rpms
 {
@@ -926,6 +865,9 @@ sub _install_rpms
     # Nothing to do if we got an empty set
     return if(scalar(@rpms) == 0);
 
+    # All paths are relative to the transfer mount. Need to make them absolute.
+    @rpms = map { $_ = $self->_transfer_path($_) } @rpms;
+
     my $g = $self->{g};
     eval {
         $g->command(['rpm', $upgrade == 1 ? '-U' : '-i', @rpms]);
@@ -935,6 +877,18 @@ sub _install_rpms
     die($@) if($@);
 }
 
+# Get full, local path of a file on the transfer mount
+sub _transfer_path
+{
+    my $self = shift;
+
+    my ($path) = @_;
+
+    $self->_ensure_transfer_mounted();
+
+    return File::Spec->catfile($self->{transfer_mount}, $path);
+}
+
 # Ensure that the transfer device is mounted. If not, mount it.
 sub _ensure_transfer_mounted
 {
diff --git a/v2v/virt-v2v.pl b/v2v/virt-v2v.pl
index cf78523..a0559e9 100755
--- a/v2v/virt-v2v.pl
+++ b/v2v/virt-v2v.pl
@@ -22,7 +22,9 @@ use strict;
 use Pod::Usage;
 use Getopt::Long;
 #use Data::Dumper;
-use Config::Tiny;
+use File::Spec;
+use File::stat;
+
 use Locale::TextDomain 'virt-v2v';
 
 use Sys::Guestfs;
@@ -31,10 +33,11 @@ use Sys::Guestfs::Lib qw(open_guest get_partitions inspect_all_partitions
                          inspect_in_detail);
 
 use Sys::VirtV2V;
-use Sys::VirtV2V::GuestOS;
 use Sys::VirtV2V::Converter;
 use Sys::VirtV2V::Connection::LibVirt;
 use Sys::VirtV2V::Connection::LibVirtXML;
+use Sys::VirtV2V::ExecHelper;
+use Sys::VirtV2V::GuestOS;
 use Sys::VirtV2V::UserMessage qw(user_message);
 
 =encoding utf8
@@ -296,10 +299,6 @@ if ($@) {
     exit(1);
 }
 
-# Configure GuestOS ([files] and [deps] sections)
-# Need to fix GuestOS's usage of config for installing applications
-Sys::VirtV2V::GuestOS->configure({});
-
 
 ###############################################################################
 ## Start of processing
@@ -311,6 +310,9 @@ exit(1) unless(defined($dom));
 # Get a list of the guest's transfered storage devices
 my @storage = $conn->get_local_storage();
 
+# Create the transfer iso if required
+my $transferiso = get_transfer_iso($config, $config_file);
+
 # Open a libguestfs handle on the guest's storage devices
 my $g = get_guestfs_handle(\@storage, $transferiso);
 
@@ -321,7 +323,7 @@ $SIG{'QUIT'} = \&close_guest_handle;
 my $os = inspect_guest($g);
 
 # Instantiate a GuestOS instance to manipulate the guest
-my $guestos = Sys::VirtV2V::GuestOS->instantiate($g, $os);
+my $guestos = Sys::VirtV2V::GuestOS->new($g, $os, $dom, $config);
 
 # Modify the guest and its metadata for the target hypervisor
 Sys::VirtV2V::Converter->convert($vmm, $guestos, $config, $dom, $os);
@@ -346,9 +348,85 @@ sub close_guest_handle
     }
 }
 
+sub get_transfer_iso
+{
+    my ($config, $config_file) = @_;
+
+    # Nothing to do if there's no config
+    return undef unless (defined($config));
+
+    # path-root doesn't have to be defined
+    my ($root) = $config->findnodes('/virt-v2v/path-root/text()');
+    $root = $root->getData() if (defined($root));
+
+    # Construct a list of path arguments to mkisofs from paths referenced in the
+    # config file
+    # We actually use a hash here to avoid duplicates
+    my %path_args;
+    foreach my $path ($config->findnodes('/virt-v2v/app/path/text() | '.
+                                         '/virt-v2v/app/dep/text()')) {
+        $path = $path->getData();
+
+        # Get the absolute path if iso-root was defined
+        my $abs;
+        if (defined($root)) {
+            $abs = File::Spec->catfile($root, $path);
+        } else {
+            $abs = $path;
+        }
+
+        # Check the referenced path is accessible
+        die(user_message(__x("Unable to access {path} referenced in ".
+                             "the config file",
+                             path => $path))) unless (-r $abs);
+
+        $path_args{"$path=$abs"} = 1;
+    }
+
+    # Nothing further to do if there are no paths
+    return if (keys(%path_args) == 0);
+
+    # Get the path of the transfer iso
+    my ($iso_path) = $config->findnodes('/virt-v2v/iso-path/text()');
+
+    # We need this
+    die(user_message(__"<iso-path> must be specified in the configuration ".
+                       "file")) unless (defined($iso_path));
+    $iso_path = $iso_path->getData();
+
+    # Check that the transfer iso exists, and is newer than the config file
+    if (-e $iso_path) {
+        my $iso_st = stat($iso_path)
+            or die(user_message(__x("Unable to stat iso file {path}: {error}",
+                                    path => $iso_path, error => $!)));
+
+        my $config_st = stat($config_file)
+            or die(user_message(__x("Unable to stat config file {path}: ".
+                                    "{error}",
+                                    path => $config_file, error => $!)));
+
+        # Don't need to re-create if the iso file is newer than the config file
+        return $iso_path if ($iso_st->mtime > $config_st->mtime);
+    }
+
+    # Re-create the transfer iso
+    my $eh = Sys::VirtV2V::ExecHelper->run
+        ('mkisofs', '-o', $iso_path,
+         '-r', '-J',
+         '-V', '__virt-v2v_transfer__',
+         '-graft-points', keys(%path_args));
+    die(user_message(__x("Failed to create transfer iso. ".
+                         "Command output was:\n{output}",
+                         output => $eh->output()))) unless ($eh->status() == 0);
+
+    return $iso_path;
+}
+
 sub get_guestfs_handle
 {
-    my $g = open_guest(\@_, rw => 1);
+    my ($storage, $transferiso) = @_;
+
+    my $g = open_guest($storage, rw => 1);
 
     # Add the transfer iso if there is one
     $g->add_drive($transferiso) if(defined($transferiso));
-- 
1.6.6

    

[Libguestfs] [PATCH 6/6] Fix application installation by GuestOS

Matthew Booth