X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=601b3f48835ba876c040c915c7f4981a6ced9ba1;hp=d522ef28ffdaf7d67ae4fb99d72c16c576cdbc72;hb=b742f0874798050d31ef31fb7f66053e34d36194;hpb=6d9804170017b4c44fa6d288e110b63573da14b4

diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm
index d522ef2..601b3f4 100644
--- a/perl/lib/Sys/Guestfs/Lib.pm
+++ b/perl/lib/Sys/Guestfs/Lib.pm
@@ -21,6 +21,8 @@ use strict;
 use warnings;
 
 use Sys::Guestfs;
+use File::Temp qw/tempdir/;
+use Locale::TextDomain 'libguestfs';
 
 # Optional:
 eval "use Sys::Virt;";
@@ -76,7 +78,7 @@ use vars qw(@EXPORT_OK @ISA);
 
  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
 
- ($g, $conn, $dom) = open_guest ($name);
+ ($g, $conn, $dom, @images) = open_guest ($name);
 
 This function opens a libguestfs handle for either the libvirt domain
 called C<$name>, or the disk image called C<$name>.  Any disk images
@@ -106,10 +108,10 @@ passed through to C<Sys::Virt-E<gt>new> unchanged.
 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.  (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>.
+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>.
 
 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 and this function can only open disk images.
@@ -130,35 +132,36 @@ sub open_guest
     } elsif (ref ($first) eq "SCALAR") {
 	@images = ($first);
     } else {
-	die "open_guest: first parameter must be a string or an arrayref"
+	die __"open_guest: first parameter must be a string or an arrayref"
     }
 
     my ($conn, $dom);
 
     if (-e $images[0]) {
 	foreach (@images) {
-	    die "guest image $_ does not exist or is not readable"
+	    die __x("guest image {imagename} does not exist or is not readable",
+		    imagename => $_)
 		unless -r $_;
 	}
     } else {
-	die "open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
+	die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
 	    unless exists $INC{"Sys/Virt.pm"} &&
 	    exists $INC{"XML/XPath.pm"} &&
 	    exists $INC{"XML/XPath/XMLParser.pm"};
 
-	die "open_guest: too many domains listed on command line"
+	die __"open_guest: too many domains listed on command line"
 	    if @images > 1;
 
 	$conn = Sys::Virt->new (readonly => 1, @_);
-	die "open_guest: cannot connect to libvirt" unless $conn;
+	die __"open_guest: cannot connect to libvirt" unless $conn;
 
 	my @doms = $conn->list_defined_domains ();
-	my $isitinactive = "an inactive libvirt domain";
+	my $isitinactive = 1;
 	unless ($readwrite) {
 	    # 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 ();
-	    $isitinactive = "a libvirt domain";
+	    $isitinactive = 0;
 	}
 	foreach (@doms) {
 	    if ($_->get_name () eq $images[0]) {
@@ -166,13 +169,28 @@ sub open_guest
 		last;
 	    }
 	}
-	die "$images[0] is not the name of $isitinactive\n" unless $dom;
+
+	unless ($dom) {
+	    if ($isitinactive) {
+		die __x("{imagename} is not the name of an inactive libvirt domain\n",
+			imagename => $images[0]);
+	    } else {
+		die __x("{imagename} is not the name of a libvirt domain\n",
+			imagename => $images[0]);
+	    }
+	}
 
 	# Get the names of the image(s).
 	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'));
+
+	die __x("{imagename} seems to have no disk devices\n",
+		imagename => $images[0])
+	    unless @disks;
+
 	@images = map { $_->getData } @disks;
     }
 
@@ -186,7 +204,7 @@ sub open_guest
 	}
     }
 
-    return wantarray ? ($g, $conn, $dom) : $g
+    return wantarray ? ($g, $conn, $dom, @images) : $g
 }
 
 =head2 get_partitions
@@ -253,7 +271,7 @@ sub resolve_windows_path
     my $path = shift;
 
     if (substr ($path, 0, 1) ne "/") {
-	warn "resolve_windows_path: path must start with a / character";
+	warn __"resolve_windows_path: path must start with a / character";
 	return undef;
     }
 
