X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=bc8be9db93cdfbcb59a74f9f4ede1f95510a307e;hp=44c4d565fb2b42bd7d9d3cd8f3efbf178f52b557;hb=7cbd1bbdd5e613561ea7227081f7ddd666b98ee0;hpb=2105fabddfdcecca68e20285808b4d8bbe133227 diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm index 44c4d56..bc8be9d 100644 --- a/perl/lib/Sys/Guestfs/Lib.pm +++ b/perl/lib/Sys/Guestfs/Lib.pm @@ -22,6 +22,7 @@ use warnings; use Sys::Guestfs; use File::Temp qw/tempdir/; +use Locale::TextDomain 'libguestfs'; # Optional: eval "use Sys::Virt;"; @@ -77,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 @@ -107,10 +108,10 @@ passed through to Cnew> unchanged. 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. (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. +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. If the C module is not available, then libvirt is bypassed, and this function can only open disk images. @@ -131,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]) { @@ -167,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; } @@ -187,7 +204,7 @@ sub open_guest } } - return wantarray ? ($g, $conn, $dom) : $g + return wantarray ? ($g, $conn, $dom, @images) : $g } =head2 get_partitions @@ -254,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; } @@ -458,13 +475,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 -=item osversion +(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 version. +Operating system major version number. + +=item os_minor_version + +(For root partitions only). +Operating system minor version number. =item fstab @@ -591,25 +624,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"; } @@ -736,7 +819,7 @@ sub _load_windows_registry close SAVEERR; unless ($res == 0) { - warn "reged command failed: $?"; + warn __x("reged command failed: {errormsg}", errormsg => $?); return; } @@ -745,7 +828,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 = ; } @@ -798,9 +881,13 @@ Operating system type, eg. "linux", "windows". Operating system distribution, eg. "debian". -=item version +=item major_version + +Operating system major version, eg. "4". + +=item minor_version -Operating system version, eg. "4.0". +Operating system minor version, eg "3". =item root @@ -866,7 +953,14 @@ 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}; } sub _assign_mount_points @@ -915,7 +1009,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; @@ -925,7 +1019,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->{$_}; @@ -948,20 +1042,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 table in that hash (see C). -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-Eumount_all ()>. @@ -973,14 +1068,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->{$_}, $_) + } + } } } @@ -1046,8 +1149,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", @@ -1167,7 +1270,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; @@ -1204,14 +1308,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"); + } } } }