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