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