X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=f0840901535e387f846171280ae5f26d3d62c219;hp=fe2198120541960b50551c4ed2508fb76e04d81a;hb=06f6cc32f02c25b88e763237332b17dc7c6c6837;hpb=0fc6b7affd28ad77566e832f338650b771145ea1

diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm
index fe21981..f084090 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;";
@@ -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;
     }
 
@@ -209,14 +227,14 @@ sub get_partitions
 
     my @partitions = $g->list_partitions ();
     my @pvs = $g->pvs ();
-    @partitions = grep { ! is_pv ($_, @pvs) } @partitions;
+    @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 
     my @lvs = $g->lvs ();
 
     return sort (@lvs, @partitions);
 }
 
-sub is_pv {
+sub _is_pv {
     local $_;
     my $t = shift;
 
@@ -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;
     }
 
@@ -457,8 +475,19 @@ 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 osversion
 
@@ -533,7 +562,7 @@ sub inspect_partition
 	if ($g->is_file ("/grub/menu.lst") ||
 	    $g->is_file ("/grub/grub.conf")) {
 	    $r{content} = "linux-grub";
-	    check_grub ($g, \%r);
+	    _check_grub ($g, \%r);
 	    goto OUT;
 	}
 
@@ -542,7 +571,7 @@ sub inspect_partition
 	    $g->is_file ("/etc/fstab")) {
 	    $r{content} = "linux-root";
 	    $r{is_root} = 1;
-	    check_linux_root ($g, \%r);
+	    _check_linux_root ($g, \%r);
 	    goto OUT;
 	}
 
@@ -573,7 +602,7 @@ sub inspect_partition
 	    $r{fsos} = "windows";
 	    $r{content} = "windows-root";
 	    $r{is_root} = 1;
-	    check_windows_root ($g, \%r, $use_windows_registry);
+	    _check_windows_root ($g, \%r, $use_windows_registry);
 	    goto OUT;
 	}
     }
@@ -583,7 +612,7 @@ sub inspect_partition
     return \%r;
 }
 
-sub check_linux_root
+sub _check_linux_root
 {
     local $_;
     my $g = shift;
@@ -591,20 +620,60 @@ sub check_linux_root
 
     # Look into /etc to see if we recognise the operating system.
     if ($g->is_file ("/etc/redhat-release")) {
+        $r->{package_format} = "rpm";
+
 	$_ = $g->cat ("/etc/redhat-release");
 	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->{osversion} = "$1";
+	    $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->{osversion} = "$1.$2";
+            }
+
+            elsif (/$distro.*release (\d+(?:\.(?:\d+))?)/) {
+                $r->{osversion} = "$1";
+            }
+
+            # Package management in RHEL changed in version 5
+            if ($r->{osdistro} eq "rhel") {
+                if ($r->{osversion} >= 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+)/) {
 	    $r->{osdistro} = "debian";
@@ -644,7 +713,7 @@ sub check_linux_root
 # XXX We could parse this better.  This won't work if /boot.ini is on
 # a different drive from the %systemroot%, and in other unusual cases.
 
-sub check_windows_root
+sub _check_windows_root
 {
     local $_;
     my $g = shift;
@@ -674,13 +743,13 @@ 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});
+		_check_windows_registry ($g, $r, $r->{systemroot});
 	    }
 	}
     }
 }
 
-sub check_windows_registry
+sub _check_windows_registry
 {
     local $_;
     my $g = shift;
@@ -694,18 +763,18 @@ sub check_windows_registry
     if (defined $configdir) {
 	my $softwaredir = resolve_windows_path ($g, "$configdir/software");
 	if (defined $softwaredir) {
-	    load_windows_registry ($g, $r, $softwaredir,
-				   "HKEY_LOCAL_MACHINE\\SOFTWARE");
+	    _load_windows_registry ($g, $r, $softwaredir,
+				    "HKEY_LOCAL_MACHINE\\SOFTWARE");
 	}
 	my $systemdir = resolve_windows_path ($g, "$configdir/system");
 	if (defined $systemdir) {
-	    load_windows_registry ($g, $r, $systemdir,
-				   "HKEY_LOCAL_MACHINE\\System");
+	    _load_windows_registry ($g, $r, $systemdir,
+				    "HKEY_LOCAL_MACHINE\\System");
 	}
     }
 }
 
