perl/lib/Sys/Guestfs/Lib.pm

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