List application in Debian based vm images

[libguestfs.git] / perl / lib / Sys / Guestfs / Lib.pm

diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm
index 89f2aa6..e8796ad 100644 (file)
--- a/perl/lib/Sys/Guestfs/Lib.pm
+++ b/perl/lib/Sys/Guestfs/Lib.pm
@@ -64,9 +64,11 @@ require Exporter;
 use vars qw(@EXPORT_OK @ISA);
 
 @ISA = qw(Exporter);
 use vars qw(@EXPORT_OK @ISA);
 
 @ISA = qw(Exporter);

-@EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
+@EXPORT_OK = qw(open_guest feature_available
+  get_partitions resolve_windows_path

   inspect_all_partitions inspect_partition
   inspect_all_partitions inspect_partition

-  inspect_operating_systems mount_operating_system inspect_in_detail);
+  inspect_operating_systems mount_operating_system inspect_in_detail
+  inspect_linux_kernel);

 
 =head2 open_guest
 
 
 =head2 open_guest
 


@@ -99,11 +101,10 @@ read-write handle, this function will refuse to use active libvirt
 domains.
 
 The handle is still in the config state when it is returned, so you
 domains.
 
 The handle is still in the config state when it is returned, so you

-have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
+have to call C<$g-E<gt>launch ()>.

 
 The optional C<address> parameter can be added to specify the libvirt
 
 The optional C<address> parameter can be added to specify the libvirt

-URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
-passed through to C<Sys::Virt-E<gt>new> unchanged.
+URI.

 
 The implicit libvirt handle is closed after this function, I<unless>
 you call the function in C<wantarray> context, in which case the
 
 The implicit libvirt handle is closed after this function, I<unless>
 you call the function in C<wantarray> context, in which case the


@@ -116,6 +117,10 @@ disk image, then C<$conn> and C<$dom> will be C<undef>.
 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 and this function can only open disk images.
 
 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 and this function can only open disk images.
 

+The optional C<interface> parameter can be used to open devices with
+C<add_drive{,_ro}_with_if>.  See
+L<Sys::Guestfs/guestfs_add_drive_with_if> for more details.
+

 =cut
 
 sub open_guest
 =cut
 
 sub open_guest


@@ -124,7 +129,9 @@ sub open_guest
     my $first = shift;
     my %params = @_;
 
     my $first = shift;
     my %params = @_;
 

-    my $readwrite = $params{rw};
+    my $rw = $params{rw};
+    my $address = $params{address};
+    my $interface = $params{interface};

 
     my @images = ();
     if (ref ($first) eq "ARRAY") {
 
     my @images = ();
     if (ref ($first) eq "ARRAY") {


@@ -152,12 +159,15 @@ sub open_guest
         die __"open_guest: too many domains listed on command line"
             if @images > 1;
 
         die __"open_guest: too many domains listed on command line"
             if @images > 1;
 

-        $conn = Sys::Virt->new (readonly => 1, @_);
+        my @libvirt_args = ();
+        push @libvirt_args, address => $address if defined $address;
+
+        $conn = Sys::Virt->new (readonly => 1, @libvirt_args);

         die __"open_guest: cannot connect to libvirt" unless $conn;
 
         my @doms = $conn->list_defined_domains ();
         my $isitinactive = 1;
         die __"open_guest: cannot connect to libvirt" unless $conn;
 
         my @doms = $conn->list_defined_domains ();
         my $isitinactive = 1;

-        unless ($readwrite) {
+        unless ($rw) {

             # In the case where we want read-only access to a domain,
             # allow the user to specify an active domain too.
             push @doms, $conn->list_domains ();
             # In the case where we want read-only access to a domain,
             # allow the user to specify an active domain too.
             push @doms, $conn->list_domains ();


@@ -197,16 +207,48 @@ sub open_guest
     # We've now got the list of @images, so feed them to libguestfs.
     my $g = Sys::Guestfs->new ();
     foreach (@images) {
     # We've now got the list of @images, so feed them to libguestfs.
     my $g = Sys::Guestfs->new ();
     foreach (@images) {

-        if ($readwrite) {
-            $g->add_drive ($_);
+        if ($rw) {
+            if ($interface) {
+                $g->add_drive_with_if ($_, $interface);
+            } else {
+                $g->add_drive ($_);
+            }

         } else {
         } else {

-            $g->add_drive_ro ($_);
+            if ($interface) {
+                $g->add_drive_ro_with_if ($_, $interface);
+            } else {
+                $g->add_drive_ro ($_);
+            }

         }
     }
 
     return wantarray ? ($g, $conn, $dom, @images) : $g
 }
 
         }
     }
 
     return wantarray ? ($g, $conn, $dom, @images) : $g
 }
 

+=head2 feature_available
+
+ $bool = feature_available ($g, $feature [, $feature ...]);
+
+This function is a useful wrapper around the basic
+C<$g-E<gt>available> call.
+
+C<$g-E<gt>available> tests for availability of a list of features and
+dies with an error if any is not available.
+
+This call tests for the list of features and returns true if all are
+available, or false otherwise.
+
+For a list of features you can test for, see L<guestfs(3)/AVAILABILITY>.
+
+=cut
+
+sub feature_available {
+    my $g = shift;
+
+    eval { $g->available (\@_); };
+    return $@ ? 0 : 1;
+}
+

 =head2 get_partitions
 
  @partitions = get_partitions ($g);
 =head2 get_partitions
 
  @partitions = get_partitions ($g);


@@ -229,7 +271,8 @@ sub get_partitions
     my @pvs = $g->pvs ();
     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 
     my @pvs = $g->pvs ();
     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 

-    my @lvs = $g->lvs ();
+    my @lvs;
+    @lvs = $g->lvs () if feature_available ($g, "lvm2");

 
     return sort (@lvs, @partitions);
 }
 
     return sort (@lvs, @partitions);
 }


