tools: Specify format of disks (RHBZ#642934,CVE-2010-3851).
[libguestfs.git] / perl / lib / Sys / Guestfs / Lib.pm
index 2c5c837..2292839 100644 (file)
@@ -88,7 +88,7 @@ use vars qw(@EXPORT_OK @ISA);
 
  $g = open_guest ($name, address => $uri, ...);
 
- $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
+ $g = open_guest ([$img1, $img2, ...], address => $uri, format => $format, ...);
 
  ($g, $conn, $dom, @images) = open_guest ($name);
 
@@ -103,7 +103,8 @@ block.
 
 The first parameter is either a string referring to a libvirt domain
 or a disk image, or (if a guest has several disk images) an arrayref
-C<[$img1, $img2, ...]>.
+C<[$img1, $img2, ...]>.  For disk images, if the C<format> parameter
+is specified then that format is forced.
 
 The handle is I<read-only> by default.  Use the optional parameter
 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
@@ -120,16 +121,16 @@ The implicit libvirt handle is closed after this function, I<unless>
 you call the function in C<wantarray> context, in which case the
 function returns a tuple of: the open libguestfs handle, the open
 libvirt handle, and the open libvirt domain handle, and a list of
-images.  (This is useful if you want to do other things like pulling
-the XML description of the guest).  Note that if this is a straight
-disk image, then C<$conn> and C<$dom> will be C<undef>.
+[image,format] pairs.  (This is useful if you want to do other things
+like pulling the XML description of the guest).  Note that if this is
+a straight 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.
 
-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.
+The optional C<interface> parameter can be used to open devices with a
+specified qemu interface.  See L<Sys::Guestfs/guestfs_add_drive_opts>
+for more details.
 
 =cut
 
@@ -142,6 +143,7 @@ sub open_guest
     my $rw = $params{rw};
     my $address = $params{address};
     my $interface = $params{interface};
+    my $format = $params{format}; # undef == autodetect
 
     my @images = ();
     if (ref ($first) eq "ARRAY") {
@@ -152,6 +154,13 @@ sub open_guest
         croak __"open_guest: first parameter must be a string or an arrayref"
     }
 
+    # Check each element of @images is defined.
+    # (See https://bugzilla.redhat.com/show_bug.cgi?id=601092#c3).
+    foreach (@images) {
+        croak __"open_guest: first argument contains undefined element"
+            unless defined $_;
+    }
+
     my ($conn, $dom);
 
     if (-e $images[0]) {
@@ -160,6 +169,8 @@ sub open_guest
                     imagename => $_)
                 unless -r $_;
         }
+
+        @images = map { [ $_, $format ] } @images;
     } else {
         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
             unless exists $INC{"Sys/Virt.pm"} &&
@@ -204,32 +215,41 @@ sub open_guest
         my $xml = $dom->get_xml_description ();
 
         my $p = XML::XPath->new (xml => $xml);
-        my @disks = $p->findnodes ('//devices/disk/source/@dev');
-        push (@disks, $p->findnodes ('//devices/disk/source/@file'));
+        my $nodes = $p->find ('//devices/disk');
+
+        my @disks = ();
+        my $node;
+        foreach $node ($nodes->get_nodelist) {
+            # The filename can be in dev or file attribute, hence:
+            my $filename = $p->find ('./source/@dev', $node);
+            unless ($filename) {
+                $filename = $p->find ('./source/@file', $node);
+                next unless $filename;
+            }
+            $filename = $filename->to_literal;
+
+            # Get the disk format (may not be set).
+            my $format = $p->find ('./driver/@type', $node);
+            $format = $format->to_literal if $format;
+
+            push @disks, [ $filename, $format ];
+        }
 
         die __x("{imagename} seems to have no disk devices\n",
                 imagename => $images[0])
             unless @disks;
 
-        @images = map { $_->getData } @disks;
+        @images = @disks;
     }
 
     # We've now got the list of @images, so feed them to libguestfs.
     my $g = Sys::Guestfs->new ();
     foreach (@images) {
-        if ($rw) {
-            if ($interface) {
-                $g->add_drive_with_if ($_, $interface);
-            } else {
-                $g->add_drive ($_);
-            }
-        } else {
-            if ($interface) {
-                $g->add_drive_ro_with_if ($_, $interface);
-            } else {
-                $g->add_drive_ro ($_);
-            }
-        }
+        my @args = ($_->[0]);
+        push @args, format => $_->[1] if defined $_->[1];
+        push @args, readonly => 1 unless $rw;
+        push @args, iface => $interface if defined $interface;
+        $g->add_drive_opts (@args);
     }
 
     return wantarray ? ($g, $conn, $dom, @images) : $g
@@ -340,159 +360,18 @@ sub resolve_windows_path
 
 =head2 file_architecture
 
