inspector: Sort application names.

[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 dfa79af..98cdb88 100644 (file)
--- a/perl/lib/Sys/Guestfs/Lib.pm
+++ b/perl/lib/Sys/Guestfs/Lib.pm
@@ -64,7 +64,8 @@ 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_operating_systems mount_operating_system inspect_in_detail
   inspect_linux_kernel);
   inspect_all_partitions inspect_partition
   inspect_operating_systems mount_operating_system inspect_in_detail
   inspect_linux_kernel);


@@ -100,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


@@ -117,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


@@ -125,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") {


@@ -153,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 ();


@@ -198,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);


@@ -230,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);
 }


@@ -267,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


@@ -569,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


@@ -639,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
 


@@ -843,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");


@@ -1272,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->{$_}, $_)

             }
         }
     }
             }
         }
     }


@@ -1413,10 +1439,11 @@ sub _check_for_applications
                 (["rpm",
                   "-q", "-a",
                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
                 (["rpm",
                   "-q", "-a",
                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);

+            @lines = sort @lines;

             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,


@@ -1427,6 +1454,24 @@ 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"]);
+            @lines = sort @lines;
+            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


@@ -1494,11 +1539,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;
 


@@ -1518,7 +1569,7 @@ sub _check_for_kernels
         my @configs = ();
         # Get all configurations from grub
         foreach my $bootable
         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);


@@ -1558,12 +1609,8 @@ sub _check_for_kernels
                 # Check the kernel was recognised
                 if(defined($kernel)) {
                     # Put this kernel on the top level kernel list
                 # Check the kernel was recognised
                 if(defined($kernel)) {
                     # Put this kernel on the top level kernel list

-                    my $kernels = $os->{kernels};
-                    if(!defined($kernels)) {
-                        $kernels = [];
-                        $os->{kernels} = $kernels;
-                    }
-                    push(@$kernels, $kernel);
+                    $os->{kernels} ||= [];
+                    push(@{$os->{kernels}}, $kernel);

 
                     $config{kernel} = $kernel;
 
 
                     $config{kernel} = $kernel;
 


@@ -1595,7 +1642,7 @@ sub _check_for_kernels
 
         # 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";


@@ -1766,13 +1813,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;
 }