@@ -266,38 +309,12 @@ by C</> characters.  Do not use C<\>, drive names, etc.
 
 sub resolve_windows_path
 {
 
 sub resolve_windows_path
 {

-    local $_;

     my $g = shift;
     my $path = shift;
 
     my $g = shift;
     my $path = shift;
 

-    if (substr ($path, 0, 1) ne "/") {
-        warn __"resolve_windows_path: path must start with a / character";
-        return undef;
-    }
-
-    my @elems = split (/\//, $path);
-    shift @elems;
-
-    # Start reconstructing the path at the top.
-    $path = "/";
-
-    foreach my $dir (@elems) {
-        my $found = 0;
-        foreach ($g->ls ($path)) {
-            if (lc ($_) eq lc ($dir)) {
-                if ($path eq "/") {
-                    $path = "/$_";
-                    $found = 1;
-                } else {
-                    $path = "$path/$_";
-                    $found = 1;
-                }
-            }
-        }
-        return undef unless $found;
-    }
-
-    return $path;
+    my $r;
+    eval { $r = $g->case_sensitive_path ($path); };
+    return $r;

 }
 
 =head2 file_architecture
 }
 
 =head2 file_architecture


@@ -568,13 +585,23 @@ C<use_windows_registry> flag are explained below.
 
 =cut
 
 
 =cut
 

+# Turn /dev/vd* and /dev/hd* into canonical device names
+# (see BLOCK DEVICE NAMING in guestfs(3)).
+
+sub _canonical_dev ($)
+{
+    my ($dev) = @_;
+    return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
+    return $dev;
+}
+

 sub inspect_all_partitions
 {
     local $_;
     my $g = shift;
     my $parts = shift;
     my @parts = @$parts;
 sub inspect_all_partitions
 {
     local $_;
     my $g = shift;
     my $parts = shift;
     my @parts = @$parts;

-    return map { $_ => inspect_partition ($g, $_, @_) } @parts;
+    return map { _canonical_dev ($_) => inspect_partition ($g, $_, @_) } @parts;

 }
 
 =head2 inspect_partition
 }
 
 =head2 inspect_partition


@@ -638,7 +665,7 @@ Operating system distribution.  One of: "fedora", "rhel", "centos",
 =item package_format
 
 (For Linux root partitions only)
 =item package_format
 
 (For Linux root partitions only)

-The package format used by the guest distribution. One of: "rpm", "dpkg".
+The package format used by the guest distribution. One of: "rpm", "deb".

 
 =item package_management
 
 
 =item package_management
 


@@ -842,7 +869,7 @@ sub _check_linux_root
             $r->{osdistro} = "redhat-based";
         }
     } elsif ($g->is_file ("/etc/debian_version")) {
             $r->{osdistro} = "redhat-based";
         }
     } elsif ($g->is_file ("/etc/debian_version")) {

-        $r->{package_format} = "dpkg";
+        $r->{package_format} = "deb";

         $r->{package_management} = "apt";
 
         $_ = $g->cat ("/etc/debian_version");
         $r->{package_management} = "apt";
 
         $_ = $g->cat ("/etc/debian_version");


@@ -1271,7 +1298,7 @@ sub mount_operating_system
             if($ro) {
                 $g->mount_ro ($mounts->{$_}, $_)
             } else {
             if($ro) {
                 $g->mount_ro ($mounts->{$_}, $_)
             } else {

-                $g->mount ($mounts->{$_}, $_)
+                $g->mount_options ("", $mounts->{$_}, $_)

             }
         }
     }
             }
         }
     }