- $arch = file_architecture ($g, $path)
-
-The C<file_architecture> function lets you get the architecture for a
-particular binary or library in the guest.  By "architecture" we mean
-what processor it is compiled for (eg. C<i586> or C<x86_64>).
-
-The function works on at least the following types of files:
-
-=over 4
-
-=item *
-
-many types of Un*x binary
-
-=item *
-
-many types of Un*x shared library
-
-=item *
-
-Windows Win32 and Win64 binaries
-
-=item *
-
-Windows Win32 and Win64 DLLs
-
-Win32 binaries and DLLs return C<i386>.
-
-Win64 binaries and DLLs return C<x86_64>.
-
-=item *
-
-Linux kernel modules
-
-=item *
-
-Linux new-style initrd images
-
-=item *
-
-some non-x86 Linux vmlinuz kernels
+Deprecated function.  Replace any calls to this function with:
 
-=back
-
-What it can't do currently:
-
-=over 4
-
-=item *
-
-static libraries (libfoo.a)
-
-=item *
-
-Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
-
-=item *
-
-x86 Linux vmlinuz kernels
-
-x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
-compressed code, and are horribly hard to unpack.  If you want to find
-the architecture of a kernel, use the architecture of the associated
-initrd or kernel module(s) instead.
-
-=back
+ $g->file_architecture ($path);
 
 =cut
 
-sub _elf_arch_to_canonical
-{
-    local $_ = shift;
-
-    if ($_ eq "Intel 80386") {
-        return "i386";
-    } elsif ($_ eq "Intel 80486") {
-        return "i486"; # probably not in the wild
-    } elsif ($_ eq "x86-64") {
-        return "x86_64";
-    } elsif ($_ eq "AMD x86-64") {
-        return "x86_64";
-    } elsif (/SPARC32/) {
-        return "sparc";
-    } elsif (/SPARC V9/) {
-        return "sparc64";
-    } elsif ($_ eq "IA-64") {
-        return "ia64";
-    } elsif (/64.*PowerPC/) {
-        return "ppc64";
-    } elsif (/PowerPC/) {
-        return "ppc";
-    } else {
-        warn __x("returning non-canonical architecture type '{arch}'",
-                 arch => $_);
-        return $_;
-    }
-}
-
-my @_initrd_binaries = ("nash", "modprobe", "sh", "bash");
-
 sub file_architecture
 {
-    local $_;
     my $g = shift;
     my $path = shift;
 
-    # Our basic tool is 'file' ...
-    my $file = $g->file ($path);
-
-    if ($file =~ /ELF.*(?:executable|shared object|relocatable), (.+?),/) {
-        # ELF executable or shared object.  We need to convert
-        # what file(1) prints into the canonical form.
-        return _elf_arch_to_canonical ($1);
-    } elsif ($file =~ /PE32 executable/) {
-        return "i386";         # Win32 executable or DLL
-    } elsif ($file =~ /PE32\+ executable/) {
-        return "x86_64";       # Win64 executable or DLL
-    }
-
-    elsif ($file =~ /cpio archive/) {
-        # Probably an initrd.
-        my $zcat = "cat";
-        if ($file =~ /gzip/) {
-            $zcat = "zcat";
-        } elsif ($file =~ /bzip2/) {
-            $zcat = "bzcat";
-        }
-
-        # Download and unpack it to find a binary file.
-        my $dir = tempdir (CLEANUP => 1);
-        $g->download ($path, "$dir/initrd");
-
-        my $bins = join " ", map { "bin/$_" } @_initrd_binaries;
-        my $cmd = "cd $dir && $zcat initrd | cpio --quiet -id $bins";
-        my $r = system ($cmd);
-        die __x("cpio command failed: {error}", error => $?)
-            unless $r == 0;
-
-        foreach my $bin (@_initrd_binaries) {
-            if (-f "$dir/bin/$bin") {
-                $_ = `file $dir/bin/$bin`;
-                if (/ELF.*executable, (.+?),/) {
-                    return _elf_arch_to_canonical ($1);
-                }
-            }
-        }
-
-        die __x("file_architecture: no known binaries found in initrd image: {path}",
-                path => $path);
-    }
-
-    die __x("file_architecture: unknown architecture: {path}",
-            path => $path);
+    return $g->file_architecture ($path);
 }
 
 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
@@ -1820,13 +1699,6 @@ sub _find_modprobe_aliases
     # Initialise augeas
     $g->aug_init("/", 16);
 
-    # Register additional paths to the Modprobe lens
-    $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/modules.conf");
-    $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/conf.modules");
-
-    # Make augeas reload
-    $g->aug_load();
-
     my %modprobe_aliases;
 
     for my $pattern qw(/files/etc/conf.modules/alias