X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=2292839bd020e8345837a1baa90868df3ce7e00f;hp=ade4a6fe9c5175409bd1a698da5304a999e307d9;hb=641ccab6c3b17f1c94676eab99e8baa9cddf5a0b;hpb=ebfcb7f23df4546977628dc718982730682a68c0 diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm index ade4a6f..2292839 100644 --- a/perl/lib/Sys/Guestfs/Lib.pm +++ b/perl/lib/Sys/Guestfs/Lib.pm @@ -1,5 +1,5 @@ # Sys::Guestfs::Lib -# Copyright (C) 2009 Red Hat Inc. +# Copyright (C) 2009-2010 Red Hat Inc. # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public @@ -20,6 +20,15 @@ package Sys::Guestfs::Lib; use strict; use warnings; +# The minor part of this version number is incremented when some +# change is made to this module. The major part is incremented if we +# make a change which is not backwards compatible. It is not related +# to the libguestfs version number. +use vars qw($VERSION); +$VERSION = '0.2'; + +use Carp qw(croak); + use Sys::Guestfs; use File::Temp qw/tempdir/; use Locale::TextDomain 'libguestfs'; @@ -79,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); @@ -94,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 parameter +is specified then that format is forced. The handle is I by default. Use the optional parameter C 1> to open a read-write handle. However if you open a @@ -111,16 +121,16 @@ The implicit libvirt handle is closed after this function, I you call the function in C 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. +[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. If the C module is not available, then libvirt is bypassed, and this function can only open disk images. -The optional C parameter can be used to open devices with -C. See -L for more details. +The optional C parameter can be used to open devices with a +specified qemu interface. See L +for more details. =cut @@ -133,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") { @@ -140,17 +151,26 @@ sub open_guest } elsif (ref ($first) eq "SCALAR") { @images = ($first); } else { - die __"open_guest: first parameter must be a string or an arrayref" + 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]) { foreach (@images) { - die __x("guest image {imagename} does not exist or is not readable", + croak __x("guest image {imagename} does not exist or is not readable", 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"} && @@ -195,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 @@ -258,16 +287,27 @@ This function takes an open libguestfs handle C<$g> and returns all partitions and logical volumes found on it. What is returned is everything that could contain a filesystem (or -swap). Physical volumes are excluded from the list, and so are any -devices which are partitioned (eg. C would not be returned -if C exists). +swap). Physical volumes are not normally included from the list +except if they contain a filesystem directly. Nor are devices which +are partitioned (eg. C would not be returned if C +exists). =cut sub get_partitions { + local $_; my $g = shift; + # Look to see if any devices directly contain filesystems (RHBZ#590167). + my @devices = $g->list_devices (); + my @fses_on_device = (); + foreach (@devices) { + eval { $g->mount_ro ($_, "/"); }; + push @fses_on_device, $_ unless $@; + $g->umount_all (); + } + my @partitions = $g->list_partitions (); my @pvs = $g->pvs (); @partitions = grep { ! _is_pv ($_, @pvs) } @partitions; @@ -275,7 +315,7 @@ sub get_partitions my @lvs; @lvs = $g->lvs () if feature_available ($g, "lvm2"); - return sort (@lvs, @partitions); + return sort (@fses_on_device, @lvs, @partitions); } sub _is_pv { @@ -320,159 +360,18 @@ sub resolve_windows_path =head2 file_architecture - $arch = file_architecture ($g, $path) - -The C 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 or C). - -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. - -Win64 binaries and DLLs return C. - -=item * - -Linux kernel modules - -=item * - -Linux new-style initrd images - -=item * - -some non-x86 Linux vmlinuz kernels - -=back - -What it can't do currently: - -=over 4 - -=item * - -static libraries (libfoo.a) - -=item * +Deprecated function. Replace any calls to this function with: -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 @@ -1099,7 +998,8 @@ like: '/dev/VG/Root' => \%os, } -(There can be multiple roots for a multi-boot VM). +There can be multiple roots for a multi-boot VM, but this function +will throw an error if no roots (ie. OSes) could be found. The C<\%os> hash contains the following keys (any can be omitted): @@ -1182,6 +1082,11 @@ sub inspect_operating_systems } } + # If we didn't find any operating systems then it's an error (RHBZ#591142). + if (0 == keys %oses) { + die __"No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by virt-inspector.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n"; + } + return \%oses; } @@ -1461,10 +1366,16 @@ sub _check_for_applications if ($osn eq "linux") { my $package_format = $os->{package_format}; if (defined $package_format && $package_format eq "rpm") { - my @lines = $g->command_lines - (["rpm", - "-q", "-a", - "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]); + my @lines = (); + eval { + @lines = $g->command_lines + (["rpm", + "-q", "-a", "--qf", + "%{name} %{epoch} %{version} %{release} %{arch}\n"]); + }; + + warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@); + @lines = sort @lines; foreach (@lines) { if (m/^(.*) (.*) (.*) (.*) (.*)$/) { @@ -1481,10 +1392,16 @@ sub _check_for_applications } } } elsif (defined $package_format && $package_format eq "deb") { - my @lines = $g->command_lines - (["dpkg-query", - "-f", '${Package} ${Version} ${Architecture} ${Status}\n', - "-W"]); + my @lines = (); + eval { + @lines = $g->command_lines + (["dpkg-query", + "-f", '${Package} ${Version} ${Architecture} ${Status}\n', + "-W"]); + }; + + warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@); + @lines = sort @lines; foreach (@lines) { if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) { @@ -1629,8 +1546,14 @@ sub _check_for_kernels } $config{cmdline} = join(' ', @args) if(scalar(@args) > 0); - my $kernel = - inspect_linux_kernel($g, $path, $os->{package_format}); + my $kernel; + if ($g->exists($path)) { + $kernel = + inspect_linux_kernel($g, $path, $os->{package_format}); + } else { + warn __x("grub refers to {path}, which doesn't exist\n", + path => $path); + } # Check the kernel was recognised if(defined($kernel)) { @@ -1670,9 +1593,6 @@ sub _check_for_kernels eval { $boot{default} = $g->aug_get("/files/$grub_conf/default"); }; - if($@) { - warn __"No grub default specified"; - } $os->{boot} = \%boot; } @@ -1779,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 @@ -1826,7 +1739,7 @@ sub _inspect_initrd # Disregard old-style compressed ext2 files and only work with real # compressed cpio files, since cpio takes ages to (fail to) process anything # else. - if ($g->file ($path) =~ /cpio/) { + if ($g->exists($path) && $g->file($path) =~ /cpio/) { eval { @modules = $g->initrd_list ($path); };