@@ -1330,7 +1357,11 @@ The kernel command line.
 
 =item default
 
 
 =item default
 

-The index of the default configuration in the configs array
+The index of the default configuration in the configs array.
+
+=item grub_fs
+
+The path of the filesystem containing the grub partition.

 
 =back
 
 
 =back
 


@@ -1411,7 +1442,7 @@ sub _check_for_applications
             foreach (@lines) {
                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
                     my $epoch = $2;
             foreach (@lines) {
                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
                     my $epoch = $2;

-                    $epoch = "" if $epoch eq "(none)";
+                    undef $epoch if $epoch eq "(none)";

                     my $app = {
                         name => $1,
                         epoch => $epoch,
                     my $app = {
                         name => $1,
                         epoch => $epoch,


@@ -1422,6 +1453,23 @@ sub _check_for_applications
                     push @apps, $app
                 }
             }
                     push @apps, $app
                 }
             }

+        } elsif (defined $package_format && $package_format eq "deb") {
+            my @lines = $g->command_lines
+                (["dpkg-query",
+                  "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
+                  "-W"]);
+            foreach (@lines) {
+                if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
+                    if ( $6 eq "installed" ) {
+                        my $app = {
+                            name => $1,
+                            version => $2,
+                            arch => $3
+                        };
+                        push @apps, $app
+                    }
+                }
+            }

         }
     } elsif ($osn eq "windows") {
         # XXX
         }
     } elsif ($osn eq "windows") {
         # XXX


@@ -1489,11 +1537,17 @@ sub _check_for_kernels
 {
     my ($g, $os) = @_;
 
 {
     my ($g, $os) = @_;
 

-    if ($os->{os} eq "linux") {
+    if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {

         # Iterate over entries in grub.conf, populating $os->{boot}
         # For every kernel we find, inspect it and add to $os->{kernels}
 
         my $grub = _find_grub_prefix($g, $os);
         # Iterate over entries in grub.conf, populating $os->{boot}
         # For every kernel we find, inspect it and add to $os->{kernels}
 
         my $grub = _find_grub_prefix($g, $os);

+        my $grub_conf = "/etc/grub.conf";
+
+        # Debian and other's have no /etc/grub.conf:
+        if ( ! -f "$grub_conf" ) {
+            $grub_conf = "$grub/grub/menu.lst";
+        }

 
         my @boot_configs;
 
 
         my @boot_configs;
 


@@ -1506,13 +1560,14 @@ sub _check_for_kernels
         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
         #           ->{initrd}  = \initrd
         #       ->{default} = \config
         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
         #           ->{initrd}  = \initrd
         #       ->{default} = \config

+        #       ->{grub_fs} = "/boot"

         # Initialise augeas
         $g->aug_init("/", 16);
 
         my @configs = ();
         # Get all configurations from grub
         foreach my $bootable
         # Initialise augeas
         $g->aug_init("/", 16);
 
         my @configs = ();
         # Get all configurations from grub
         foreach my $bootable

-            ($g->aug_match("/files/etc/grub.conf/title"))
+            ($g->aug_match("/files/$grub_conf/title"))

         {
             my %config = ();
             $config{title} = $g->aug_get($bootable);
         {
             my %config = ();
             $config{title} = $g->aug_get($bootable);


@@ -1546,10 +1601,15 @@ sub _check_for_kernels
                 }
                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
 
                 }
                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
 

-                my $kernel = _inspect_linux_kernel($g, $os, "$path");
+                my $kernel =
+                    inspect_linux_kernel($g, $path, $os->{package_format});

 
                 # Check the kernel was recognised
                 if(defined($kernel)) {
 
                 # Check the kernel was recognised
                 if(defined($kernel)) {

+                    # Put this kernel on the top level kernel list
+                    $os->{kernels} ||= [];
+                    push(@{$os->{kernels}}, $kernel);
+

                     $config{kernel} = $kernel;
 
                     # Look for an initrd entry
                     $config{kernel} = $kernel;
 
                     # Look for an initrd entry


@@ -1576,10 +1636,11 @@ sub _check_for_kernels
         # Create the top level boot entry
         my %boot;
         $boot{configs} = \@configs;
         # Create the top level boot entry
         my %boot;
         $boot{configs} = \@configs;

+        $boot{grub_fs} = $grub;

 
         # Add the default configuration
         eval {
 
         # Add the default configuration
         eval {

-            $boot{default} = $g->aug_get("/files/etc/grub.conf/default");
+            $boot{default} = $g->aug_get("/files/$grub_conf/default");

         };
         if($@) {
             warn __"No grub default specified";
         };
         if($@) {
             warn __"No grub default specified";


@@ -1593,9 +1654,19 @@ sub _check_for_kernels
     }
 }
 
     }
 }
 

-sub _inspect_linux_kernel
+=head2 inspect_linux_kernel
+
+ my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
+
+inspect_linux_kernel returns a hash describing the target linux kernel. For the
+contents of the hash, see the I<kernels> structure described under
+L</inspect_in_detail>.
+
+=cut
+
+sub inspect_linux_kernel

 {
 {

-    my ($g, $os, $path) = @_;
+    my ($g, $path, $package_format) = @_;

 
     my %kernel = ();
 
 
     my %kernel = ();
 


@@ -1604,7 +1675,7 @@ sub _inspect_linux_kernel
     # If this is a packaged kernel, try to work out the name of the package
     # which installed it. This lets us know what to install to replace it with,
     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
     # If this is a packaged kernel, try to work out the name of the package
     # which installed it. This lets us know what to install to replace it with,
     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE

-    if($os->{package_format} eq "rpm") {
+    if($package_format eq "rpm") {

         my $package;
         eval { $package = $g->command(['rpm', '-qf', '--qf',
                                        '%{NAME}', $path]); };
         my $package;
         eval { $package = $g->command(['rpm', '-qf', '--qf',
                                        '%{NAME}', $path]); };


@@ -1661,14 +1732,6 @@ sub _inspect_linux_kernel
     # of any kernel module.
     $kernel{arch} = file_architecture ($g, $any_module);
 
     # of any kernel module.
     $kernel{arch} = file_architecture ($g, $any_module);
 

-    # Put this kernel on the top level kernel list
-    my $kernels = $os->{kernels};
-    if(!defined($kernels)) {
-        $kernels = [];
-        $os->{kernels} = $kernels;
-    }
-    push(@$kernels, \%kernel);
-

     return \%kernel;
 }
 
     return \%kernel;
 }
 


@@ -1748,13 +1811,8 @@ sub _inspect_initrd
     }
 
     # Add to the top level initrd_modules entry
     }
 
     # Add to the top level initrd_modules entry

-    my $initrd_modules = $os->{initrd_modules};
-    if(!defined($initrd_modules)) {
-        $initrd_modules = {};
-        $os->{initrd_modules} = $initrd_modules;
-    }
-
-    $initrd_modules->{$version} = \@modules;
+    $os->{initrd_modules} ||= {};
+    $os->{initrd_modules}->{$version} = \@modules;

 
     return \@modules;
 }
 
     return \@modules;
 }