change strncmp() == 0 to STREQLEN()

[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 72b0f7d..549916f 100644 (file)
--- a/perl/lib/Sys/Guestfs/Lib.pm
+++ b/perl/lib/Sys/Guestfs/Lib.pm
@@ -66,7 +66,8 @@ use vars qw(@EXPORT_OK @ISA);
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
   inspect_all_partitions inspect_partition
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
   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,7 +100,7 @@ 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
 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
 
 The optional C<address> parameter can be added to specify the libvirt
 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are


@@ -266,38 +267,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 +543,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


@@ -1330,7 +1315,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
 


@@ -1435,6 +1424,56 @@ sub _check_for_applications
     $os->{apps} = \@apps;
 }
 
     $os->{apps} = \@apps;
 }
 

+# Find the path which needs to be prepended to paths in grub.conf to make them
+# absolute
+sub _find_grub_prefix
+{
+    my ($g, $os) = @_;
+
+    my $fses = $os->{filesystems};
+    die("filesystems undefined") unless(defined($fses));
+
+    # Look for the filesystem which contains grub
+    my $grubdev;
+    foreach my $dev (keys(%$fses)) {
+        my $fsinfo = $fses->{$dev};
+        if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
+            $grubdev = $dev;
+            last;
+        }
+    }
+
+    my $mounts = $os->{mounts};
+    die("mounts undefined") unless(defined($mounts));
+
+    # Find where the filesystem is mounted
+    if(defined($grubdev)) {
+        foreach my $mount (keys(%$mounts)) {
+            if($mounts->{$mount} eq $grubdev) {
+                return "" if($mount eq '/');
+                return $mount;
+            }
+        }
+
+        die("$grubdev defined in filesystems, but not in mounts");
+    }
+
+    # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
+    # what filesystem it's on. We use menu.lst rather than grub.conf because
+    # debian only uses menu.lst, and anaconda creates a symlink for it.
+    die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
+
+    # Look for the most specific mount point in mounts
+    foreach my $path qw(/boot/grub /boot /) {
+        if(exists($mounts->{$path})) {
+            return "" if($path eq '/');
+            return $path;
+        }
+    }
+
+    die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
+}
+

 sub _check_for_kernels
 {
     my ($g, $os) = @_;
 sub _check_for_kernels
 {
     my ($g, $os) = @_;


@@ -1443,6 +1482,8 @@ sub _check_for_kernels
         # Iterate over entries in grub.conf, populating $os->{boot}
         # For every kernel we find, inspect it and add to $os->{kernels}
 
         # 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 @boot_configs;
 
         # We want
         my @boot_configs;
 
         # We want


@@ -1454,6 +1495,7 @@ 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);
 
         # Initialise augeas
         $g->aug_init("/", 16);
 


@@ -1474,7 +1516,7 @@ sub _check_for_kernels
 
             # Check we've got a kernel entry
             if(defined($grub_kernel)) {
 
             # Check we've got a kernel entry
             if(defined($grub_kernel)) {

-                my $path = "/boot$grub_kernel";
+                my $path = "$grub$grub_kernel";

 
                 # Reconstruct the kernel command line
                 my @args = ();
 
                 # Reconstruct the kernel command line
                 my @args = ();


@@ -1494,10 +1536,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


@@ -1508,7 +1555,7 @@ sub _check_for_kernels
 
                     unless($@) {
                         $config{initrd} =
 
                     unless($@) {
                         $config{initrd} =

-                            _inspect_initrd($g, $os, "/boot$initrd",
+                            _inspect_initrd($g, $os, "$grub$initrd",

                                             $kernel->{version});
                     } else {
                         warn __x("Grub entry {title} does not specify an ".
                                             $kernel->{version});
                     } else {
                         warn __x("Grub entry {title} does not specify an ".


@@ -1524,6 +1571,7 @@ 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 {


@@ -1541,9 +1589,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 = ();
 


@@ -1552,7 +1610,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]); };


@@ -1609,14 +1667,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;
 }
 


@@ -1696,13 +1746,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;
 }