X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=8e20593797143b2ddaf00e21241154b82071c734;hp=27a7b9ee246c67adfbddc7c3c6306c83eff5f24c;hb=6279c4bbf9cbbe66917ce9ffa4b98eca9040bcd9;hpb=335a8e3b0efa4c9dee01591134aeeb2b17ae22f5 diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm index 27a7b9e..8e20593 100644 --- a/perl/lib/Sys/Guestfs/Lib.pm +++ b/perl/lib/Sys/Guestfs/Lib.pm @@ -22,6 +22,7 @@ use warnings; use Sys::Guestfs; use File::Temp qw/tempdir/; +use Locale::TextDomain 'libguestfs'; # Optional: eval "use Sys::Virt;"; @@ -77,7 +78,7 @@ use vars qw(@EXPORT_OK @ISA); $g = open_guest ([$img1, $img2, ...], address => $uri, ...); - ($g, $conn, $dom) = open_guest ($name); + ($g, $conn, $dom, @images) = open_guest ($name); This function opens a libguestfs handle for either the libvirt domain called C<$name>, or the disk image called C<$name>. Any disk images @@ -107,10 +108,10 @@ passed through to Cnew> unchanged. The implicit libvirt handle is closed after this function, I you call the function in C context, in which case the function returns a tuple of: the open libguestfs handle, the open -libvirt handle, and the open libvirt domain handle. (This is useful -if you want to do other things like pulling the XML description of the -guest). Note that if this is a straight disk image, then C<$conn> and -C<$dom> will be C. +libvirt handle, and the open libvirt domain handle, and a list of +images. (This is useful if you want to do other things like pulling +the XML description of the guest). Note that if this is a straight +disk image, then C<$conn> and C<$dom> will be C. If the C module is not available, then libvirt is bypassed, and this function can only open disk images. @@ -131,35 +132,36 @@ sub open_guest } elsif (ref ($first) eq "SCALAR") { @images = ($first); } else { - die "open_guest: first parameter must be a string or an arrayref" + die __"open_guest: first parameter must be a string or an arrayref" } my ($conn, $dom); if (-e $images[0]) { foreach (@images) { - die "guest image $_ does not exist or is not readable" + die __x("guest image {imagename} does not exist or is not readable", + imagename => $_) unless -r $_; } } else { - die "open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)" + die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)" unless exists $INC{"Sys/Virt.pm"} && exists $INC{"XML/XPath.pm"} && exists $INC{"XML/XPath/XMLParser.pm"}; - die "open_guest: too many domains listed on command line" + die __"open_guest: too many domains listed on command line" if @images > 1; $conn = Sys::Virt->new (readonly => 1, @_); - die "open_guest: cannot connect to libvirt" unless $conn; + die __"open_guest: cannot connect to libvirt" unless $conn; my @doms = $conn->list_defined_domains (); - my $isitinactive = "an inactive libvirt domain"; + my $isitinactive = 1; unless ($readwrite) { # In the case where we want read-only access to a domain, # allow the user to specify an active domain too. push @doms, $conn->list_domains (); - $isitinactive = "a libvirt domain"; + $isitinactive = 0; } foreach (@doms) { if ($_->get_name () eq $images[0]) { @@ -167,7 +169,16 @@ sub open_guest last; } } - die "$images[0] is not the name of $isitinactive\n" unless $dom; + + unless ($dom) { + if ($isitinactive) { + die __x("{imagename} is not the name of an inactive libvirt domain\n", + imagename => $images[0]); + } else { + die __x("{imagename} is not the name of a libvirt domain\n", + imagename => $images[0]); + } + } # Get the names of the image(s). my $xml = $dom->get_xml_description (); @@ -176,7 +187,9 @@ sub open_guest my @disks = $p->findnodes ('//devices/disk/source/@dev'); push (@disks, $p->findnodes ('//devices/disk/source/@file')); - die "$images[0] seems to have no disk devices\n" unless @disks; + die __x("{imagename} seems to have no disk devices\n", + imagename => $images[0]) + unless @disks; @images = map { $_->getData } @disks; } @@ -191,7 +204,7 @@ sub open_guest } } - return wantarray ? ($g, $conn, $dom) : $g + return wantarray ? ($g, $conn, $dom, @images) : $g } =head2 get_partitions @@ -258,7 +271,7 @@ sub resolve_windows_path my $path = shift; if (substr ($path, 0, 1) ne "/") { - warn "resolve_windows_path: path must start with a / character"; + warn __"resolve_windows_path: path must start with a / character"; return undef; } @@ -287,6 +300,163 @@ sub resolve_windows_path return $path; } +=head2 file_architecture + + $arch = file_architecture ($g, $path) + +The C function lets you get the architecture for a +particular binary or library in the guest. By "architecture" we mean +what processor it is compiled for (eg. C or C). + +The function works on at least the following types of files: + +=over 4 + +=item * + +many types of Un*x binary + +=item * + +many types of Un*x shared library + +=item * + +Windows Win32 and Win64 binaries + +=item * + +Windows Win32 and Win64 DLLs + +Win32 binaries and DLLs return C. + +Win64 binaries and DLLs return C. + +=item * + +Linux kernel modules + +=item * + +Linux new-style initrd images + +=item * + +some non-x86 Linux vmlinuz kernels + +=back + +What it can't do currently: + +=over 4 + +=item * + +static libraries (libfoo.a) + +=item * + +Linux old-style initrd as compressed ext2 filesystem (RHEL 3) + +=item * + +x86 Linux vmlinuz kernels + +x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and +compressed code, and are horribly hard to unpack. If you want to find +the architecture of a kernel, use the architecture of the associated +initrd or kernel module(s) instead. + +=back + +=cut + +sub _elf_arch_to_canonical +{ + local $_ = shift; + + if ($_ eq "Intel 80386") { + return "i386"; + } elsif ($_ eq "Intel 80486") { + return "i486"; # probably not in the wild + } elsif ($_ eq "x86-64") { + return "x86_64"; + } elsif ($_ eq "AMD x86-64") { + return "x86_64"; + } elsif (/SPARC32/) { + return "sparc"; + } elsif (/SPARC V9/) { + return "sparc64"; + } elsif ($_ eq "IA-64") { + return "ia64"; + } elsif (/64.*PowerPC/) { + return "ppc64"; + } elsif (/PowerPC/) { + return "ppc"; + } else { + warn __x("returning non-canonical architecture type '{arch}'", + arch => $_); + return $_; + } +} + +my @_initrd_binaries = ("nash", "modprobe", "sh", "bash"); + +sub file_architecture +{ + local $_; + my $g = shift; + my $path = shift; + + # Our basic tool is 'file' ... + my $file = $g->file ($path); + + if ($file =~ /ELF.*(?:executable|shared object|relocatable), (.+?),/) { + # ELF executable or shared object. We need to convert + # what file(1) prints into the canonical form. + return _elf_arch_to_canonical ($1); + } elsif ($file =~ /PE32 executable/) { + return "i386"; # Win32 executable or DLL + } elsif ($file =~ /PE32\+ executable/) { + return "x86_64"; # Win64 executable or DLL + } + + elsif ($file =~ /cpio archive/) { + # Probably an initrd. + my $zcat = "cat"; + if ($file =~ /gzip/) { + $zcat = "zcat"; + } elsif ($file =~ /bzip2/) { + $zcat = "bzcat"; + } + + # Download and unpack it to find a binary file. + my $dir = tempdir (CLEANUP => 1); + $g->download ($path, "$dir/initrd"); + + my $bins = join " ", map { "bin/$_" } @_initrd_binaries; + my $cmd = "cd $dir && $zcat initrd | cpio --quiet -id $bins"; + my $r = system ($cmd); + die __x("cpio command failed: {error}", error => $?) + unless $r == 0; + + foreach my $bin (@_initrd_binaries) { + if (-f "$dir/bin/$bin") { + $_ = `file $dir/bin/$bin`; + if (/ELF.*executable, (.+?),/) { + return _elf_arch_to_canonical ($1); + } + } + } + + die __x("file_architecture: no known binaries found in initrd image: {path}", + path => $path); + } + + die __x("file_architecture: unknown architecture: {path}", + path => $path); +} + =head1 OPERATING SYSTEM INSPECTION FUNCTIONS The functions in this section can be used to inspect the operating @@ -336,7 +506,7 @@ described in more detail below, but at the top level looks like: '/dev/VG/Root1' => \%os1, '/dev/VG/Root2' => \%os2, } - + %os1 = { os => 'linux', mounts => { @@ -462,13 +632,29 @@ Filesystem content, if we could determine it. One of: "linux-grub", =item osdistro (For Linux root partitions only). -Operating system distribution. One of: "fedora", "redhat", -"debian". +Operating system distribution. One of: "fedora", "rhel", "centos", +"scientific", "debian". + +=item package_format + +(For Linux root partitions only) +The package format used by the guest distribution. One of: "rpm", "dpkg". + +=item package_management + +(For Linux root partitions only) +The package management tool used by the guest distribution. One of: "rhn", +"yum", "apt". + +=item os_major_version -=item osversion +(For root partitions only). +Operating system major version number. + +=item os_minor_version (For root partitions only). -Operating system version. +Operating system minor version number. =item fstab @@ -595,25 +781,75 @@ sub _check_linux_root my $r = shift; # Look into /etc to see if we recognise the operating system. - if ($g->is_file ("/etc/redhat-release")) { + # N.B. don't use $g->is_file here, because it might be a symlink + if ($g->exists ("/etc/redhat-release")) { + $r->{package_format} = "rpm"; + $_ = $g->cat ("/etc/redhat-release"); - if (/Fedora release (\d+\.\d+)/) { + if (/Fedora release (\d+)(?:\.(\d+))?/) { $r->{osdistro} = "fedora"; - $r->{osversion} = "$1" - } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) { - $r->{osdistro} = "redhat"; - $r->{osversion} = "$2.$3"; - } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) { - $r->{osdistro} = "redhat"; - $r->{osversion} = "$2"; - } else { - $r->{osdistro} = "redhat"; + $r->{os_major_version} = "$1"; + $r->{os_minor_version} = "$2" if(defined($2)); + $r->{package_management} = "yum"; + } + + elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) { + my $distro = $1; + + if($distro eq "Red Hat Enterprise Linux") { + $r->{osdistro} = "rhel"; + } + + elsif($distro eq "CentOS") { + $r->{osdistro} = "centos"; + $r->{package_management} = "yum"; + } + + elsif($distro eq "Scientific Linux") { + $r->{osdistro} = "scientific"; + $r->{package_management} = "yum"; + } + + # Shouldn't be possible + else { die }; + + if (/$distro.*release (\d+).*Update (\d+)/) { + $r->{os_major_version} = "$1"; + $r->{os_minor_version} = "$2"; + } + + elsif (/$distro.*release (\d+)(?:\.(\d+))?/) { + $r->{os_major_version} = "$1"; + + if(defined($2)) { + $r->{os_minor_version} = "$2"; + } else { + $r->{os_minor_version} = "0"; + } + } + + # Package management in RHEL changed in version 5 + if ($r->{osdistro} eq "rhel") { + if ($r->{os_major_version} >= 5) { + $r->{package_management} = "yum"; + } else { + $r->{package_management} = "rhn"; + } + } + } + + else { + $r->{osdistro} = "redhat-based"; } } elsif ($g->is_file ("/etc/debian_version")) { + $r->{package_format} = "dpkg"; + $r->{package_management} = "apt"; + $_ = $g->cat ("/etc/debian_version"); - if (/(\d+\.\d+)/) { + if (/(\d+)\.(\d+)/) { $r->{osdistro} = "debian"; - $r->{osversion} = "$1"; + $r->{os_major_version} = "$1"; + $r->{os_minor_version} = "$2"; } else { $r->{osdistro} = "debian"; } @@ -640,6 +876,17 @@ sub _check_linux_root } $r->{fstab} = \@fstab if @fstab; } + + # Determine the architecture of this root. + my $arch; + foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") { + if ($g->is_file ($_)) { + $arch = file_architecture ($g, $_); + last; + } + } + + $r->{arch} = $arch if defined $arch; } # We only support NT. The control file /boot.ini contains a list of @@ -678,13 +925,30 @@ sub _check_windows_root if (defined $systemroot) { $r->{systemroot} = resolve_windows_path ($g, "/$systemroot"); - if (defined $r->{systemroot} && $use_windows_registry) { - _check_windows_registry ($g, $r, $r->{systemroot}); + if (defined $r->{systemroot}) { + _check_windows_arch ($g, $r, $r->{systemroot}); + if ($use_windows_registry) { + _check_windows_registry ($g, $r, $r->{systemroot}); + } } } } } +# Find Windows userspace arch. + +sub _check_windows_arch +{ + local $_; + my $g = shift; + my $r = shift; + my $systemroot = shift; + + my $cmd_exe = + resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe"); + $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe; +} + sub _check_windows_registry { local $_; @@ -740,7 +1004,7 @@ sub _load_windows_registry close SAVEERR; unless ($res == 0) { - warn "reged command failed: $?"; + warn __x("reged command failed: {errormsg}", errormsg => $?); return; } @@ -749,7 +1013,7 @@ sub _load_windows_registry # it. my $content; unless (open F, "$dir/out") { - warn "no output from reged command: $!"; + warn __x("no output from reged command: {errormsg}", errormsg => $!); return; } { local $/ = undef; $content = ; } @@ -787,7 +1051,7 @@ 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): @@ -798,13 +1062,21 @@ The C<\%os> hash contains the following keys (any can be omitted): Operating system type, eg. "linux", "windows". +=item arch + +Operating system userspace architecture, eg. "i386", "x86_64". + =item distro Operating system distribution, eg. "debian". -=item version +=item major_version + +Operating system major version, eg. "4". -Operating system version, eg. "4.0". +=item minor_version + +Operating system minor version, eg "3". =item root @@ -870,7 +1142,15 @@ sub _get_os_version $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos}; $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro}; - $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion}; + $r->{major_version} = $r->{root}->{os_major_version} + if exists $r->{root}->{os_major_version}; + $r->{minor_version} = $r->{root}->{os_minor_version} + if exists $r->{root}->{os_minor_version}; + $r->{package_format} = $r->{root}->{package_format} + if exists $r->{root}->{package_format}; + $r->{package_management} = $r->{root}->{package_management} + if exists $r->{root}->{package_management}; + $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch}; } sub _assign_mount_points @@ -919,7 +1199,7 @@ sub _find_filesystem return ($_, $fses->{$_}); } } - warn "unknown filesystem label $label\n"; + warn __x("unknown filesystem label {label}\n", label => $label); return (); } elsif (/^UUID=(.*)/) { my $uuid = $1; @@ -929,7 +1209,7 @@ sub _find_filesystem return ($_, $fses->{$_}); } } - warn "unknown filesystem UUID $uuid\n"; + warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid); return (); } else { return ($_, $fses->{$_}) if exists $fses->{$_}; @@ -952,20 +1232,21 @@ sub _find_filesystem return () if m{/dev/cdrom}; - warn "unknown filesystem $_\n"; + warn __x("unknown filesystem {fs}\n", fs => $_); return (); } } =head2 mount_operating_system - mount_operating_system ($g, \%os); + mount_operating_system ($g, \%os, [$ro]); This function mounts the operating system described in the C<%os> hash according to the C table in that hash (see C). -The partitions are mounted read-only. +The partitions are mounted read-only unless the third parameter +is specified as zero explicitly. To reverse the effect of this call, use the standard libguestfs API call C<$g-Eumount_all ()>. @@ -977,14 +1258,22 @@ sub mount_operating_system local $_; my $g = shift; my $os = shift; + my $ro = shift; # Read-only? + + $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified my $mounts = $os->{mounts}; # Have to mount / first. Luckily '/' is early in the ASCII # character set, so this should be OK. foreach (sort keys %$mounts) { - $g->mount_ro ($mounts->{$_}, $_) - if $_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_)); + if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) { + if($ro) { + $g->mount_ro ($mounts->{$_}, $_) + } else { + $g->mount ($mounts->{$_}, $_) + } + } } } @@ -995,8 +1284,8 @@ sub mount_operating_system $g->umount_all (); The C function inspects the mounted operating -system for installed applications, installed kernels, kernel modules -and more. +system for installed applications, installed kernels, kernel modules, +system architecture, and more. It adds extra keys to the existing C<%os> hash reflecting what it finds. These extra keys are: @@ -1007,10 +1296,74 @@ finds. These extra keys are: 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 + +=back + =item kernels List of kernels. +This is a hash of kernel version =E a hash with the following keys: + +=over 4 + +=item version + +Kernel version. + +=item arch + +Kernel architecture (eg. C). + +=item modules + +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 (For Linux VMs). @@ -1035,8 +1388,7 @@ sub inspect_in_detail _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); } } @@ -1050,8 +1402,8 @@ sub _check_for_applications my $osn = $os->{os}; if ($osn eq "linux") { - my $distro = $os->{distro}; - if (defined $distro && ($distro eq "redhat" || $distro eq "fedora")) { + my $package_format = $os->{package_format}; + if (defined $package_format && $package_format eq "rpm") { my @lines = $g->command_lines (["rpm", "-q", "-a", @@ -1085,81 +1437,211 @@ sub _check_for_applications sub _check_for_kernels { - local $_; - my $g = shift; - my $os = shift; + my ($g, $os) = @_; - my @kernels; + if ($os->{os} eq "linux") { + # Iterate over entries in grub.conf, populating $os->{boot} + # For every kernel we find, inspect it and add to $os->{kernels} + + 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 + # Initialise augeas + $g->aug_init("/", 16); + + my @configs = (); + # Get all configurations from grub + foreach my $bootable + ($g->aug_match("/files/etc/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 = "/boot$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 = _inspect_linux_kernel($g, $os, "$path"); + + # Check the kernel was recognised + if(defined($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, "/boot$initrd", + $kernel->{version}); + } else { + warn __x("Grub entry {title} does not specify an ". + "initrd", title => $config{title}); + } + } + } + + push(@configs, \%config); + } - 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; + # Create the top level boot entry + my %boot; + $boot{configs} = \@configs; - push @kernels, \%kernel; - } - } + # Add the default configuration + eval { + $boot{default} = $g->aug_get("/files/etc/grub.conf/default"); + }; + if($@) { + warn __"No grub default specified"; + } - } elsif ($osn eq "windows") { + $os->{boot} = \%boot; + } + + elsif ($os->{os} eq "windows") { # XXX } +} + +sub _inspect_linux_kernel +{ + my ($g, $os, $path) = @_; + + 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($os->{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); + + # Put this kernel on the top level kernel list + my $kernels = $os->{kernels}; + if(!defined($kernels)) { + $kernels = []; + $os->{kernels} = $kernels; + } + push(@$kernels, \%kernel); - $os->{kernels} = \@kernels; + return \%kernel; } -# 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/ +# Find all modprobe aliases. Specifically, this looks in the following +# locations: +# * /etc/conf.modules +# * /etc/modules.conf +# * /etc/modprobe.conf +# * /etc/modprobe.d/* -sub _check_for_modprobe_aliases +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); - } + $g->aug_init("/", 16); - $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"); + # Register additional paths to the Modprobe lens + $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/modules.conf"); + $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/conf.modules"); # Make augeas reload - $success = $g->aug_load(); + $g->aug_load(); my %modprobe_aliases; @@ -1167,11 +1649,10 @@ sub _check_for_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("$path doesn't match augeas pattern"); + or die __x("{path} doesn't match augeas pattern", + path => $path); my $file = $1; my $alias; @@ -1192,37 +1673,39 @@ 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; + 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->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"); + } + } - 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" - } - } + # Add to the top level initrd_modules entry + my $initrd_modules = $os->{initrd_modules}; + if(!defined($initrd_modules)) { + $initrd_modules = {}; + $os->{initrd_modules} = $initrd_modules; } - $os->{initrd_modules} = \%initrd_modules; -} + $initrd_modules->{$version} = \@modules; + return \@modules; +} 1;