# 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
use strict;
use warnings;
+# The minor part of this version number is incremented when some
+# change is made to this module. The major part is incremented if we
+# make a change which is not backwards compatible. It is not related
+# to the libguestfs version number.
+use vars qw($VERSION);
+$VERSION = '0.2';
+
+use Carp qw(croak);
+
use Sys::Guestfs;
use File::Temp qw/tempdir/;
use Locale::TextDomain 'libguestfs';
eval "use Sys::Virt;";
eval "use XML::XPath;";
eval "use XML::XPath::XMLParser;";
+eval "use Win::Hivex;";
=pod
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
domains.
The handle is still in the config state when it is returned, so you
-have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
+have to call C<$g-E<gt>launch ()>.
The optional C<address> parameter can be added to specify the libvirt
-URI. In addition, L<Sys::Virt(3)> lists other parameters which are
-passed through to C<Sys::Virt-E<gt>new> unchanged.
+URI.
The implicit libvirt handle is closed after this function, I<unless>
you call the function in C<wantarray> context, in which case the
If the C<Sys::Virt> module is not available, then libvirt is bypassed,
and this function can only open disk images.
+The optional C<interface> parameter can be used to open devices with
+C<add_drive{,_ro}_with_if>. See
+L<Sys::Guestfs/guestfs_add_drive_with_if> for more details.
+
=cut
sub open_guest
my $first = shift;
my %params = @_;
- my $readwrite = $params{rw};
+ my $rw = $params{rw};
+ my $address = $params{address};
+ my $interface = $params{interface};
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"
}
my ($conn, $dom);
if (-e $images[0]) {
- foreach (@images) {
- die __x("guest image {imagename} does not exist or is not readable",
- imagename => $_)
- unless -r $_;
- }
+ foreach (@images) {
+ croak __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)"
- 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 = 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 = 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 @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;
+ 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 @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;
}
# 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 ($_);
- }
+ if ($rw) {
+ if ($interface) {
+ $g->add_drive_with_if ($_, $interface);
+ } else {
+ $g->add_drive ($_);
+ }
+ } else {
+ if ($interface) {
+ $g->add_drive_ro_with_if ($_, $interface);
+ } else {
+ $g->add_drive_ro ($_);
+ }
+ }
}
return wantarray ? ($g, $conn, $dom, @images) : $g
}
+=head2 feature_available
+
+ $bool = feature_available ($g, $feature [, $feature ...]);
+
+This function is a useful wrapper around the basic
+C<$g-E<gt>available> call.
+
+C<$g-E<gt>available> 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<guestfs(3)/AVAILABILITY>.
+
+=cut
+
+sub feature_available {
+ my $g = shift;
+
+ eval { $g->available (\@_); };
+ return $@ ? 0 : 1;
+}
+
=head2 get_partitions
@partitions = get_partitions ($g);
partitions and logical volumes found on it.
What is returned is everything that could contain a filesystem (or
-swap). Physical volumes are excluded from the list, and so are any
-devices which are partitioned (eg. C</dev/sda> would not be returned
-if C</dev/sda1> exists).
+swap). Physical volumes are not normally included from the list
+except if they contain a filesystem directly. Nor are devices which
+are partitioned (eg. C</dev/sda> would not be returned if C</dev/sda1>
+exists).
=cut
sub get_partitions
{
+ local $_;
my $g = shift;
+ # Look to see if any devices directly contain filesystems (RHBZ#590167).
+ my @devices = $g->list_devices ();
+ my @fses_on_device = ();
+ foreach (@devices) {
+ eval { $g->mount_ro ($_, "/"); };
+ push @fses_on_device, $_ unless $@;
+ $g->umount_all ();
+ }
+
my @partitions = $g->list_partitions ();
my @pvs = $g->pvs ();
@partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
- 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 {
my $t = shift;
foreach (@_) {
- return 1 if $_ eq $t;
+ return 1 if $_ eq $t;
}
0;
}
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;
}
=head2 file_architecture
local $_ = shift;
if ($_ eq "Intel 80386") {
- return "i386";
+ return "i386";
} elsif ($_ eq "Intel 80486") {
- return "i486"; # probably not in the wild
+ return "i486"; # probably not in the wild
} elsif ($_ eq "x86-64") {
- return "x86_64";
+ return "x86_64";
+ } elsif ($_ eq "AMD x86-64") {
+ return "x86_64";
} elsif (/SPARC32/) {
- return "sparc";
+ return "sparc";
} elsif (/SPARC V9/) {
- return "sparc64";
+ return "sparc64";
} elsif ($_ eq "IA-64") {
- return "ia64";
+ return "ia64";
} elsif (/64.*PowerPC/) {
- return "ppc64";
+ return "ppc64";
} elsif (/PowerPC/) {
- return "ppc";
+ return "ppc";
} else {
- warn __x("returning non-canonical architecture type '{arch}'",
- arch => $_);
- return $_;
+ warn __x("returning non-canonical architecture type '{arch}'",
+ arch => $_);
+ return $_;
}
}
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);
+ # 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
+ return "i386"; # Win32 executable or DLL
} elsif ($file =~ /PE32\+ executable/) {
- return "x86_64"; # Win64 executable or DLL
+ 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 -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);
+ # 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);
+ path => $path);
}
=head1 OPERATING SYSTEM INSPECTION FUNCTIONS
'/dev/VG/Root1' => \%os1,
'/dev/VG/Root2' => \%os2,
}
-
+
%os1 = {
os => 'linux',
mounts => {
%fses = inspect_all_partitions ($g, \@partitions);
- %fses = inspect_all_partitions ($g, \@partitions, use_windows_registry => 1);
-
This calls C<inspect_partition> for each partition in the list
C<@partitions>.
The result is a hash which maps partition name to C<\%fs> hashref.
-The contents of the C<%fs> hash and the meaning of the
-C<use_windows_registry> flag are explained below.
+The contents of the C<%fs> hash is explained below.
=cut
+# Turn /dev/vd* and /dev/hd* into canonical device names
+# (see BLOCK DEVICE NAMING in guestfs(3)).
+
+sub _canonical_dev ($)
+{
+ my ($dev) = @_;
+ return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
+ return $dev;
+}
+
sub inspect_all_partitions
{
local $_;
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<use_windows_registry> 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<reged>, patched to remove numerous crashing bugs in the
-upstream version.
+If the Perl module L<Win::Hivex(3)> is installed, then additional
+information is made available for Windows guests, if we can locate and
+read their registries.
The returned value is a hashref C<\%fs> which may contain the
following top-level keys (any key can be missing):
=item package_format
(For Linux root partitions only)
-The package format used by the guest distribution. One of: "rpm", "dpkg".
+The package format used by the guest distribution. One of: "rpm", "deb".
=item package_management
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:
if ($g->exists ("/etc/redhat-release")) {
$r->{package_format} = "rpm";
- $_ = $g->cat ("/etc/redhat-release");
- if (/Fedora release (\d+)(?:\.(\d+))?/) {
- $r->{osdistro} = "fedora";
- $r->{os_major_version} = "$1";
- $r->{os_minor_version} = "$2" if(defined($2));
- $r->{package_management} = "yum";
- }
-
+ $_ = $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 Enterprise Linux|CentOS|Scientific Linux)/) {
+ chomp; $r->{product_name} = $_;
+
my $distro = $1;
if($distro eq "Red Hat Enterprise Linux") {
}
else {
- $r->{osdistro} = "redhat-based";
- }
+ $r->{osdistro} = "redhat-based";
+ }
} elsif ($g->is_file ("/etc/debian_version")) {
- $r->{package_format} = "dpkg";
+ $r->{package_format} = "deb";
$r->{package_management} = "apt";
- $_ = $g->cat ("/etc/debian_version");
- if (/(\d+)\.(\d+)/) {
- $r->{osdistro} = "debian";
- $r->{os_major_version} = "$1";
- $r->{os_minor_version} = "$2";
- } else {
- $r->{osdistro} = "debian";
- }
+ $_ = $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;
- }
+ if ($g->is_file ($_)) {
+ $arch = file_architecture ($g, $_);
+ last;
+ }
}
$r->{arch} = $arch if defined $arch;
# 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
{
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}) {
- _check_windows_arch ($g, $r, $r->{systemroot});
- if ($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});
+ }
}
}
my $systemroot = shift;
my $cmd_exe =
- resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
+ resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
$r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
}
my $systemroot = shift;
# Download the system registry files. Only download the
- # interesting ones, and we don't bother with user profiles at all.
+ # interesting ones (SOFTWARE and SYSTEM). We don't bother with
+ # the user ones.
+
+ return unless exists $INC{"Win/Hivex.pm"};
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");
- }
+ 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;
}
-}
-
-sub _load_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 @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
- my $res = system (@cmd);
-
- close STDOUT;
- close STDERR;
- open STDOUT, ">&SAVEOUT";
- open STDERR, ">&SAVEERR";
- close SAVEOUT;
- close SAVEERR;
- unless ($res == 0) {
- warn __x("reged command failed: {errormsg}", errormsg => $?);
- 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;
}
- # 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 __x("no output from reged command: {errormsg}", errormsg => $!);
- return;
+ # 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 $_;
+ }
+ }
+ }
}
- { local $/ = undef; $content = <F>; }
- close F;
-
- my @registry = ();
- @registry = @{$r->{registry}} if exists $r->{registry};
- push @registry, $content;
- $r->{registry} = \@registry;
}
sub _check_grub
%oses = {
'/dev/VG/Root' => \%os,
}
-
-(There can be multiple roots for a multi-boot VM).
+
+There can be multiple roots for a multi-boot VM, but this function
+will throw an error if no roots (ie. OSes) could be found.
The C<\%os> hash contains the following keys (any can be omitted):
Operating system distribution, eg. "debian".
+=item product_name
+
+Free text product name.
+
=item major_version
Operating system major version, eg. "4".
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;
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->{major_version} = $r->{root}->{os_major_version}
if exists $r->{root}->{os_major_version};
# 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);
+ if ($dev) {
+ $r->{mounts}->{$file} = $dev;
+ $r->{filesystems}->{$dev} = $fs;
+ if (exists $fs->{used}) {
+ $fs->{used}++
+ } else {
+ $fs->{used} = 1
+ }
$fs->{spec} = $spec;
- }
- }
+ }
+ }
}
}
local $_ = shift;
if (/^LABEL=(.*)/) {
- 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 ();
+ 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 __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
- 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
# 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 __x("unknown filesystem {fs}\n", fs => $_);
- return ();
+ 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 __x("unknown filesystem {fs}\n", fs => $_);
+ return ();
}
}
if($ro) {
$g->mount_ro ($mounts->{$_}, $_)
} else {
- $g->mount ($mounts->{$_}, $_)
+ $g->mount_options ("", $mounts->{$_}, $_)
}
}
}
List of applications.
+=item boot
+
+Boot configurations. A hash containing:
+
+=over 4
+
+=item configs
+
+An array of boot configurations. Each array entry is a hash containing:
+
+=over 4
+
+=item initrd
+
+A reference to the expanded initrd structure (see below) for the initrd used by
+this boot configuration.
+
+=item kernel
+
+A reference to the expanded kernel structure (see below) for the kernel used by
+this boot configuration.
+
+=item title
+
+The human readable name of the configuration.
+
+=item cmdline
+
+The kernel command line.
+
+=back
+
+=item default
+
+The index of the default configuration in the configs array.
+
+=item grub_fs
+
+The path of the filesystem containing the grub partition.
+
+=back
+
=item kernels
List of kernels.
List of modules.
+=item path
+
+The path to the kernel's vmlinuz file.
+
+=item package
+
+If the kernel was installed in a package, the name of that package.
+
=back
=item modprobe_aliases
_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);
}
}
my $osn = $os->{os};
if ($osn eq "linux") {
- my $package_format = $os->{package_format};
- if (defined $package_format && $package_format eq "rpm") {
- my @lines = $g->command_lines
- (["rpm",
- "-q", "-a",
- "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
- 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;
}
+# Find the path which needs to be prepended to paths in grub.conf to make them
+# absolute
+sub _find_grub_prefix
+{
+ 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 $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;
+ }
+ }
+
+ die("$grubdev defined in filesystems, but not in mounts");
+ }
+
+ # 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;
+ }
+ }
+
+ die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
+}
+
sub _check_for_kernels
{
- local $_;
- my $g = shift;
- my $os = shift;
+ my ($g, $os) = @_;
- my @kernels;
+ 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 $osn = $os->{os};
- if ($osn eq "linux") {
- # Installed kernels will have a corresponding /lib/modules/<version>
- # 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;
- 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;
- }
- }
+ my $grub = _find_grub_prefix($g, $os);
+ my $grub_conf = "/etc/grub.conf";
- } elsif ($osn eq "windows") {
- # XXX
+ # 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;
}
- $os->{kernels} = \@kernels;
+ elsif ($os->{os} eq "windows") {
+ # XXX
+ }
}
-# 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/
+=head2 inspect_linux_kernel
+
+ my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
+
+inspect_linux_kernel returns a hash describing the target linux kernel. For the
+contents of the hash, see the I<kernels> structure described under
+L</inspect_in_detail>.
+
+=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;
+ }
+ }
-sub _check_for_modprobe_aliases
+ $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;
/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 $path ( $g->aug_match($pattern) ) {
$path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
or die __x("{path} doesn't match augeas pattern",
- path => $path);
+ path => $path);
my $file = $1;
my $alias;
$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;
-
- # 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");
- }
- }
- }
+ 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;
git.annexia.org / libguestfs.git / blobdiff