-sub load_windows_registry
+sub _load_windows_registry
 {
     local $_;
     my $g = shift;
@@ -735,7 +804,7 @@ sub load_windows_registry
     close SAVEERR;
 
     unless ($res == 0) {
-	warn "reged command failed: $?";
+	warn __x("reged command failed: {errormsg}", errormsg => $?);
 	return;
     }
 
@@ -744,7 +813,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>; }
@@ -756,7 +825,7 @@ sub load_windows_registry
     $r->{registry} = \@registry;
 }
 
-sub check_grub
+sub _check_grub
 {
     local $_;
     my $g = shift;
@@ -848,8 +917,8 @@ sub inspect_operating_systems
 		root => $fses->{$_},
 		root_device => $_
 		);
-	    get_os_version ($g, \%r);
-	    assign_mount_points ($g, $fses, \%r);
+	    _get_os_version ($g, \%r);
+	    _assign_mount_points ($g, $fses, \%r);
 	    $oses{$_} = \%r;
 	}
     }
@@ -857,7 +926,7 @@ sub inspect_operating_systems
     return \%oses;
 }
 
-sub get_os_version
+sub _get_os_version
 {
     local $_;
     my $g = shift;
@@ -866,9 +935,13 @@ 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->{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};
 }
 
-sub assign_mount_points
+sub _assign_mount_points
 {
     local $_;
     my $g = shift;
@@ -884,7 +957,7 @@ sub assign_mount_points
 	foreach (@fstab) {
 	    my ($spec, $file) = @$_;
 
-	    my ($dev, $fs) = find_filesystem ($g, $fses, $spec);
+	    my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
 	    if ($dev) {
 		$r->{mounts}->{$file} = $dev;
 		$r->{filesystems}->{$dev} = $fs;
@@ -900,7 +973,7 @@ sub assign_mount_points
 }
 
 # Find filesystem by device name, LABEL=.. or UUID=..
-sub find_filesystem
+sub _find_filesystem
 {
     my $g = shift;
     my $fses = shift;
@@ -914,7 +987,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 +997,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,7 +1020,7 @@ sub find_filesystem
 
 	return () if m{/dev/cdrom};
 
-	warn "unknown filesystem $_\n";
+	warn __x("unknown filesystem {fs}\n", fs => $_);
 	return ();
     }
 }
@@ -1027,15 +1100,15 @@ sub inspect_in_detail
     my $g = shift;
     my $os = shift;
 
-    check_for_applications ($g, $os);
-    check_for_kernels ($g, $os);
+    _check_for_applications ($g, $os);
+    _check_for_kernels ($g, $os);
     if ($os->{os} eq "linux") {
-	check_for_modprobe_aliases ($g, $os);
-	check_for_initrd ($g, $os);
+	_check_for_modprobe_aliases ($g, $os);
+	_check_for_initrd ($g, $os);
     }
 }
 
-sub check_for_applications
+sub _check_for_applications
 {
     local $_;
     my $g = shift;
@@ -1045,8 +1118,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",
@@ -1078,7 +1151,7 @@ sub check_for_applications
     $os->{apps} = \@apps;
 }
 
-sub check_for_kernels
+sub _check_for_kernels
 {
     local $_;
     my $g = shift;
@@ -1126,7 +1199,7 @@ sub check_for_kernels
 #
 # XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
 
-sub check_for_modprobe_aliases
+sub _check_for_modprobe_aliases
 {
     local $_;
     my $g = shift;
@@ -1166,7 +1239,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;
@@ -1190,7 +1264,7 @@ sub check_for_modprobe_aliases
 # Get a listing of device drivers in any initrd corresponding to a
 # kernel.  This is an indication of what can possibly be booted.
 
-sub check_for_initrd
+sub _check_for_initrd
 {
     local $_;
     my $g = shift;
@@ -1203,14 +1277,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, since cpio
+	    # takes ages to (fail to) process these.
+	    if ($g->file ("/boot/$initrd") !~ /gzip compressed/ ||
+		$g->zfile ("gzip", "/boot/$initrd") !~ /ext2 filesystem/) {
+		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");
+	        }
 	    }
 	}
     }