@@ -282,6 +300,161 @@ sub resolve_windows_path
     return $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
+
+=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
+
+=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 (/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);
+}
+
 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
 
 The functions in this section can be used to inspect the operating
@@ -457,13 +630,29 @@ Filesystem content, if we could determine it.  One of: "linux-grub",
 =item osdistro
 
 (For Linux root partitions only).
-Operating system distribution.  One of: "fedora", "redhat",
-"debian".
+Operating system distribution.  One of: "fedora", "rhel", "centos",
+"scientific", "debian".
+
+=item package_format
+
+(For Linux root partitions only)
+The package format used by the guest distribution. One of: "rpm", "dpkg".
+
+=item package_management
+
+(For Linux root partitions only)
+The package management tool used by the guest distribution. One of: "rhn",
+"yum", "apt".
+
+=item os_major_version
+
+(For root partitions only).
+Operating system major version number.
 
-=item osversion
+=item os_minor_version
 
 (For root partitions only).
-Operating system version.
+Operating system minor version number.
 
 =item fstab
 
@@ -590,25 +779,75 @@ sub _check_linux_root
     my $r = shift;
 
     # Look into /etc to see if we recognise the operating system.
-    if ($g->is_file ("/etc/redhat-release")) {
+    # N.B. don't use $g->is_file here, because it might be a symlink
+    if ($g->exists ("/etc/redhat-release")) {
+        $r->{package_format} = "rpm";
+
 	$_ = $g->cat ("/etc/redhat-release");
-	if (/Fedora release (\d+\.\d+)/) {
+	if (/Fedora release (\d+)(?:\.(\d+))?/) {
 	    $r->{osdistro} = "fedora";
-	    $r->{osversion} = "$1"
-	} elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) {
-	    $r->{osdistro} = "redhat";
-	    $r->{osversion} = "$2.$3";
-        } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) {
-	    $r->{osdistro} = "redhat";
-	    $r->{osversion} = "$2";
-	} else {
-	    $r->{osdistro} = "redhat";
+	    $r->{os_major_version} = "$1";
+	    $r->{os_minor_version} = "$2" if(defined($2));
+	    $r->{package_management} = "yum";
+	}
+        
+        elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
+            my $distro = $1;
+
+            if($distro eq "Red Hat Enterprise Linux") {
+                $r->{osdistro} = "rhel";
+            }
+
+            elsif($distro eq "CentOS") {
+                $r->{osdistro} = "centos";
+                $r->{package_management} = "yum";
+            }
+
+            elsif($distro eq "Scientific Linux") {
+                $r->{osdistro} = "scientific";
+                $r->{package_management} = "yum";
+            }
+
+            # Shouldn't be possible
+            else { die };
+
+            if (/$distro.*release (\d+).*Update (\d+)/) {
+                $r->{os_major_version} = "$1";
+                $r->{os_minor_version} = "$2";
+            }
+
+            elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
+                $r->{os_major_version} = "$1";
+
+                if(defined($2)) {
+                    $r->{os_minor_version} = "$2";
+                } else {
+                    $r->{os_minor_version} = "0";
+                }
+            }
+
+            # Package management in RHEL changed in version 5
+            if ($r->{osdistro} eq "rhel") {
+                if ($r->{os_major_version} >= 5) {
+                    $r->{package_management} = "yum";
+                } else {
+                    $r->{package_management} = "rhn";
+                }
+            }
+        }
+
+        else {
+	    $r->{osdistro} = "redhat-based";
 	}
     } elsif ($g->is_file ("/etc/debian_version")) {
+        $r->{package_format} = "dpkg";
+        $r->{package_management} = "apt";
+
 	$_ = $g->cat ("/etc/debian_version");
-	if (/(\d+\.\d+)/) {
+	if (/(\d+)\.(\d+)/) {
 	    $r->{osdistro} = "debian";
-	    $r->{osversion} = "$1";
+	    $r->{os_major_version} = "$1";
+	    $r->{os_minor_version} = "$2";
 	} else {
 	    $r->{osdistro} = "debian";
 	}
@@ -635,6 +874,17 @@ sub _check_linux_root
 	}
 	$r->{fstab} = \@fstab if @fstab;
     }
