X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=fc6a10f69149f67e7e2ff322de3c4608de7b58ae;hp=fc5173af2c23a2ae72a7d815f7d4bd35382d0c9b;hb=c70532ab4b3d977ed7484e473107808b22d90a2a;hpb=22528e9bc486cbb6357192bd758c417c61bba955 diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm index fc5173a..fc6a10f 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,12 +20,24 @@ 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.3'; + +use Carp qw(croak); + use Sys::Guestfs; +use File::Temp qw/tempdir/; +use Locale::TextDomain 'libguestfs'; # Optional: eval "use Sys::Virt;"; eval "use XML::XPath;"; eval "use XML::XPath::XMLParser;"; +eval "use Win::Hivex;"; =pod @@ -35,7 +47,7 @@ Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl =head1 SYNOPSIS - use Sys::Guestfs::Lib qw(#any symbols you want to use); + use Sys::Guestfs::Lib qw(open_guest ...); $g = open_guest ($name); @@ -49,6 +61,14 @@ The basic libguestfs API is not covered by this manpage. Please refer instead to L and L. The libvirt API is also not covered. For that, see L. +=head1 DEPRECATION OF SOME FUNCTIONS + +This module contains functions and code to perform inspection of guest +images. Since libguestfs 1.5.3 this ability has moved into the core +API (see L). The inspection functions in this +module are deprecated and will not be updated. Each deprecated +function is marked in the documentation below. + =head1 BASIC FUNCTIONS =cut @@ -58,9 +78,11 @@ require Exporter; use vars qw(@EXPORT_OK @ISA); @ISA = qw(Exporter); -@EXPORT_OK = qw(open_guest get_partitions resolve_windows_path +@EXPORT_OK = qw(open_guest feature_available + get_partitions resolve_windows_path inspect_all_partitions inspect_partition - inspect_operating_systems mount_operating_system inspect_in_detail); + inspect_operating_systems mount_operating_system inspect_in_detail + inspect_linux_kernel); =head2 open_guest @@ -70,9 +92,9 @@ 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) = 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 @@ -85,7 +107,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 @@ -93,130 +116,211 @@ read-write handle, this function will refuse to use active libvirt domains. The handle is still in the config state when it is returned, so you -have to call C<$g-Elaunch ()> and C<$g-Ewait_ready>. +have to call C<$g-Elaunch ()>. The optional C
parameter can be added to specify the libvirt -URI. In addition, L lists other parameters which are -passed through to Cnew> unchanged. +URI. 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 +[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 a +specified qemu interface. See L +for more details. + =cut sub open_guest { + local $_; my $first = shift; my %params = @_; - my $readwrite = $params{rw}; + 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") { - @images = @$first; + @images = @$first; } elsif (ref ($first) eq "SCALAR") { - @images = ($first); + @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 "guest image $_ does not exist or is not readable" - unless -r $_; - } + foreach (@images) { + 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"} && - exists $INC{"XML/XPath.pm"} && - exists $INC{"XML/XPath/XMLParser.pm"}; - - 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; - - my @doms = $conn->list_defined_domains (); - my $isitinactive = "an inactive libvirt domain"; - 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"; - } - foreach (@doms) { - if ($_->get_name () eq $images[0]) { - $dom = $_; - last; - } - } - die "$images[0] is not the name of $isitinactive\n" unless $dom; - - # 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'); - @images = map { $_->getData } @disks; + 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" + if @images > 1; + + my @libvirt_args = (); + push @libvirt_args, address => $address if defined $address; + + $conn = Sys::Virt->new (readonly => 1, @libvirt_args); + die __"open_guest: cannot connect to libvirt" unless $conn; + + my @doms = $conn->list_defined_domains (); + my $isitinactive = 1; + unless ($rw) { + # 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 = 0; + } + foreach (@doms) { + if ($_->get_name () eq $images[0]) { + $dom = $_; + last; + } + } + + 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 $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 = @disks; } # We've now got the list of @images, so feed them to libguestfs. my $g = Sys::Guestfs->new (); foreach (@images) { - if ($readwrite) { - $g->add_drive ($_); - } 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) : $g + return wantarray ? ($g, $conn, $dom, @images) : $g } -=head2 get_partitions +=head2 feature_available + + $bool = feature_available ($g, $feature [, $feature ...]); + +This function is a useful wrapper around the basic +C<$g-Eavailable> call. - @partitions = get_partitions ($g); +C<$g-Eavailable> tests for availability of a list of features and +dies with an error if any is not available. + +This call tests for the list of features and returns true if all are +available, or false otherwise. + +For a list of features you can test for, see L. + +=cut + +sub feature_available { + my $g = shift; + + eval { $g->available (\@_); }; + return $@ ? 0 : 1; +} -This function takes an open libguestfs handle C<$g> and returns all -partitions and logical volumes found on it. +=head2 get_partitions -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). +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API function L instead. =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; + @partitions = grep { ! _is_pv ($_, @pvs) } @partitions; - my @lvs = $g->lvs (); + my @lvs; + @lvs = $g->lvs () if feature_available ($g, "lvm2"); - return sort (@lvs, @partitions); + return sort (@fses_on_device, @lvs, @partitions); } -sub is_pv { +sub _is_pv { local $_; my $t = shift; foreach (@_) { - return 1 if $_ eq $t; + return 1 if $_ eq $t; } 0; } @@ -243,150 +347,49 @@ by C characters. Do not use C<\>, drive names, etc. sub resolve_windows_path { - local $_; my $g = shift; my $path = shift; - if (substr ($path, 0, 1) ne "/") { - warn "resolve_windows_path: path must start with a / character"; - return undef; - } - - my @elems = split (/\//, $path); - shift @elems; - - # Start reconstructing the path at the top. - $path = "/"; - - foreach my $dir (@elems) { - my $found = 0; - foreach ($g->ls ($path)) { - if (lc ($_) eq lc ($dir)) { - if ($path eq "/") { - $path = "/$_"; - $found = 1; - } else { - $path = "$path/$_"; - $found = 1; - } - } - } - return undef unless $found; - } - - return $path; + my $r; + eval { $r = $g->case_sensitive_path ($path); }; + return $r; } -=head1 OPERATING SYSTEM INSPECTION FUNCTIONS - -The functions in this section can be used to inspect the operating -system(s) available inside a virtual machine image. For example, you -can find out if the VM is Linux or Windows, how the partitions are -meant to be mounted, and what applications are installed. - -If you just want a simple command-line interface to this -functionality, use the L tool. The documentation -below covers the case where you want to access this functionality from -a Perl program. - -Once you have the list of partitions (from C) there -are several steps involved: - -=over 4 - -=item 1. - -Look at each partition separately and find out what is on it. - -The information you get back includes whether the partition contains a -filesystem or swapspace, what sort of filesystem (eg. ext3, ntfs), and -a first pass guess at the content of the filesystem (eg. Linux boot, -Windows root). +=head2 file_architecture -The result of this step is a C<%fs> hash of information, one hash for -each partition. +Deprecated function. Replace any calls to this function with: -See: C, C + $g->file_architecture ($path); -=item 2. - -Work out the relationship between partitions. - -In this step we work out how partitions are related to each other. In -the case of a single-boot VM, we work out how the partitions are -mounted in respect of each other (eg. C is mounted as -C). In the case of a multi-boot VM where there are several -roots, we may identify several operating system roots, and mountpoints -can even be shared. - -The result of this step is a single hash called C<%oses> which is -described in more detail below, but at the top level looks like: - - %oses = { - '/dev/VG/Root1' => \%os1, - '/dev/VG/Root2' => \%os2, - } - - %os1 = { - os => 'linux', - mounts => { - '/' => '/dev/VG/Root1', - '/boot' => '/dev/sda1', - }, - ... - } - -(example shows a multi-boot VM containing two root partitions). - -See: C - -=item 3. - -Mount up the disks. - -Previous to this point we've essentially been looking at each -partition in isolation. Now we construct a true guest filesystem by -mounting up all of the disks. Only once everything is mounted up can -we run commands in the OS context to do more detailed inspection. - -See: C - -=item 4. - -Check for kernels and applications. - -This step now does more detailed inspection, where we can look for -kernels, applications and more installed in the guest. - -The result of this is an enhanced C<%os> hash. - -See: C - -=item 5. +=cut -Generate output. +sub file_architecture +{ + my $g = shift; + my $path = shift; -This library does not contain functions for generating output based on -the analysis steps above. Use a command line tool such as -L to get useful output. + return $g->file_architecture ($path); +} -=back +=head1 OPERATING SYSTEM INSPECTION FUNCTIONS =head2 inspect_all_partitions - %fses = inspect_all_partitions ($g, \@partitions); +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. - %fses = inspect_all_partitions ($g, \@partitions, use_windows_registry => 1); - -This calls C for each partition in the list -C<@partitions>. - -The result is a hash which maps partition name to C<\%fs> hashref. +=cut -The contents of the C<%fs> hash and the meaning of the -C flag are explained below. +# Turn /dev/vd* and /dev/hd* into canonical device names +# (see BLOCK DEVICE NAMING in guestfs(3)). -=cut +sub _canonical_dev ($) +{ + my ($dev) = @_; + return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)}; + return $dev; +} sub inspect_all_partitions { @@ -394,88 +397,14 @@ sub inspect_all_partitions my $g = shift; my $parts = shift; my @parts = @$parts; - return map { $_ => inspect_partition ($g, $_, @_) } @parts; + return map { _canonical_dev ($_) => inspect_partition ($g, $_) } @parts; } =head2 inspect_partition - \%fs = inspect_partition ($g, $partition); - - \%fs = inspect_partition ($g, $partition, use_windows_registry => 1); - -This function inspects the device named C<$partition> in isolation and -tries to determine what it is. It returns information such as whether -the partition is formatted, and with what, whether it is mountable, -and what it appears to contain (eg. a Windows root, or a Linux /usr). - -If C is set to 1, then we will try to download -and parse the content of the Windows registry (for Windows root -devices). However since this is an expensive and error-prone -operation, we don't do this by default. It also requires the external -program C, patched to remove numerous crashing bugs in the -upstream version. - -The returned value is a hashref C<\%fs> which may contain the -following top-level keys (any key can be missing): - -=over 4 - -=item fstype - -Filesystem type, eg. "ext2" or "ntfs" - -=item fsos - -Apparent filesystem OS, eg. "linux" or "windows" - -=item is_swap - -If set, the partition is a swap partition. - -=item uuid - -Filesystem UUID. - -=item label - -Filesystem label. - -=item is_mountable - -If set, the partition could be mounted by libguestfs. - -=item content - -Filesystem content, if we could determine it. One of: "linux-grub", -"linux-root", "linux-usrlocal", "linux-usr", "windows-root". - -=item osdistro - -(For Linux root partitions only). -Operating system distribution. One of: "fedora", "redhat", -"debian". - -=item osversion - -(For root partitions only). -Operating system version. - -=item fstab - -(For Linux root partitions only). -The contents of the C file. - -=item boot_ini - -(For Windows root partitions only). -The contents of the C (NTLDR) file. - -=item registry - -The value is an arrayref, which is a list of Windows registry -file contents, in Windows C<.REG> format. - -=back +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. =cut @@ -484,93 +413,90 @@ sub inspect_partition local $_; my $g = shift; my $dev = shift; # LV or partition name. - my %params = @_; - - my $use_windows_registry = $params{use_windows_registry}; my %r; # Result hash. # First try 'file(1)' on it. my $file = $g->file ($dev); if ($file =~ /ext2 filesystem data/) { - $r{fstype} = "ext2"; - $r{fsos} = "linux"; + $r{fstype} = "ext2"; + $r{fsos} = "linux"; } elsif ($file =~ /ext3 filesystem data/) { - $r{fstype} = "ext3"; - $r{fsos} = "linux"; + $r{fstype} = "ext3"; + $r{fsos} = "linux"; } elsif ($file =~ /ext4 filesystem data/) { - $r{fstype} = "ext4"; - $r{fsos} = "linux"; + $r{fstype} = "ext4"; + $r{fsos} = "linux"; } elsif ($file =~ m{Linux/i386 swap file}) { - $r{fstype} = "swap"; - $r{fsos} = "linux"; - $r{is_swap} = 1; + $r{fstype} = "swap"; + $r{fsos} = "linux"; + $r{is_swap} = 1; } # If it's ext2/3/4, then we want the UUID and label. if (exists $r{fstype} && $r{fstype} =~ /^ext/) { - $r{uuid} = $g->get_e2uuid ($dev); - $r{label} = $g->get_e2label ($dev); + $r{uuid} = $g->get_e2uuid ($dev); + $r{label} = $g->get_e2label ($dev); } # Try mounting it, fnarrr. if (!$r{is_swap}) { - $r{is_mountable} = 1; - eval { $g->mount_ro ($dev, "/") }; - if ($@) { - # It's not mountable, probably empty or some format - # we don't understand. - $r{is_mountable} = 0; - goto OUT; - } - - # Grub /boot? - if ($g->is_file ("/grub/menu.lst") || - $g->is_file ("/grub/grub.conf")) { - $r{content} = "linux-grub"; - check_grub ($g, \%r); - goto OUT; - } - - # Linux root? - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_file ("/etc/fstab")) { - $r{content} = "linux-root"; - $r{is_root} = 1; - check_linux_root ($g, \%r); - goto OUT; - } - - # Linux /usr/local. - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_dir ("/share") && !$g->exists ("/local") && - !$g->is_file ("/etc/fstab")) { - $r{content} = "linux-usrlocal"; - goto OUT; - } - - # Linux /usr. - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_dir ("/share") && $g->exists ("/local") && - !$g->is_file ("/etc/fstab")) { - $r{content} = "linux-usr"; - goto OUT; - } - - # Windows root? - if ($g->is_file ("/AUTOEXEC.BAT") || - $g->is_file ("/autoexec.bat") || - $g->is_dir ("/Program Files") || - $g->is_dir ("/WINDOWS") || - $g->is_file ("/boot.ini") || - $g->is_file ("/ntldr")) { - $r{fstype} = "ntfs"; # XXX this is a guess - $r{fsos} = "windows"; - $r{content} = "windows-root"; - $r{is_root} = 1; - check_windows_root ($g, \%r, $use_windows_registry); - goto OUT; - } + $r{is_mountable} = 1; + eval { $g->mount_ro ($dev, "/") }; + if ($@) { + # It's not mountable, probably empty or some format + # we don't understand. + $r{is_mountable} = 0; + goto OUT; + } + + # Grub /boot? + if ($g->is_file ("/grub/menu.lst") || + $g->is_file ("/grub/grub.conf")) { + $r{content} = "linux-grub"; + _check_grub ($g, \%r); + goto OUT; + } + + # Linux root? + if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && + $g->is_file ("/etc/fstab")) { + $r{content} = "linux-root"; + $r{is_root} = 1; + _check_linux_root ($g, \%r); + goto OUT; + } + + # Linux /usr/local. + if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && + $g->is_dir ("/share") && !$g->exists ("/local") && + !$g->is_file ("/etc/fstab")) { + $r{content} = "linux-usrlocal"; + goto OUT; + } + + # Linux /usr. + if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && + $g->is_dir ("/share") && $g->exists ("/local") && + !$g->is_file ("/etc/fstab")) { + $r{content} = "linux-usr"; + goto OUT; + } + + # Windows root? + if ($g->is_file ("/AUTOEXEC.BAT") || + $g->is_file ("/autoexec.bat") || + $g->is_dir ("/Program Files") || + $g->is_dir ("/WINDOWS") || + $g->is_file ("/boot.ini") || + $g->is_file ("/ntldr")) { + $r{fstype} = "ntfs"; # XXX this is a guess + $r{fsos} = "windows"; + $r{content} = "windows-root"; + $r{is_root} = 1; + _check_windows_root ($g, \%r); + goto OUT; + } } OUT: @@ -578,180 +504,288 @@ sub inspect_partition return \%r; } -sub check_linux_root +sub _check_linux_root { local $_; my $g = shift; my $r = shift; # Look into /etc to see if we recognise the operating system. - if ($g->is_file ("/etc/redhat-release")) { - $_ = $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"; - } + # 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+))?/) { + chomp; $r->{product_name} = $_; + $r->{osdistro} = "fedora"; + $r->{os_major_version} = "$1"; + $r->{os_minor_version} = "$2" if(defined($2)); + $r->{package_management} = "yum"; + } + + elsif (/(Red Hat|CentOS|Scientific Linux)/) { + chomp; $r->{product_name} = $_; + + my $distro = $1; + + if($distro eq "Red Hat") { + $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")) { - $_ = $g->cat ("/etc/debian_version"); - if (/(\d+\.\d+)/) { - $r->{osdistro} = "debian"; - $r->{osversion} = "$1"; - } else { - $r->{osdistro} = "debian"; - } + $r->{package_format} = "deb"; + $r->{package_management} = "apt"; + + $_ = $g->cat ("/etc/debian_version"); + if (/(\d+)\.(\d+)/) { + chomp; $r->{product_name} = $_; + $r->{osdistro} = "debian"; + $r->{os_major_version} = "$1"; + $r->{os_minor_version} = "$2"; + } else { + $r->{osdistro} = "debian"; + } } # Parse the contents of /etc/fstab. This is pretty vital so # we can determine where filesystems are supposed to be mounted. eval "\$_ = \$g->cat ('/etc/fstab');"; if (!$@ && $_) { - my @lines = split /\n/; - my @fstab; - foreach (@lines) { - my @fields = split /[ \t]+/; - if (@fields >= 2) { - my $spec = $fields[0]; # first column (dev/label/uuid) - my $file = $fields[1]; # second column (mountpoint) - if ($spec =~ m{^/} || - $spec =~ m{^LABEL=} || - $spec =~ m{^UUID=} || - $file eq "swap") { - push @fstab, [$spec, $file] - } - } - } - $r->{fstab} = \@fstab if @fstab; + my @lines = split /\n/; + my @fstab; + foreach (@lines) { + my @fields = split /[ \t]+/; + if (@fields >= 2) { + my $spec = $fields[0]; # first column (dev/label/uuid) + my $file = $fields[1]; # second column (mountpoint) + if ($spec =~ m{^/} || + $spec =~ m{^LABEL=} || + $spec =~ m{^UUID=} || + $file eq "swap") { + push @fstab, [$spec, $file] + } + } + } + $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 # Windows installations and their %systemroot%s in a simple text # format. # -# 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. +# XXX We don't handle the case where /boot.ini is on a different +# partition very well (Windows Vista and later). -sub check_windows_root +sub _check_windows_root { local $_; my $g = shift; my $r = shift; - my $use_windows_registry = shift; my $boot_ini = resolve_windows_path ($g, "/boot.ini"); $r->{boot_ini} = $boot_ini; + my $systemroot; if (defined $r->{boot_ini}) { - $_ = $g->cat ($boot_ini); - my @lines = split /\n/; - my $section; - my $systemroot; - foreach (@lines) { - if (m/\[.*\]/) { - $section = $1; - } elsif (m/^default=.*?\\(\w+)$/i) { - $systemroot = $1; - last; - } elsif (m/\\(\w+)=/) { - $systemroot = $1; - last; - } - } - - if (defined $systemroot) { - $r->{systemroot} = resolve_windows_path ($g, "/$systemroot"); - if (defined $r->{systemroot} && $use_windows_registry) { - check_windows_registry ($g, $r, $r->{systemroot}); - } - } + $_ = $g->cat ($boot_ini); + my @lines = split /\n/; + my $section; + foreach (@lines) { + if (m/\[.*\]/) { + $section = $1; + } elsif (m/^default=.*?\\(\w+)$/i) { + $systemroot = $1; + last; + } elsif (m/\\(\w+)=/) { + $systemroot = $1; + last; + } + } + } + + if (!defined $systemroot) { + # Last ditch ... try to guess %systemroot% location. + foreach ("windows", "winnt") { + my $dir = resolve_windows_path ($g, "/$_/system32"); + if (defined $dir) { + $systemroot = $_; + last; + } + } + } + + if (defined $systemroot) { + $r->{systemroot} = resolve_windows_path ($g, "/$systemroot"); + if (defined $r->{systemroot}) { + _check_windows_arch ($g, $r, $r->{systemroot}); + _check_windows_registry ($g, $r, $r->{systemroot}); + } } } -sub check_windows_registry +# Find Windows userspace arch. + +sub _check_windows_arch { local $_; my $g = shift; my $r = shift; my $systemroot = shift; - # Download the system registry files. Only download the - # interesting ones, and we don't bother with user profiles at all. - - my $configdir = resolve_windows_path ($g, "$systemroot/system32/config"); - if (defined $configdir) { - my $softwaredir = resolve_windows_path ($g, "$configdir/software"); - if (defined $softwaredir) { - 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"); - } - } + my $cmd_exe = + resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe"); + $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe; } -sub load_windows_registry +sub _check_windows_registry { local $_; my $g = shift; my $r = shift; - my $regfile = shift; - my $prefix = shift; - - my $dir = tempdir (CLEANUP => 1); - - $g->download ($regfile, "$dir/reg"); - - # 'reged' command is particularly noisy. Redirect stdout and - # stderr to /dev/null temporarily. - open SAVEOUT, ">&STDOUT"; - open SAVEERR, ">&STDERR"; - open STDOUT, ">/dev/null"; - open STDERR, ">/dev/null"; + my $systemroot = shift; - my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out"); - my $res = system (@cmd); + # Download the system registry files. Only download the + # interesting ones (SOFTWARE and SYSTEM). We don't bother with + # the user ones. - close STDOUT; - close STDERR; - open STDOUT, ">&SAVEOUT"; - open STDERR, ">&SAVEERR"; - close SAVEOUT; - close SAVEERR; + return unless exists $INC{"Win/Hivex.pm"}; - unless ($res == 0) { - warn "reged command failed: $?"; - return; + my $configdir = resolve_windows_path ($g, "$systemroot/system32/config"); + return unless defined $configdir; + + my $tmpdir = tempdir (CLEANUP => 1); + + my $software = resolve_windows_path ($g, "$configdir/software"); + my $software_hive; + if (defined $software) { + eval { + $g->download ($software, "$tmpdir/software"); + $software_hive = Win::Hivex->open ("$tmpdir/software"); + }; + warn "$@\n" if $@; + $r->{windows_software_hive} = $software; } - # Some versions of reged segfault on inputs. If that happens we - # may get no / partial output file. Anyway, if it exists, load - # it. - my $content; - unless (open F, "$dir/out") { - warn "no output from reged command: $!"; - return; + my $system = resolve_windows_path ($g, "$configdir/system"); + my $system_hive; + if (defined $system) { + eval { + $g->download ($system, "$tmpdir/system"); + $system_hive = Win::Hivex->open ("$tmpdir/system"); + }; + warn "$@\n" if $@; + $r->{windows_system_hive} = $system; } - { local $/ = undef; $content = ; } - close F; - my @registry = (); - @registry = @{$r->{registry}} if exists $r->{registry}; - push @registry, $content; - $r->{registry} = \@registry; + # Get the ProductName, major and minor version, etc. + if (defined $software_hive) { + my $cv_node; + eval { + $cv_node = $software_hive->root; + $cv_node = $software_hive->node_get_child ($cv_node, $_) + foreach ("Microsoft", "Windows NT", "CurrentVersion"); + }; + warn "$@\n" if $@; + + if ($cv_node) { + my @values = $software_hive->node_values ($cv_node); + + foreach (@values) { + my $k = $software_hive->value_key ($_); + if ($k eq "ProductName") { + $_ = $software_hive->value_string ($_); + $r->{product_name} = $_ if defined $_; + } elsif ($k eq "CurrentVersion") { + $_ = $software_hive->value_string ($_); + if (defined $_ && m/^(\d+)\.(\d+)/) { + $r->{os_major_version} = $1; + $r->{os_minor_version} = $2; + } + } elsif ($k eq "CurrentBuild") { + $_ = $software_hive->value_string ($_); + $r->{windows_current_build} = $_ if defined $_; + } elsif ($k eq "SoftwareType") { + $_ = $software_hive->value_string ($_); + $r->{windows_software_type} = $_ if defined $_; + } elsif ($k eq "CurrentType") { + $_ = $software_hive->value_string ($_); + $r->{windows_current_type} = $_ if defined $_; + } elsif ($k eq "RegisteredOwner") { + $_ = $software_hive->value_string ($_); + $r->{windows_registered_owner} = $_ if defined $_; + } elsif ($k eq "RegisteredOrganization") { + $_ = $software_hive->value_string ($_); + $r->{windows_registered_organization} = $_ if defined $_; + } elsif ($k eq "InstallationType") { + $_ = $software_hive->value_string ($_); + $r->{windows_installation_type} = $_ if defined $_; + } elsif ($k eq "EditionID") { + $_ = $software_hive->value_string ($_); + $r->{windows_edition_id} = $_ if defined $_; + } elsif ($k eq "ProductID") { + $_ = $software_hive->value_string ($_); + $r->{windows_product_id} = $_ if defined $_; + } + } + } + } } -sub check_grub +sub _check_grub { local $_; my $g = shift; @@ -762,70 +796,9 @@ sub check_grub =head2 inspect_operating_systems - \%oses = inspect_operating_systems ($g, \%fses); - -This function works out how partitions are related to each other. In -the case of a single-boot VM, we work out how the partitions are -mounted in respect of each other (eg. C is mounted as -C). In the case of a multi-boot VM where there are several -roots, we may identify several operating system roots, and mountpoints -can even be shared. - -This function returns a hashref C<\%oses> which at the top level looks -like: - - %oses = { - '/dev/VG/Root' => \%os, - } - -(There can be multiple roots for a multi-boot VM). - -The C<\%os> hash contains the following keys (any can be omitted): - -=over 4 - -=item os - -Operating system type, eg. "linux", "windows". - -=item distro - -Operating system distribution, eg. "debian". - -=item version - -Operating system version, eg. "4.0". - -=item root - -The value is a reference to the root partition C<%fs> hash. - -=item root_device - -The value is the name of the root partition (as a string). - -=item mounts - -Mountpoints. -The value is a hashref like this: - - mounts => { - '/' => '/dev/VG/Root', - '/boot' => '/dev/sda1', - } - -=item filesystems - -Filesystems (including swap devices and unmounted partitions). -The value is a hashref like this: - - filesystems => { - '/dev/sda1' => \%fs, - '/dev/VG/Root' => \%fs, - '/dev/VG/Swap' => \%fs, - } - -=back +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. =cut @@ -838,32 +811,47 @@ sub inspect_operating_systems my %oses = (); foreach (sort keys %$fses) { - if ($fses->{$_}->{is_root}) { - my %r = ( - root => $fses->{$_}, - root_device => $_ - ); - get_os_version ($g, \%r); - assign_mount_points ($g, $fses, \%r); - $oses{$_} = \%r; - } + if ($fses->{$_}->{is_root}) { + my %r = ( + root => $fses->{$_}, + root_device => $_ + ); + _get_os_version ($g, \%r); + _assign_mount_points ($g, $fses, \%r); + $oses{$_} = \%r; + } + } + + # 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; } -sub get_os_version +sub _get_os_version { local $_; my $g = shift; my $r = shift; $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos}; + $r->{product_name} = $r->{root}->{product_name} + if exists $r->{root}->{product_name}; $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 +sub _assign_mount_points { local $_; my $g = shift; @@ -875,54 +863,55 @@ sub assign_mount_points # Use /etc/fstab if we have it to mount the rest. if (exists $r->{root}->{fstab}) { - my @fstab = @{$r->{root}->{fstab}}; - foreach (@fstab) { - my ($spec, $file) = @$_; - - my ($dev, $fs) = find_filesystem ($g, $fses, $spec); - if ($dev) { - $r->{mounts}->{$file} = $dev; - $r->{filesystems}->{$dev} = $fs; - if (exists $fs->{used}) { - $fs->{used}++ - } else { - $fs->{used} = 1 - } + my @fstab = @{$r->{root}->{fstab}}; + foreach (@fstab) { + my ($spec, $file) = @$_; + + my ($dev, $fs) = _find_filesystem ($g, $fses, $spec, $file); + if ($dev) { + $r->{mounts}->{$file} = $dev; + $r->{filesystems}->{$dev} = $fs; + if (exists $fs->{used}) { + $fs->{used}++ + } else { + $fs->{used} = 1 + } $fs->{spec} = $spec; - } - } + } + } } } # Find filesystem by device name, LABEL=.. or UUID=.. -sub find_filesystem +sub _find_filesystem { my $g = shift; my $fses = shift; local $_ = shift; + my $file = shift; if (/^LABEL=(.*)/) { - my $label = $1; - foreach (sort keys %$fses) { - if (exists $fses->{$_}->{label} && - $fses->{$_}->{label} eq $label) { - return ($_, $fses->{$_}); - } - } - warn "unknown filesystem label $label\n"; - return (); + my $label = $1; + foreach (sort keys %$fses) { + if (exists $fses->{$_}->{label} && + $fses->{$_}->{label} eq $label) { + return ($_, $fses->{$_}); + } + } + warn __x("unknown filesystem label {label}\n", label => $label); + return (); } elsif (/^UUID=(.*)/) { - my $uuid = $1; - foreach (sort keys %$fses) { - if (exists $fses->{$_}->{uuid} && - $fses->{$_}->{uuid} eq $uuid) { - return ($_, $fses->{$_}); - } - } - warn "unknown filesystem UUID $uuid\n"; - return (); + my $uuid = $1; + foreach (sort keys %$fses) { + if (exists $fses->{$_}->{uuid} && + $fses->{$_}->{uuid} eq $uuid) { + return ($_, $fses->{$_}); + } + } + warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid); + return (); } else { - return ($_, $fses->{$_}) if exists $fses->{$_}; + return ($_, $fses->{$_}) if exists $fses->{$_}; # The following is to handle the case where an fstab entry specifies a # specific device rather than its label or uuid, and the libguestfs @@ -930,35 +919,33 @@ sub find_filesystem # different driver. # This will work as long as the underlying drivers recognise devices in # the same order. - if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) { - return ("/dev/sd$1", $fses->{"/dev/sd$1"}); - } - if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) { - return ("/dev/sd$1", $fses->{"/dev/sd$1"}); - } - if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) { - return ("/dev/$1/$2", $fses->{"/dev/$1/$2"}); - } - - return () if m{/dev/cdrom}; - - warn "unknown filesystem $_\n"; - return (); + if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) { + return ("/dev/sd$1", $fses->{"/dev/sd$1"}); + } + if (m{^/dev/vd(.*)} && exists $fses->{"/dev/sd$1"}) { + return ("/dev/sd$1", $fses->{"/dev/sd$1"}); + } + if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) { + return ("/dev/sd$1", $fses->{"/dev/sd$1"}); + } + if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) { + return ("/dev/$1/$2", $fses->{"/dev/$1/$2"}); + } + + return () if $file =~ (/media\/cdrom/); + return () if m{/dev/cdrom}; + return () if m{/dev/fd0}; + + warn __x("unknown filesystem {fs}\n", fs => $_); + return (); } } =head2 mount_operating_system - mount_operating_system ($g, \%os); - -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. - -To reverse the effect of this call, use the standard -libguestfs API call C<$g-Eumount_all ()>. +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. =cut @@ -967,52 +954,30 @@ 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_options ("", $mounts->{$_}, $_) + } + } } } =head2 inspect_in_detail - mount_operating_system ($g, \%os); - inspect_in_detail ($g, \%os); - $g->umount_all (); - -The C function inspects the mounted operating -system for installed applications, installed kernels, kernel modules -and more. - -It adds extra keys to the existing C<%os> hash reflecting what it -finds. These extra keys are: - -=over 4 - -=item apps - -List of applications. - -=item kernels - -List of kernels. - -=item modprobe_aliases - -(For Linux VMs). -The contents of the modprobe configuration. - -=item initrd_modules - -(For Linux VMs). -The kernel modules installed in the initrd. The value is -a hashref of kernel version to list of modules. - -=back +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. =cut @@ -1022,15 +987,14 @@ 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); + _find_modprobe_aliases ($g, $os); } } -sub check_for_applications +sub _check_for_applications { local $_; my $g = shift; @@ -1040,128 +1004,349 @@ 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 @lines = $g->command_lines - (["rpm", - "-q", "-a", - "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]); - foreach (@lines) { - if (m/^(.*) (.*) (.*) (.*) (.*)$/) { - my $epoch = $2; - $epoch = "" if $epoch eq "(none)"; - my $app = { - name => $1, - epoch => $epoch, - version => $3, - release => $4, - arch => $5 - }; - push @apps, $app - } - } - } + my $package_format = $os->{package_format}; + if (defined $package_format && $package_format eq "rpm") { + 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/^(.*) (.*) (.*) (.*) (.*)$/) { + my $epoch = $2; + undef $epoch if $epoch eq "(none)"; + my $app = { + name => $1, + epoch => $epoch, + version => $3, + release => $4, + arch => $5 + }; + push @apps, $app + } + } + } elsif (defined $package_format && $package_format eq "deb") { + 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/^(.*) (.*) (.*) (.*) (.*) (.*)$/) { + if ( $6 eq "installed" ) { + my $app = { + name => $1, + version => $2, + arch => $3 + }; + push @apps, $app + } + } + } + } } elsif ($osn eq "windows") { - # XXX - # I worked out a general plan for this, but haven't - # implemented it yet. We can iterate over /Program Files - # looking for *.EXE files, which we download, then use - # i686-pc-mingw32-windres on, to find the VERSIONINFO - # section, which has a lot of useful information. + # XXX + # I worked out a general plan for this, but haven't + # implemented it yet. We can iterate over /Program Files + # looking for *.EXE files, which we download, then use + # i686-pc-mingw32-windres on, to find the VERSIONINFO + # section, which has a lot of useful information. } $os->{apps} = \@apps; } -sub check_for_kernels +# Find the path which needs to be prepended to paths in grub.conf to make them +# absolute +sub _find_grub_prefix { - local $_; - my $g = shift; - my $os = shift; + my ($g, $os) = @_; + + my $fses = $os->{filesystems}; + die("filesystems undefined") unless(defined($fses)); + + # Look for the filesystem which contains grub + my $grubdev; + foreach my $dev (keys(%$fses)) { + my $fsinfo = $fses->{$dev}; + if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") { + $grubdev = $dev; + last; + } + } - my @kernels; + my $mounts = $os->{mounts}; + die("mounts undefined") unless(defined($mounts)); + + # Find where the filesystem is mounted + if(defined($grubdev)) { + foreach my $mount (keys(%$mounts)) { + if($mounts->{$mount} eq $grubdev) { + return "" if($mount eq '/'); + return $mount; + } + } - my $osn = $os->{os}; - if ($osn eq "linux") { - # Installed kernels will have a corresponding /lib/modules/ - # directory, which is the easiest way to find out what kernels - # are installed, and what modules are available. - foreach ($g->ls ("/lib/modules")) { - if ($g->is_dir ("/lib/modules/$_")) { - my %kernel; - $kernel{version} = $_; - - # List modules. - my @modules; - foreach ($g->find ("/lib/modules/$_")) { - if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) { - push @modules, $1; - } - } - - $kernel{modules} = \@modules; - - push @kernels, \%kernel; - } - } + die("$grubdev defined in filesystems, but not in mounts"); + } - } elsif ($osn eq "windows") { - # XXX + # If we didn't find it, look for /boot/grub/menu.lst, then try to work out + # what filesystem it's on. We use menu.lst rather than grub.conf because + # debian only uses menu.lst, and anaconda creates a symlink for it. + die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst')); + + # Look for the most specific mount point in mounts + foreach my $path (qw(/boot/grub /boot /)) { + if(exists($mounts->{$path})) { + return "" if($path eq '/'); + return $path; + } } - $os->{kernels} = \@kernels; + die("Couldn't determine which filesystem holds /boot/grub/menu.lst"); } -# Check /etc/modprobe.conf to see if there are any specified -# drivers associated with network (ethX) or hard drives. Normally -# one might find something like: -# -# alias eth0 xennet -# alias scsi_hostadapter xenblk -# -# XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/ +sub _check_for_kernels +{ + my ($g, $os) = @_; -sub check_for_modprobe_aliases + if ($os->{os} eq "linux" && feature_available ($g, "augeas")) { + # Iterate over entries in grub.conf, populating $os->{boot} + # For every kernel we find, inspect it and add to $os->{kernels} + + my $grub = _find_grub_prefix($g, $os); + my $grub_conf = "/etc/grub.conf"; + + # Debian and other's have no /etc/grub.conf: + if ( ! -f "$grub_conf" ) { + $grub_conf = "$grub/grub/menu.lst"; + } + + my @boot_configs; + + # We want + # $os->{boot} + # ->{configs} + # ->[0] + # ->{title} = "Fedora (2.6.29.6-213.fc11.i686.PAE)" + # ->{kernel} = \kernel + # ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb" + # ->{initrd} = \initrd + # ->{default} = \config + # ->{grub_fs} = "/boot" + # Initialise augeas + $g->aug_init("/", 16); + + my @configs = (); + # Get all configurations from grub + foreach my $bootable + ($g->aug_match("/files/$grub_conf/title")) + { + my %config = (); + $config{title} = $g->aug_get($bootable); + + my $grub_kernel; + eval { $grub_kernel = $g->aug_get("$bootable/kernel"); }; + if($@) { + warn __x("Grub entry {title} has no kernel", + title => $config{title}); + } + + # Check we've got a kernel entry + if(defined($grub_kernel)) { + my $path = "$grub$grub_kernel"; + + # Reconstruct the kernel command line + my @args = (); + foreach my $arg ($g->aug_match("$bootable/kernel/*")) { + $arg =~ m{/kernel/([^/]*)$} + or die("Unexpected return from aug_match: $arg"); + + my $name = $1; + my $value; + eval { $value = $g->aug_get($arg); }; + + if(defined($value)) { + push(@args, "$name=$value"); + } else { + push(@args, $name); + } + } + $config{cmdline} = join(' ', @args) if(scalar(@args) > 0); + + 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)) { + # Put this kernel on the top level kernel list + $os->{kernels} ||= []; + push(@{$os->{kernels}}, $kernel); + + $config{kernel} = $kernel; + + # Look for an initrd entry + my $initrd; + eval { + $initrd = $g->aug_get("$bootable/initrd"); + }; + + unless($@) { + $config{initrd} = + _inspect_initrd($g, $os, "$grub$initrd", + $kernel->{version}); + } else { + warn __x("Grub entry {title} does not specify an ". + "initrd", title => $config{title}); + } + } + } + + push(@configs, \%config); + } + + + # Create the top level boot entry + my %boot; + $boot{configs} = \@configs; + $boot{grub_fs} = $grub; + + # Add the default configuration + eval { + $boot{default} = $g->aug_get("/files/$grub_conf/default"); + }; + + $os->{boot} = \%boot; + } + + elsif ($os->{os} eq "windows") { + # XXX + } +} + +=head2 inspect_linux_kernel + +This function is deprecated. It will not be updated in future +versions of libguestfs. New code should not use this function. Use +the core API functions instead, see L. + +=cut + +sub inspect_linux_kernel +{ + my ($g, $path, $package_format) = @_; + + my %kernel = (); + + $kernel{path} = $path; + + # If this is a packaged kernel, try to work out the name of the package + # which installed it. This lets us know what to install to replace it with, + # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE + if($package_format eq "rpm") { + my $package; + eval { $package = $g->command(['rpm', '-qf', '--qf', + '%{NAME}', $path]); }; + $kernel{package} = $package if defined($package);; + } + + # Try to get the kernel version by running file against it + my $version; + my $filedesc = $g->file($path); + if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) { + $version = $1; + } + + # Sometimes file can't work out the kernel version, for example because it's + # a Xen PV kernel. In this case try to guess the version from the filename + else { + if($path =~ m{/boot/vmlinuz-(.*)}) { + $version = $1; + + # Check /lib/modules/$version exists + if(!$g->is_dir("/lib/modules/$version")) { + warn __x("Didn't find modules directory {modules} for kernel ". + "{path}", modules => "/lib/modules/$version", + path => $path); + + # Give up + return undef; + } + } else { + warn __x("Couldn't guess kernel version number from path for ". + "kernel {path}", path => $path); + + # Give up + return undef; + } + } + + $kernel{version} = $version; + + # List modules. + my @modules; + my $any_module; + my $prefix = "/lib/modules/$version"; + foreach my $module ($g->find ($prefix)) { + if ($module =~ m{/([^/]+)\.(?:ko|o)$}) { + $any_module = "$prefix$module" 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); + + return \%kernel; +} + +# Find all modprobe aliases. Specifically, this looks in the following +# locations: +# * /etc/conf.modules +# * /etc/modules.conf +# * /etc/modprobe.conf +# * /etc/modprobe.d/* + +sub _find_modprobe_aliases { local $_; my $g = shift; my $os = shift; # Initialise augeas - my $success = 0; - $success = $g->aug_init("/", 16); - - # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens - my @results; - @results = $g->aug_match("/augeas/load/Modprobe/incl"); - - # Calculate the next index of /augeas/load/Modprobe/incl - my $i = 1; - foreach ( @results ) { - next unless m{/augeas/load/Modprobe/incl\[(\d*)]}; - $i = $1 + 1 if ($1 == $i); - } - - $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]", - "/etc/modules.conf"); - $i++; - $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]", - "/etc/conf.modules"); - - # Make augeas reload - $success = $g->aug_load(); + $g->aug_init("/", 16); my %modprobe_aliases; - for my $pattern qw(/files/etc/conf.modules/alias - /files/etc/modules.conf/alias - /files/etc/modprobe.conf/alias - /files/etc/modprobe.d/*/alias) { - @results = $g->aug_match($pattern); - - for my $path ( @results ) { + for my $pattern (qw(/files/etc/conf.modules/alias + /files/etc/modules.conf/alias + /files/etc/modprobe.conf/alias + /files/etc/modprobe.d/*/alias)) { + for my $path ( $g->aug_match($pattern) ) { $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; @@ -1182,43 +1367,40 @@ sub check_for_modprobe_aliases $os->{modprobe_aliases} = \%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 +# Get a listing of device drivers from an initrd +sub _inspect_initrd { - local $_; - my $g = shift; - my $os = shift; - - my %initrd_modules; - - foreach my $initrd ($g->ls ("/boot")) { - if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$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" - } - } + my ($g, $os, $path, $version) = @_; + + my @modules; + + # 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->exists($path) && $g->file($path) =~ /cpio/) { + eval { + @modules = $g->initrd_list ($path); + }; + unless ($@) { + @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules; + } else { + warn __x("{filename}: could not read initrd format", + filename => "$path"); + } } - $os->{initrd_modules} = \%initrd_modules; -} + # Add to the top level initrd_modules entry + $os->{initrd_modules} ||= {}; + $os->{initrd_modules}->{$version} = \@modules; + return \@modules; +} 1; =head1 COPYRIGHT -Copyright (C) 2009 Red Hat Inc. +Copyright (C) 2009-2010 Red Hat Inc. =head1 LICENSE