perl/lib/Sys/Guestfs/Lib.pm

   1 # Sys::Guestfs::Lib
   2 # Copyright (C) 2009 Red Hat Inc.
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 package Sys::Guestfs::Lib;
  19
  20 use strict;
  21 use warnings;
  22
  23 use Sys::Guestfs;
  24 use File::Temp qw/tempdir/;
  25 use Locale::TextDomain 'libguestfs';
  26
  27 # Optional:
  28 eval "use Sys::Virt;";
  29 eval "use XML::XPath;";
  30 eval "use XML::XPath::XMLParser;";
  31
  32 =pod
  33
  34 =head1 NAME
  35
  36 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
  37
  38 =head1 SYNOPSIS
  39
  40  use Sys::Guestfs::Lib qw(open_guest inspect_all_partitions ...);
  41
  42  $g = open_guest ($name);
  43
  44  %fses = inspect_all_partitions ($g, \@partitions);
  45
  46 (and many more calls - see the rest of this manpage)
  47
  48 =head1 DESCRIPTION
  49
  50 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
  51 the libguestfs API from Perl.  It also provides tighter integration
  52 with libvirt.
  53
  54 The basic libguestfs API is not covered by this manpage.  Please refer
  55 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
  56 also not covered.  For that, see L<Sys::Virt(3)>.
  57
  58 =head1 BASIC FUNCTIONS
  59
  60 =cut
  61
  62 require Exporter;
  63
  64 use vars qw(@EXPORT_OK @ISA);
  65
  66 @ISA = qw(Exporter);
  67 @EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
  68   inspect_all_partitions inspect_partition
  69   inspect_operating_systems mount_operating_system inspect_in_detail);
  70
  71 =head2 open_guest
  72
  73  $g = open_guest ($name);
  74
  75  $g = open_guest ($name, rw => 1, ...);
  76
  77  $g = open_guest ($name, address => $uri, ...);
  78
  79  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
  80
  81  ($g, $conn, $dom, @images) = open_guest ($name);
  82
  83 This function opens a libguestfs handle for either the libvirt domain
  84 called C<$name>, or the disk image called C<$name>.  Any disk images
  85 found through libvirt or specified explicitly are attached to the
  86 libguestfs handle.
  87
  88 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
  89 it throws an exception.  To catch errors, wrap the call in an eval
  90 block.
  91
  92 The first parameter is either a string referring to a libvirt domain
  93 or a disk image, or (if a guest has several disk images) an arrayref
  94 C<[$img1, $img2, ...]>.
  95
  96 The handle is I<read-only> by default.  Use the optional parameter
  97 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
  98 read-write handle, this function will refuse to use active libvirt
  99 domains.
 100
 101 The handle is still in the config state when it is returned, so you
 102 have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
 103
 104 The optional C<address> parameter can be added to specify the libvirt
 105 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
 106 passed through to C<Sys::Virt-E<gt>new> unchanged.
 107
 108 The implicit libvirt handle is closed after this function, I<unless>
 109 you call the function in C<wantarray> context, in which case the
 110 function returns a tuple of: the open libguestfs handle, the open
 111 libvirt handle, and the open libvirt domain handle, and a list of
 112 images.  (This is useful if you want to do other things like pulling
 113 the XML description of the guest).  Note that if this is a straight
 114 disk image, then C<$conn> and C<$dom> will be C<undef>.
 115
 116 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 117 and this function can only open disk images.
 118
 119 =cut
 120
 121 sub open_guest
 122 {
 123     local $_;
 124     my $first = shift;
 125     my %params = @_;
 126
 127     my $readwrite = $params{rw};
 128
 129     my @images = ();
 130     if (ref ($first) eq "ARRAY") {
 131         @images = @$first;
 132     } elsif (ref ($first) eq "SCALAR") {
 133         @images = ($first);
 134     } else {
 135         die __"open_guest: first parameter must be a string or an arrayref"
 136     }
 137
 138     my ($conn, $dom);
 139
 140     if (-e $images[0]) {
 141         foreach (@images) {
 142             die __x("guest image {imagename} does not exist or is not readable",
 143                     imagename => $_)
 144                 unless -r $_;
 145         }
 146     } else {
 147         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
 148             unless exists $INC{"Sys/Virt.pm"} &&
 149             exists $INC{"XML/XPath.pm"} &&
 150             exists $INC{"XML/XPath/XMLParser.pm"};
 151
 152         die __"open_guest: too many domains listed on command line"
 153             if @images > 1;
 154
 155         $conn = Sys::Virt->new (readonly => 1, @_);
 156         die __"open_guest: cannot connect to libvirt" unless $conn;
 157
 158         my @doms = $conn->list_defined_domains ();
 159         my $isitinactive = 1;
 160         unless ($readwrite) {
 161             # In the case where we want read-only access to a domain,
 162             # allow the user to specify an active domain too.
 163             push @doms, $conn->list_domains ();
 164             $isitinactive = 0;
 165         }
 166         foreach (@doms) {
 167             if ($_->get_name () eq $images[0]) {
 168                 $dom = $_;
 169                 last;
 170             }
 171         }
 172
 173         unless ($dom) {
 174             if ($isitinactive) {
 175                 die __x("{imagename} is not the name of an inactive libvirt domain\n",
 176                         imagename => $images[0]);
 177             } else {
 178                 die __x("{imagename} is not the name of a libvirt domain\n",
 179                         imagename => $images[0]);
 180             }
 181         }
 182
 183         # Get the names of the image(s).
 184         my $xml = $dom->get_xml_description ();
 185
 186         my $p = XML::XPath->new (xml => $xml);
 187         my @disks = $p->findnodes ('//devices/disk/source/@dev');
 188         push (@disks, $p->findnodes ('//devices/disk/source/@file'));
 189
 190         die __x("{imagename} seems to have no disk devices\n",
 191                 imagename => $images[0])
 192             unless @disks;
 193
 194         @images = map { $_->getData } @disks;
 195     }
 196
 197     # We've now got the list of @images, so feed them to libguestfs.
 198     my $g = Sys::Guestfs->new ();
 199     foreach (@images) {
 200         if ($readwrite) {
 201             $g->add_drive ($_);
 202         } else {
 203             $g->add_drive_ro ($_);
 204         }
 205     }
 206
 207     return wantarray ? ($g, $conn, $dom, @images) : $g
 208 }
 209
 210 =head2 get_partitions
 211
 212  @partitions = get_partitions ($g);
 213
 214 This function takes an open libguestfs handle C<$g> and returns all
 215 partitions and logical volumes found on it.
 216
 217 What is returned is everything that could contain a filesystem (or
 218 swap).  Physical volumes are excluded from the list, and so are any
 219 devices which are partitioned (eg. C</dev/sda> would not be returned
 220 if C</dev/sda1> exists).
 221
 222 =cut
 223
 224 sub get_partitions
 225 {
 226     my $g = shift;
 227
 228     my @partitions = $g->list_partitions ();
 229     my @pvs = $g->pvs ();
 230     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 231
 232     my @lvs = $g->lvs ();
 233
 234     return sort (@lvs, @partitions);
 235 }
 236
 237 sub _is_pv {
 238     local $_;
 239     my $t = shift;
 240
 241     foreach (@_) {
 242         return 1 if $_ eq $t;
 243     }
 244     0;
 245 }
 246
 247 =head2 resolve_windows_path
 248
 249  $path = resolve_windows_path ($g, $path);
 250
 251  $path = resolve_windows_path ($g, "/windows/system");
 252    ==> "/WINDOWS/System"
 253        or undef if no path exists
 254
 255 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
 256 guests), lets you look up a case insensitive C<$path> in the
 257 filesystem and returns the true, case sensitive path as required by
 258 the underlying kernel or NTFS-3g driver.
 259
 260 If C<$path> does not exist then this function returns C<undef>.
 261
 262 The C<$path> parameter must begin with C</> character and be separated
 263 by C</> characters.  Do not use C<\>, drive names, etc.
 264
 265 =cut
 266
 267 sub resolve_windows_path
 268 {
 269     local $_;
 270     my $g = shift;
 271     my $path = shift;
 272
 273     if (substr ($path, 0, 1) ne "/") {
 274         warn __"resolve_windows_path: path must start with a / character";
 275         return undef;
 276     }
 277
 278     my @elems = split (/\//, $path);
 279     shift @elems;
 280
 281     # Start reconstructing the path at the top.
 282     $path = "/";
 283
 284     foreach my $dir (@elems) {
 285         my $found = 0;
 286         foreach ($g->ls ($path)) {
 287             if (lc ($_) eq lc ($dir)) {
 288                 if ($path eq "/") {
 289                     $path = "/$_";
 290                     $found = 1;
 291                 } else {
 292                     $path = "$path/$_";
 293                     $found = 1;
 294                 }
 295             }
 296         }
 297         return undef unless $found;
 298     }
 299
 300     return $path;
 301 }
 302
 303 =head2 file_architecture
 304
 305  $arch = file_architecture ($g, $path)
 306
 307 The C<file_architecture> function lets you get the architecture for a
 308 particular binary or library in the guest.  By "architecture" we mean
 309 what processor it is compiled for (eg. C<i586> or C<x86_64>).
 310
 311 The function works on at least the following types of files:
 312
 313 =over 4
 314
 315 =item *
 316
 317 many types of Un*x binary
 318
 319 =item *
 320
 321 many types of Un*x shared library
 322
 323 =item *
 324
 325 Windows Win32 and Win64 binaries
 326
 327 =item *
 328
 329 Windows Win32 and Win64 DLLs
 330
 331 Win32 binaries and DLLs return C<i386>.
 332
 333 Win64 binaries and DLLs return C<x86_64>.
 334
 335 =item *
 336
 337 Linux kernel modules
 338
 339 =item *
 340
 341 Linux new-style initrd images
 342
 343 =item *
 344
 345 some non-x86 Linux vmlinuz kernels
 346
 347 =back
 348
 349 What it can't do currently:
 350
 351 =over 4
 352
 353 =item *
 354
 355 static libraries (libfoo.a)
 356
 357 =item *
 358
 359 Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
 360
 361 =item *
 362
 363 x86 Linux vmlinuz kernels
 364
 365 x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
 366 compressed code, and are horribly hard to unpack.  If you want to find
 367 the architecture of a kernel, use the architecture of the associated
 368 initrd or kernel module(s) instead.
 369
 370 =back
 371
 372 =cut
 373
 374 sub _elf_arch_to_canonical
 375 {
 376     local $_ = shift;
 377
 378     if ($_ eq "Intel 80386") {
 379         return "i386";
 380     } elsif ($_ eq "Intel 80486") {
 381         return "i486";  # probably not in the wild
 382     } elsif ($_ eq "x86-64") {
 383         return "x86_64";
 384     } elsif (/SPARC32/) {
 385         return "sparc";
 386     } elsif (/SPARC V9/) {
 387         return "sparc64";
 388     } elsif ($_ eq "IA-64") {
 389         return "ia64";
 390     } elsif (/64.*PowerPC/) {
 391         return "ppc64";
 392     } elsif (/PowerPC/) {
 393         return "ppc";
 394     } else {
 395         warn __x("returning non-canonical architecture type '{arch}'",
 396                  arch => $_);
 397         return $_;
 398     }
 399 }
 400
 401 my @_initrd_binaries = ("nash", "modprobe", "sh", "bash");
 402
 403 sub file_architecture
 404 {
 405     local $_;
 406     my $g = shift;
 407     my $path = shift;
 408
 409     # Our basic tool is 'file' ...
 410     my $file = $g->file ($path);
 411
 412     if ($file =~ /ELF.*(?:executable|shared object|relocatable), (.+?),/) {
 413         # ELF executable or shared object.  We need to convert
 414         # what file(1) prints into the canonical form.
 415         return _elf_arch_to_canonical ($1);
 416     } elsif ($file =~ /PE32 executable/) {
 417         return "i386";          # Win32 executable or DLL
 418     } elsif ($file =~ /PE32\+ executable/) {
 419         return "x86_64";        # Win64 executable or DLL
 420     }
 421
 422     elsif ($file =~ /cpio archive/) {
 423         # Probably an initrd.
 424         my $zcat = "cat";
 425         if ($file =~ /gzip/) {
 426             $zcat = "zcat";
 427         } elsif ($file =~ /bzip2/) {
 428             $zcat = "bzcat";
 429         }
 430
 431         # Download and unpack it to find a binary file.
 432         my $dir = tempdir (CLEANUP => 1);
 433         $g->download ($path, "$dir/initrd");
 434
 435         my $bins = join " ", map { "bin/$_" } @_initrd_binaries;
 436         my $cmd = "cd $dir && $zcat initrd | cpio -id $bins";
 437         my $r = system ($cmd);
 438         die __x("cpio command failed: {error}", error => $?)
 439             unless $r == 0;
 440
 441         foreach my $bin (@_initrd_binaries) {
 442             if (-f "$dir/bin/$bin") {
 443                 $_ = `file $dir/bin/$bin`;
 444                 if (/ELF.*executable, (.+?),/) {
 445                     return _elf_arch_to_canonical ($1);
 446                 }
 447             }
 448         }
 449
 450         die __x("file_architecture: no known binaries found in initrd image: {path}",
 451                 path => $path);
 452     }
 453
 454     die __x("file_architecture: unknown architecture: {path}",
 455             path => $path);
 456 }
 457
 458 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
 459
 460 The functions in this section can be used to inspect the operating
 461 system(s) available inside a virtual machine image.  For example, you
 462 can find out if the VM is Linux or Windows, how the partitions are
 463 meant to be mounted, and what applications are installed.
 464
 465 If you just want a simple command-line interface to this
 466 functionality, use the L<virt-inspector(1)> tool.  The documentation
 467 below covers the case where you want to access this functionality from
 468 a Perl program.
 469
 470 Once you have the list of partitions (from C<get_partitions>) there
 471 are several steps involved:
 472
 473 =over 4
 474
 475 =item 1.
 476
 477 Look at each partition separately and find out what is on it.
 478
 479 The information you get back includes whether the partition contains a
 480 filesystem or swapspace, what sort of filesystem (eg. ext3, ntfs), and
 481 a first pass guess at the content of the filesystem (eg. Linux boot,
 482 Windows root).
 483
 484 The result of this step is a C<%fs> hash of information, one hash for
 485 each partition.
 486
 487 See: C<inspect_partition>, C<inspect_all_partitions>
 488
 489 =item 2.
 490
 491 Work out the relationship between partitions.
 492
 493 In this step we work out how partitions are related to each other.  In
 494 the case of a single-boot VM, we work out how the partitions are
 495 mounted in respect of each other (eg. C</dev/sda1> is mounted as
 496 C</boot>).  In the case of a multi-boot VM where there are several
 497 roots, we may identify several operating system roots, and mountpoints
 498 can even be shared.
 499
 500 The result of this step is a single hash called C<%oses> which is
 501 described in more detail below, but at the top level looks like:
 502
 503  %oses = {
 504    '/dev/VG/Root1' => \%os1,
 505    '/dev/VG/Root2' => \%os2,
 506  }
 507
 508  %os1 = {
 509    os => 'linux',
 510    mounts => {
 511      '/' => '/dev/VG/Root1',
 512      '/boot' => '/dev/sda1',
 513    },
 514    ...
 515  }
 516
 517 (example shows a multi-boot VM containing two root partitions).
 518
 519 See: C<inspect_operating_systems>
 520
 521 =item 3.
 522
 523 Mount up the disks.
 524
 525 Previous to this point we've essentially been looking at each
 526 partition in isolation.  Now we construct a true guest filesystem by
 527 mounting up all of the disks.  Only once everything is mounted up can
 528 we run commands in the OS context to do more detailed inspection.
 529
 530 See: C<mount_operating_system>
 531
 532 =item 4.
 533
 534 Check for kernels and applications.
 535
 536 This step now does more detailed inspection, where we can look for
 537 kernels, applications and more installed in the guest.
 538
 539 The result of this is an enhanced C<%os> hash.
 540
 541 See: C<inspect_in_detail>
 542
 543 =item 5.
 544
 545 Generate output.
 546
 547 This library does not contain functions for generating output based on
 548 the analysis steps above.  Use a command line tool such as
 549 L<virt-inspector(1)> to get useful output.
 550
 551 =back
 552
 553 =head2 inspect_all_partitions
 554
 555  %fses = inspect_all_partitions ($g, \@partitions);
 556
 557  %fses = inspect_all_partitions ($g, \@partitions, use_windows_registry => 1);
 558
 559 This calls C<inspect_partition> for each partition in the list
 560 C<@partitions>.
 561
 562 The result is a hash which maps partition name to C<\%fs> hashref.
 563
 564 The contents of the C<%fs> hash and the meaning of the
 565 C<use_windows_registry> flag are explained below.
 566
 567 =cut
 568
 569 sub inspect_all_partitions
 570 {
 571     local $_;
 572     my $g = shift;
 573     my $parts = shift;
 574     my @parts = @$parts;
 575     return map { $_ => inspect_partition ($g, $_, @_) } @parts;
 576 }
 577
 578 =head2 inspect_partition
 579
 580  \%fs = inspect_partition ($g, $partition);
 581
 582  \%fs = inspect_partition ($g, $partition, use_windows_registry => 1);
 583
 584 This function inspects the device named C<$partition> in isolation and
 585 tries to determine what it is.  It returns information such as whether
 586 the partition is formatted, and with what, whether it is mountable,
 587 and what it appears to contain (eg. a Windows root, or a Linux /usr).
 588
 589 If C<use_windows_registry> is set to 1, then we will try to download
 590 and parse the content of the Windows registry (for Windows root
 591 devices).  However since this is an expensive and error-prone
 592 operation, we don't do this by default.  It also requires the external
 593 program C<reged>, patched to remove numerous crashing bugs in the
 594 upstream version.
 595
 596 The returned value is a hashref C<\%fs> which may contain the
 597 following top-level keys (any key can be missing):
 598
 599 =over 4
 600
 601 =item fstype
 602
 603 Filesystem type, eg. "ext2" or "ntfs"
 604
 605 =item fsos
 606
 607 Apparent filesystem OS, eg. "linux" or "windows"
 608
 609 =item is_swap
 610
 611 If set, the partition is a swap partition.
 612
 613 =item uuid
 614
 615 Filesystem UUID.
 616
 617 =item label
 618
 619 Filesystem label.
 620
 621 =item is_mountable
 622
 623 If set, the partition could be mounted by libguestfs.
 624
 625 =item content
 626
 627 Filesystem content, if we could determine it.  One of: "linux-grub",
 628 "linux-root", "linux-usrlocal", "linux-usr", "windows-root".
 629
 630 =item osdistro
 631
 632 (For Linux root partitions only).
 633 Operating system distribution.  One of: "fedora", "rhel", "centos",
 634 "scientific", "debian".
 635
 636 =item package_format
 637
 638 (For Linux root partitions only)
 639 The package format used by the guest distribution. One of: "rpm", "dpkg".
 640
 641 =item package_management
 642
 643 (For Linux root partitions only)
 644 The package management tool used by the guest distribution. One of: "rhn",
 645 "yum", "apt".
 646
 647 =item os_major_version
 648
 649 (For root partitions only).
 650 Operating system major version number.
 651
 652 =item os_minor_version
 653
 654 (For root partitions only).
 655 Operating system minor version number.
 656
 657 =item fstab
 658
 659 (For Linux root partitions only).
 660 The contents of the C</etc/fstab> file.
 661
 662 =item boot_ini
 663
 664 (For Windows root partitions only).
 665 The contents of the C</boot.ini> (NTLDR) file.
 666
 667 =item registry
 668
 669 The value is an arrayref, which is a list of Windows registry
 670 file contents, in Windows C<.REG> format.
 671
 672 =back
 673
 674 =cut
 675
 676 sub inspect_partition
 677 {
 678     local $_;
 679     my $g = shift;
 680     my $dev = shift;            # LV or partition name.
 681     my %params = @_;
 682
 683     my $use_windows_registry = $params{use_windows_registry};
 684
 685     my %r;                      # Result hash.
 686
 687     # First try 'file(1)' on it.
 688     my $file = $g->file ($dev);
 689     if ($file =~ /ext2 filesystem data/) {
 690         $r{fstype} = "ext2";
 691         $r{fsos} = "linux";
 692     } elsif ($file =~ /ext3 filesystem data/) {
 693         $r{fstype} = "ext3";
 694         $r{fsos} = "linux";
 695     } elsif ($file =~ /ext4 filesystem data/) {
 696         $r{fstype} = "ext4";
 697         $r{fsos} = "linux";
 698     } elsif ($file =~ m{Linux/i386 swap file}) {
 699         $r{fstype} = "swap";
 700         $r{fsos} = "linux";
 701         $r{is_swap} = 1;
 702     }
 703
 704     # If it's ext2/3/4, then we want the UUID and label.
 705     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 706         $r{uuid} = $g->get_e2uuid ($dev);
 707         $r{label} = $g->get_e2label ($dev);
 708     }
 709
 710     # Try mounting it, fnarrr.
 711     if (!$r{is_swap}) {
 712         $r{is_mountable} = 1;
 713         eval { $g->mount_ro ($dev, "/") };
 714         if ($@) {
 715             # It's not mountable, probably empty or some format
 716             # we don't understand.
 717             $r{is_mountable} = 0;
 718             goto OUT;
 719         }
 720
 721         # Grub /boot?
 722         if ($g->is_file ("/grub/menu.lst") ||
 723             $g->is_file ("/grub/grub.conf")) {
 724             $r{content} = "linux-grub";
 725             _check_grub ($g, \%r);
 726             goto OUT;
 727         }
 728
 729         # Linux root?
 730         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 731             $g->is_file ("/etc/fstab")) {
 732             $r{content} = "linux-root";
 733             $r{is_root} = 1;
 734             _check_linux_root ($g, \%r);
 735             goto OUT;
 736         }
 737
 738         # Linux /usr/local.
 739         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 740             $g->is_dir ("/share") && !$g->exists ("/local") &&
 741             !$g->is_file ("/etc/fstab")) {
 742             $r{content} = "linux-usrlocal";
 743             goto OUT;
 744         }
 745
 746         # Linux /usr.
 747         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 748             $g->is_dir ("/share") && $g->exists ("/local") &&
 749             !$g->is_file ("/etc/fstab")) {
 750             $r{content} = "linux-usr";
 751             goto OUT;
 752         }
 753
 754         # Windows root?
 755         if ($g->is_file ("/AUTOEXEC.BAT") ||
 756             $g->is_file ("/autoexec.bat") ||
 757             $g->is_dir ("/Program Files") ||
 758             $g->is_dir ("/WINDOWS") ||
 759             $g->is_file ("/boot.ini") ||
 760             $g->is_file ("/ntldr")) {
 761             $r{fstype} = "ntfs"; # XXX this is a guess
 762             $r{fsos} = "windows";
 763             $r{content} = "windows-root";
 764             $r{is_root} = 1;
 765             _check_windows_root ($g, \%r, $use_windows_registry);
 766             goto OUT;
 767         }
 768     }
 769
 770   OUT:
 771     $g->umount_all ();
 772     return \%r;
 773 }
 774
 775 sub _check_linux_root
 776 {
 777     local $_;
 778     my $g = shift;
 779     my $r = shift;
 780
 781     # Look into /etc to see if we recognise the operating system.
 782     # N.B. don't use $g->is_file here, because it might be a symlink
 783     if ($g->exists ("/etc/redhat-release")) {
 784         $r->{package_format} = "rpm";
 785
 786         $_ = $g->cat ("/etc/redhat-release");
 787         if (/Fedora release (\d+)(?:\.(\d+))?/) {
 788             $r->{osdistro} = "fedora";
 789             $r->{os_major_version} = "$1";
 790             $r->{os_minor_version} = "$2" if(defined($2));
 791             $r->{package_management} = "yum";
 792         }
 793
 794         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
 795             my $distro = $1;
 796
 797             if($distro eq "Red Hat Enterprise Linux") {
 798                 $r->{osdistro} = "rhel";
 799             }
 800
 801             elsif($distro eq "CentOS") {
 802                 $r->{osdistro} = "centos";
 803                 $r->{package_management} = "yum";
 804             }
 805
 806             elsif($distro eq "Scientific Linux") {
 807                 $r->{osdistro} = "scientific";
 808                 $r->{package_management} = "yum";
 809             }
 810
 811             # Shouldn't be possible
 812             else { die };
 813
 814             if (/$distro.*release (\d+).*Update (\d+)/) {
 815                 $r->{os_major_version} = "$1";
 816                 $r->{os_minor_version} = "$2";
 817             }
 818
 819             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
 820                 $r->{os_major_version} = "$1";
 821
 822                 if(defined($2)) {
 823                     $r->{os_minor_version} = "$2";
 824                 } else {
 825                     $r->{os_minor_version} = "0";
 826                 }
 827             }
 828
 829             # Package management in RHEL changed in version 5
 830             if ($r->{osdistro} eq "rhel") {
 831                 if ($r->{os_major_version} >= 5) {
 832                     $r->{package_management} = "yum";
 833                 } else {
 834                     $r->{package_management} = "rhn";
 835                 }
 836             }
 837         }
 838
 839         else {
 840             $r->{osdistro} = "redhat-based";
 841         }
 842     } elsif ($g->is_file ("/etc/debian_version")) {
 843         $r->{package_format} = "dpkg";
 844         $r->{package_management} = "apt";
 845
 846         $_ = $g->cat ("/etc/debian_version");
 847         if (/(\d+)\.(\d+)/) {
 848             $r->{osdistro} = "debian";
 849             $r->{os_major_version} = "$1";
 850             $r->{os_minor_version} = "$2";
 851         } else {
 852             $r->{osdistro} = "debian";
 853         }
 854     }
 855
 856     # Parse the contents of /etc/fstab.  This is pretty vital so
 857     # we can determine where filesystems are supposed to be mounted.
 858     eval "\$_ = \$g->cat ('/etc/fstab');";
 859     if (!$@ && $_) {
 860         my @lines = split /\n/;
 861         my @fstab;
 862         foreach (@lines) {
 863             my @fields = split /[ \t]+/;
 864             if (@fields >= 2) {
 865                 my $spec = $fields[0]; # first column (dev/label/uuid)
 866                 my $file = $fields[1]; # second column (mountpoint)
 867                 if ($spec =~ m{^/} ||
 868                     $spec =~ m{^LABEL=} ||
 869                     $spec =~ m{^UUID=} ||
 870                     $file eq "swap") {
 871                     push @fstab, [$spec, $file]
 872                 }
 873             }
 874         }
 875         $r->{fstab} = \@fstab if @fstab;
 876     }
 877
 878     # Determine the architecture of this root.
 879     my $arch;
 880     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
 881         if ($g->is_file ($_)) {
 882             $arch = file_architecture ($g, $_);
 883             last;
 884         }
 885     }
 886
 887     $r->{arch} = $arch if defined $arch;
 888 }
 889
 890 # We only support NT.  The control file /boot.ini contains a list of
 891 # Windows installations and their %systemroot%s in a simple text
 892 # format.
 893 #
 894 # XXX We could parse this better.  This won't work if /boot.ini is on
 895 # a different drive from the %systemroot%, and in other unusual cases.
 896
 897 sub _check_windows_root
 898 {
 899     local $_;
 900     my $g = shift;
 901     my $r = shift;
 902     my $use_windows_registry = shift;
 903
 904     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 905     $r->{boot_ini} = $boot_ini;
 906
 907     if (defined $r->{boot_ini}) {
 908         $_ = $g->cat ($boot_ini);
 909         my @lines = split /\n/;
 910         my $section;
 911         my $systemroot;
 912         foreach (@lines) {
 913             if (m/\[.*\]/) {
 914                 $section = $1;
 915             } elsif (m/^default=.*?\\(\w+)$/i) {
 916                 $systemroot = $1;
 917                 last;
 918             } elsif (m/\\(\w+)=/) {
 919                 $systemroot = $1;
 920                 last;
 921             }
 922         }
 923
 924         if (defined $systemroot) {
 925             $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 926             if (defined $r->{systemroot}) {
 927                 _check_windows_arch ($g, $r, $r->{systemroot});
 928                 if ($use_windows_registry) {
 929                     _check_windows_registry ($g, $r, $r->{systemroot});
 930                 }
 931             }
 932         }
 933     }
 934 }
 935
 936 # Find Windows userspace arch.
 937
 938 sub _check_windows_arch
 939 {
 940     local $_;
 941     my $g = shift;
 942     my $r = shift;
 943     my $systemroot = shift;
 944
 945     my $cmd_exe =
 946         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
 947     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
 948 }
 949
 950 sub _check_windows_registry
 951 {
 952     local $_;
 953     my $g = shift;
 954     my $r = shift;
 955     my $systemroot = shift;
 956
 957     # Download the system registry files.  Only download the
 958     # interesting ones, and we don't bother with user profiles at all.
 959
 960     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 961     if (defined $configdir) {
 962         my $softwaredir = resolve_windows_path ($g, "$configdir/software");
 963         if (defined $softwaredir) {
 964             _load_windows_registry ($g, $r, $softwaredir,
 965                                     "HKEY_LOCAL_MACHINE\\SOFTWARE");
 966         }
 967         my $systemdir = resolve_windows_path ($g, "$configdir/system");
 968         if (defined $systemdir) {
 969             _load_windows_registry ($g, $r, $systemdir,
 970                                     "HKEY_LOCAL_MACHINE\\System");
 971         }
 972     }
 973 }
 974
 975 sub _load_windows_registry
 976 {
 977     local $_;
 978     my $g = shift;
 979     my $r = shift;
 980     my $regfile = shift;
 981     my $prefix = shift;
 982
 983     my $dir = tempdir (CLEANUP => 1);
 984
 985     $g->download ($regfile, "$dir/reg");
 986
 987     # 'reged' command is particularly noisy.  Redirect stdout and
 988     # stderr to /dev/null temporarily.
 989     open SAVEOUT, ">&STDOUT";
 990     open SAVEERR, ">&STDERR";
 991     open STDOUT, ">/dev/null";
 992     open STDERR, ">/dev/null";
 993
 994     my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
 995     my $res = system (@cmd);
 996
 997     close STDOUT;
 998     close STDERR;
 999     open STDOUT, ">&SAVEOUT";
1000     open STDERR, ">&SAVEERR";
1001     close SAVEOUT;
1002     close SAVEERR;
1003
1004     unless ($res == 0) {
1005         warn __x("reged command failed: {errormsg}", errormsg => $?);
1006         return;
1007     }
1008
1009     # Some versions of reged segfault on inputs.  If that happens we
1010     # may get no / partial output file.  Anyway, if it exists, load
1011     # it.
1012     my $content;
1013     unless (open F, "$dir/out") {
1014         warn __x("no output from reged command: {errormsg}", errormsg => $!);
1015         return;
1016     }
1017     { local $/ = undef; $content = <F>; }
1018     close F;
1019
1020     my @registry = ();
1021     @registry = @{$r->{registry}} if exists $r->{registry};
1022     push @registry, $content;
1023     $r->{registry} = \@registry;
1024 }
1025
1026 sub _check_grub
1027 {
1028     local $_;
1029     my $g = shift;
1030     my $r = shift;
1031
1032     # Grub version, if we care.
1033 }
1034
1035 =head2 inspect_operating_systems
1036
1037  \%oses = inspect_operating_systems ($g, \%fses);
1038
1039 This function works out how partitions are related to each other.  In
1040 the case of a single-boot VM, we work out how the partitions are
1041 mounted in respect of each other (eg. C</dev/sda1> is mounted as
1042 C</boot>).  In the case of a multi-boot VM where there are several
1043 roots, we may identify several operating system roots, and mountpoints
1044 can even be shared.
1045
1046 This function returns a hashref C<\%oses> which at the top level looks
1047 like:
1048
1049  %oses = {
1050    '/dev/VG/Root' => \%os,
1051  }
1052
1053 (There can be multiple roots for a multi-boot VM).
1054
1055 The C<\%os> hash contains the following keys (any can be omitted):
1056
1057 =over 4
1058
1059 =item os
1060
1061 Operating system type, eg. "linux", "windows".
1062
1063 =item arch
1064
1065 Operating system userspace architecture, eg. "i386", "x86_64".
1066
1067 =item distro
1068
1069 Operating system distribution, eg. "debian".
1070
1071 =item major_version
1072
1073 Operating system major version, eg. "4".
1074
1075 =item minor_version
1076
1077 Operating system minor version, eg "3".
1078
1079 =item root
1080
1081 The value is a reference to the root partition C<%fs> hash.
1082
1083 =item root_device
1084
1085 The value is the name of the root partition (as a string).
1086
1087 =item mounts
1088
1089 Mountpoints.
1090 The value is a hashref like this:
1091
1092  mounts => {
1093    '/' => '/dev/VG/Root',
1094    '/boot' => '/dev/sda1',
1095  }
1096
1097 =item filesystems
1098
1099 Filesystems (including swap devices and unmounted partitions).
1100 The value is a hashref like this:
1101
1102  filesystems => {
1103    '/dev/sda1' => \%fs,
1104    '/dev/VG/Root' => \%fs,
1105    '/dev/VG/Swap' => \%fs,
1106  }
1107
1108 =back
1109
1110 =cut
1111
1112 sub inspect_operating_systems
1113 {
1114     local $_;
1115     my $g = shift;
1116     my $fses = shift;
1117
1118     my %oses = ();
1119
1120     foreach (sort keys %$fses) {
1121         if ($fses->{$_}->{is_root}) {
1122             my %r = (
1123                 root => $fses->{$_},
1124                 root_device => $_
1125                 );
1126             _get_os_version ($g, \%r);
1127             _assign_mount_points ($g, $fses, \%r);
1128             $oses{$_} = \%r;
1129         }
1130     }
1131
1132     return \%oses;
1133 }
1134
1135 sub _get_os_version
1136 {
1137     local $_;
1138     my $g = shift;
1139     my $r = shift;
1140
1141     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1142     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1143     $r->{major_version} = $r->{root}->{os_major_version}
1144         if exists $r->{root}->{os_major_version};
1145     $r->{minor_version} = $r->{root}->{os_minor_version}
1146         if exists $r->{root}->{os_minor_version};
1147     $r->{package_format} = $r->{root}->{package_format}
1148         if exists $r->{root}->{package_format};
1149     $r->{package_management} = $r->{root}->{package_management}
1150         if exists $r->{root}->{package_management};
1151     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1152 }
1153
1154 sub _assign_mount_points
1155 {
1156     local $_;
1157     my $g = shift;
1158     my $fses = shift;
1159     my $r = shift;
1160
1161     $r->{mounts} = { "/" => $r->{root_device} };
1162     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1163
1164     # Use /etc/fstab if we have it to mount the rest.
1165     if (exists $r->{root}->{fstab}) {
1166         my @fstab = @{$r->{root}->{fstab}};
1167         foreach (@fstab) {
1168             my ($spec, $file) = @$_;
1169
1170             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1171             if ($dev) {
1172                 $r->{mounts}->{$file} = $dev;
1173                 $r->{filesystems}->{$dev} = $fs;
1174                 if (exists $fs->{used}) {
1175                     $fs->{used}++
1176                 } else {
1177                     $fs->{used} = 1
1178                 }
1179                 $fs->{spec} = $spec;
1180             }
1181         }
1182     }
1183 }
1184
1185 # Find filesystem by device name, LABEL=.. or UUID=..
1186 sub _find_filesystem
1187 {
1188     my $g = shift;
1189     my $fses = shift;
1190     local $_ = shift;
1191
1192     if (/^LABEL=(.*)/) {
1193         my $label = $1;
1194         foreach (sort keys %$fses) {
1195             if (exists $fses->{$_}->{label} &&
1196                 $fses->{$_}->{label} eq $label) {
1197                 return ($_, $fses->{$_});
1198             }
1199         }
1200         warn __x("unknown filesystem label {label}\n", label => $label);
1201         return ();
1202     } elsif (/^UUID=(.*)/) {
1203         my $uuid = $1;
1204         foreach (sort keys %$fses) {
1205             if (exists $fses->{$_}->{uuid} &&
1206                 $fses->{$_}->{uuid} eq $uuid) {
1207                 return ($_, $fses->{$_});
1208             }
1209         }
1210         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1211         return ();
1212     } else {
1213         return ($_, $fses->{$_}) if exists $fses->{$_};
1214
1215         # The following is to handle the case where an fstab entry specifies a
1216         # specific device rather than its label or uuid, and the libguestfs
1217         # appliance has named the device differently due to the use of a
1218         # different driver.
1219         # This will work as long as the underlying drivers recognise devices in
1220         # the same order.
1221         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1222             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1223         }
1224         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1225             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1226         }
1227         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1228             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1229         }
1230
1231         return () if m{/dev/cdrom};
1232
1233         warn __x("unknown filesystem {fs}\n", fs => $_);
1234         return ();
1235     }
1236 }
1237
1238 =head2 mount_operating_system
1239
1240  mount_operating_system ($g, \%os, [$ro]);
1241
1242 This function mounts the operating system described in the
1243 C<%os> hash according to the C<mounts> table in that hash (see
1244 C<inspect_operating_systems>).
1245
1246 The partitions are mounted read-only unless the third parameter
1247 is specified as zero explicitly.
1248
1249 To reverse the effect of this call, use the standard
1250 libguestfs API call C<$g-E<gt>umount_all ()>.
1251
1252 =cut
1253
1254 sub mount_operating_system
1255 {
1256     local $_;
1257     my $g = shift;
1258     my $os = shift;
1259     my $ro = shift;             # Read-only?
1260
1261     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1262
1263     my $mounts = $os->{mounts};
1264
1265     # Have to mount / first.  Luckily '/' is early in the ASCII
1266     # character set, so this should be OK.
1267     foreach (sort keys %$mounts) {
1268         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1269             if($ro) {
1270                 $g->mount_ro ($mounts->{$_}, $_)
1271             } else {
1272                 $g->mount ($mounts->{$_}, $_)
1273             }
1274         }
1275     }
1276 }
1277
1278 =head2 inspect_in_detail
1279
1280  mount_operating_system ($g, \%os);
1281  inspect_in_detail ($g, \%os);
1282  $g->umount_all ();
1283
1284 The C<inspect_in_detail> function inspects the mounted operating
1285 system for installed applications, installed kernels, kernel modules,
1286 system architecture, and more.
1287
1288 It adds extra keys to the existing C<%os> hash reflecting what it
1289 finds.  These extra keys are:
1290
1291 =over 4
1292
1293 =item apps
1294
1295 List of applications.
1296
1297 =item kernels
1298
1299 List of kernels.
1300
1301 This is a hash of kernel version =E<gt> a hash with the following keys:
1302
1303 =over 4
1304
1305 =item version
1306
1307 Kernel version.
1308
1309 =item arch
1310
1311 Kernel architecture (eg. C<x86-64>).
1312
1313 =item modules
1314
1315 List of modules.
1316
1317 =back
1318
1319 =item modprobe_aliases
1320
1321 (For Linux VMs).
1322 The contents of the modprobe configuration.
1323
1324 =item initrd_modules
1325
1326 (For Linux VMs).
1327 The kernel modules installed in the initrd.  The value is
1328 a hashref of kernel version to list of modules.
1329
1330 =back
1331
1332 =cut
1333
1334 sub inspect_in_detail
1335 {
1336     local $_;
1337     my $g = shift;
1338     my $os = shift;
1339
1340     _check_for_applications ($g, $os);
1341     _check_for_kernels ($g, $os);
1342     if ($os->{os} eq "linux") {
1343         _check_for_modprobe_aliases ($g, $os);
1344         _check_for_initrd ($g, $os);
1345     }
1346 }
1347
1348 sub _check_for_applications
1349 {
1350     local $_;
1351     my $g = shift;
1352     my $os = shift;
1353
1354     my @apps;
1355
1356     my $osn = $os->{os};
1357     if ($osn eq "linux") {
1358         my $package_format = $os->{package_format};
1359         if (defined $package_format && $package_format eq "rpm") {
1360             my @lines = $g->command_lines
1361                 (["rpm",
1362                   "-q", "-a",
1363                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1364             foreach (@lines) {
1365                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1366                     my $epoch = $2;
1367                     $epoch = "" if $epoch eq "(none)";
1368                     my $app = {
1369                         name => $1,
1370                         epoch => $epoch,
1371                         version => $3,
1372                         release => $4,
1373                         arch => $5
1374                     };
1375                     push @apps, $app
1376                 }
1377             }
1378         }
1379     } elsif ($osn eq "windows") {
1380         # XXX
1381         # I worked out a general plan for this, but haven't
1382         # implemented it yet.  We can iterate over /Program Files
1383         # looking for *.EXE files, which we download, then use
1384         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1385         # section, which has a lot of useful information.
1386     }
1387
1388     $os->{apps} = \@apps;
1389 }
1390
1391 sub _check_for_kernels
1392 {
1393     local $_;
1394     my $g = shift;
1395     my $os = shift;
1396
1397     my @kernels;
1398
1399     my $osn = $os->{os};
1400     if ($osn eq "linux") {
1401         # Installed kernels will have a corresponding /lib/modules/<version>
1402         # directory, which is the easiest way to find out what kernels
1403         # are installed, and what modules are available.
1404         foreach ($g->ls ("/lib/modules")) {
1405             if ($g->is_dir ("/lib/modules/$_")) {
1406                 my %kernel;
1407                 $kernel{version} = $_;
1408
1409                 # List modules.
1410                 my @modules;
1411                 my $any_module;
1412                 my $prefix = "/lib/modules/$_";
1413                 foreach ($g->find ($prefix)) {
1414                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
1415                         $any_module = "$prefix$_" unless defined $any_module;
1416                         push @modules, $1;
1417                     }
1418                 }
1419
1420                 $kernel{modules} = \@modules;
1421
1422                 # Determine kernel architecture by looking at the arch
1423                 # of any kernel module.
1424                 $kernel{arch} = file_architecture ($g, $any_module);
1425
1426                 push @kernels, \%kernel;
1427             }
1428         }
1429
1430     } elsif ($osn eq "windows") {
1431         # XXX
1432     }
1433
1434     $os->{kernels} = \@kernels;
1435 }
1436
1437 # Check /etc/modprobe.conf to see if there are any specified
1438 # drivers associated with network (ethX) or hard drives.  Normally
1439 # one might find something like:
1440 #
1441 #  alias eth0 xennet
1442 #  alias scsi_hostadapter xenblk
1443 #
1444 # XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
1445
1446 sub _check_for_modprobe_aliases
1447 {
1448     local $_;
1449     my $g = shift;
1450     my $os = shift;
1451
1452     # Initialise augeas
1453     my $success = 0;
1454     $success = $g->aug_init("/", 16);
1455
1456     # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens
1457     my @results;
1458     @results = $g->aug_match("/augeas/load/Modprobe/incl");
1459
1460     # Calculate the next index of /augeas/load/Modprobe/incl
1461     my $i = 1;
1462     foreach ( @results ) {
1463         next unless m{/augeas/load/Modprobe/incl\[(\d*)]};
1464         $i = $1 + 1 if ($1 == $i);
1465     }
1466
1467     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1468                            "/etc/modules.conf");
1469     $i++;
1470     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1471                                   "/etc/conf.modules");
1472
1473     # Make augeas reload
1474     $success = $g->aug_load();
1475
1476     my %modprobe_aliases;
1477
1478     for my $pattern qw(/files/etc/conf.modules/alias
1479                        /files/etc/modules.conf/alias
1480                        /files/etc/modprobe.conf/alias
1481                        /files/etc/modprobe.d/*/alias) {
1482         @results = $g->aug_match($pattern);
1483
1484         for my $path ( @results ) {
1485             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1486                 or die __x("{path} doesn't match augeas pattern",
1487                            path => $path);
1488             my $file = $1;
1489
1490             my $alias;
1491             $alias = $g->aug_get($path);
1492
1493             my $modulename;
1494             $modulename = $g->aug_get($path.'/modulename');
1495
1496             my %aliasinfo;
1497             $aliasinfo{modulename} = $modulename;
1498             $aliasinfo{augeas} = $path;
1499             $aliasinfo{file} = $file;
1500
1501             $modprobe_aliases{$alias} = \%aliasinfo;
1502         }
1503     }
1504
1505     $os->{modprobe_aliases} = \%modprobe_aliases;
1506 }
1507
1508 # Get a listing of device drivers in any initrd corresponding to a
1509 # kernel.  This is an indication of what can possibly be booted.
1510
1511 sub _check_for_initrd
1512 {
1513     local $_;
1514     my $g = shift;
1515     my $os = shift;
1516
1517     my %initrd_modules;
1518
1519     foreach my $initrd ($g->ls ("/boot")) {
1520         if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
1521             my $version = $1;
1522             my @modules;
1523
1524             # Disregard old-style compressed ext2 files and only
1525             # work with real compressed cpio files, since cpio
1526             # takes ages to (fail to) process anything else.
1527             if ($g->file ("/boot/$initrd") =~ /cpio/) {
1528                 eval {
1529                     @modules = $g->initrd_list ("/boot/$initrd");
1530                 };
1531                 unless ($@) {
1532                     @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, }
1533                     @modules;
1534                     $initrd_modules{$version} = \@modules
1535                 } else {
1536                     warn __x("{filename}: could not read initrd format",
1537                              filename => "/boot/$initrd");
1538                 }
1539             }
1540         }
1541     }
1542
1543     $os->{initrd_modules} = \%initrd_modules;
1544 }
1545
1546
1547 1;
1548
1549 =head1 COPYRIGHT
1550
1551 Copyright (C) 2009 Red Hat Inc.
1552
1553 =head1 LICENSE
1554
1555 Please see the file COPYING.LIB for the full license.
1556
1557 =head1 SEE ALSO
1558
1559 L<virt-inspector(1)>,
1560 L<Sys::Guestfs(3)>,
1561 L<guestfs(3)>,
1562 L<http://libguestfs.org/>,
1563 L<Sys::Virt(3)>,
1564 L<http://libvirt.org/>,
1565 L<guestfish(1)>.
1566
1567 =cut