+
+    # Determine the architecture of this root.
+    my $arch;
+    foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
+	if ($g->is_file ($_)) {
+	    $arch = file_architecture ($g, $_);
+	    last;
+	}
+    }
+
+    $r->{arch} = $arch if defined $arch;
 }
 
 # We only support NT.  The control file /boot.ini contains a list of
@@ -673,13 +923,30 @@ sub _check_windows_root
 
 	if (defined $systemroot) {
 	    $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
-	    if (defined $r->{systemroot} && $use_windows_registry) {
-		_check_windows_registry ($g, $r, $r->{systemroot});
+	    if (defined $r->{systemroot}) {
+		_check_windows_arch ($g, $r, $r->{systemroot});
+		if ($use_windows_registry) {
+		    _check_windows_registry ($g, $r, $r->{systemroot});
+		}
 	    }
 	}
     }
 }
 
+# Find Windows userspace arch.
+
+sub _check_windows_arch
+{
+    local $_;
+    my $g = shift;
+    my $r = shift;
+    my $systemroot = shift;
+
+    my $cmd_exe =
+	resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
+    $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
+}
+
 sub _check_windows_registry
 {
     local $_;
@@ -735,7 +1002,7 @@ sub _load_windows_registry
     close SAVEERR;
 
     unless ($res == 0) {
-	warn "reged command failed: $?";
+	warn __x("reged command failed: {errormsg}", errormsg => $?);
 	return;
     }
 
@@ -744,7 +1011,7 @@ sub _load_windows_registry
     # it.
     my $content;
     unless (open F, "$dir/out") {
-	warn "no output from reged command: $!";
+	warn __x("no output from reged command: {errormsg}", errormsg => $!);
 	return;
     }
     { local $/ = undef; $content = <F>; }
@@ -793,13 +1060,21 @@ The C<\%os> hash contains the following keys (any can be omitted):
 
 Operating system type, eg. "linux", "windows".
 
+=item arch
+
+Operating system userspace architecture, eg. "i386", "x86_64".
+
 =item distro
 
 Operating system distribution, eg. "debian".
 
-=item version
+=item major_version
+
+Operating system major version, eg. "4".
 
-Operating system version, eg. "4.0".
+=item minor_version
+
+Operating system minor version, eg "3".
 
 =item root
 
@@ -865,7 +1140,15 @@ sub _get_os_version
 
     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
-    $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
+    $r->{major_version} = $r->{root}->{os_major_version}
+        if exists $r->{root}->{os_major_version};
+    $r->{minor_version} = $r->{root}->{os_minor_version}
+        if exists $r->{root}->{os_minor_version};
+    $r->{package_format} = $r->{root}->{package_format}
+        if exists $r->{root}->{package_format};
+    $r->{package_management} = $r->{root}->{package_management}
+        if exists $r->{root}->{package_management};
+    $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
 }
 
 sub _assign_mount_points
@@ -914,7 +1197,7 @@ sub _find_filesystem
 		return ($_, $fses->{$_});
 	    }
 	}
-	warn "unknown filesystem label $label\n";
+	warn __x("unknown filesystem label {label}\n", label => $label);
 	return ();
     } elsif (/^UUID=(.*)/) {
 	my $uuid = $1;
@@ -924,7 +1207,7 @@ sub _find_filesystem
 		return ($_, $fses->{$_});
 	    }
 	}
-	warn "unknown filesystem UUID $uuid\n";
+	warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
 	return ();
     } else {
 	return ($_, $fses->{$_}) if exists $fses->{$_};
@@ -947,20 +1230,21 @@ sub _find_filesystem
 
 	return () if m{/dev/cdrom};
 
-	warn "unknown filesystem $_\n";
+	warn __x("unknown filesystem {fs}\n", fs => $_);
 	return ();
     }
 }
 
 =head2 mount_operating_system
 
- mount_operating_system ($g, \%os);
+ mount_operating_system ($g, \%os, [$ro]);
 
 This function mounts the operating system described in the
 C<%os> hash according to the C<mounts> table in that hash (see
 C<inspect_operating_systems>).
 
-The partitions are mounted read-only.
+The partitions are mounted read-only unless the third parameter
+is specified as zero explicitly.
 
 To reverse the effect of this call, use the standard
 libguestfs API call C<$g-E<gt>umount_all ()>.
@@ -972,14 +1256,22 @@ sub mount_operating_system
     local $_;
     my $g = shift;
     my $os = shift;
+    my $ro = shift;		# Read-only?
+
+    $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
 
     my $mounts = $os->{mounts};
 
     # Have to mount / first.  Luckily '/' is early in the ASCII
     # character set, so this should be OK.
     foreach (sort keys %$mounts) {
-	$g->mount_ro ($mounts->{$_}, $_)
-	    if $_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_));
+        if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
+            if($ro) {
+                $g->mount_ro ($mounts->{$_}, $_)
+            } else {
+                $g->mount ($mounts->{$_}, $_)
+            }
+        }
     }
 }
 
@@ -990,8 +1282,8 @@ sub mount_operating_system
  $g->umount_all ();
 
 The C<inspect_in_detail> function inspects the mounted operating
-system for installed applications, installed kernels, kernel modules
-and more.
+system for installed applications, installed kernels, kernel modules,
+system architecture, and more.
 
 It adds extra keys to the existing C<%os> hash reflecting what it
 finds.  These extra keys are:
@@ -1006,6 +1298,24 @@ List of applications.
 
 List of kernels.
 
+This is a hash of kernel version =E<gt> a hash with the following keys:
+
+=over 4
+
+=item version
+
+Kernel version.
+
+=item arch
+
+Kernel architecture (eg. C<x86-64>).
+
+=item modules
+
+List of modules.
+
+=back
+
 =item modprobe_aliases
 
 (For Linux VMs).
@@ -1045,8 +1355,8 @@ sub _check_for_applications
 
     my $osn = $os->{os};
     if ($osn eq "linux") {
-	my $distro = $os->{distro};
-	if (defined $distro && ($distro eq "redhat" || $distro eq "fedora")) {
+	my $package_format = $os->{package_format};
+	if (defined $package_format && $package_format eq "rpm") {
 	    my @lines = $g->command_lines
 		(["rpm",
 		  "-q", "-a",
@@ -1098,14 +1408,21 @@ sub _check_for_kernels
 
 		# List modules.
 		my @modules;
-		foreach ($g->find ("/lib/modules/$_")) {
+		my $any_module;
+		my $prefix = "/lib/modules/$_";
+		foreach ($g->find ($prefix)) {
 		    if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
+			$any_module = "$prefix$_" unless defined $any_module;
 			push @modules, $1;
 		    }
 		}
 
 		$kernel{modules} = \@modules;
 
+		# Determine kernel architecture by looking at the arch
+		# of any kernel module.
+		$kernel{arch} = file_architecture ($g, $any_module);
+
 		push @kernels, \%kernel;
 	    }
 	}
@@ -1166,7 +1483,8 @@ sub _check_for_modprobe_aliases
 
         for my $path ( @results ) {
             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
-                or die("$path doesn't match augeas pattern");
+                or die __x("{path} doesn't match augeas pattern",
+			   path => $path);
             my $file = $1;
 
             my $alias;
@@ -1203,14 +1521,21 @@ sub _check_for_initrd
 	    my $version = $1;
 	    my @modules;
 
-	    eval {
-		@modules = $g->initrd_list ("/boot/$initrd");
-	    };
-	    unless ($@) {
-		@modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, } @modules;
-		$initrd_modules{$version} = \@modules
-	    } else {
-		warn "/boot/$initrd: could not read initrd format"
+	    # 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 ("/boot/$initrd") =~ /cpio/) {
+		eval {
+		    @modules = $g->initrd_list ("/boot/$initrd");
+		};
+		unless ($@) {
+		    @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, }
+		    @modules;
+		    $initrd_modules{$version} = \@modules
+		} else {
+		    warn __x("{filename}: could not read initrd format",
+			     filename => "/boot/$initrd");
+	        }
 	    }
 	}
     }