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.2';
  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, but this function
1123 will throw an error if no roots (ie. OSes) could be found.
1124
1125 The C<\%os> hash contains the following keys (any can be omitted):
1126
1127 =over 4
1128
1129 =item os
1130
1131 Operating system type, eg. "linux", "windows".
1132
1133 =item arch
1134
1135 Operating system userspace architecture, eg. "i386", "x86_64".
1136
1137 =item distro
1138
1139 Operating system distribution, eg. "debian".
1140
1141 =item product_name
1142
1143 Free text product name.
1144
1145 =item major_version
1146
1147 Operating system major version, eg. "4".
1148
1149 =item minor_version
1150
1151 Operating system minor version, eg "3".
1152
1153 =item root
1154
1155 The value is a reference to the root partition C<%fs> hash.
1156
1157 =item root_device
1158
1159 The value is the name of the root partition (as a string).
1160
1161 =item mounts
1162
1163 Mountpoints.
1164 The value is a hashref like this:
1165
1166  mounts => {
1167    '/' => '/dev/VG/Root',
1168    '/boot' => '/dev/sda1',
1169  }
1170
1171 =item filesystems
1172
1173 Filesystems (including swap devices and unmounted partitions).
1174 The value is a hashref like this:
1175
1176  filesystems => {
1177    '/dev/sda1' => \%fs,
1178    '/dev/VG/Root' => \%fs,
1179    '/dev/VG/Swap' => \%fs,
1180  }
1181
1182 =back
1183
1184 =cut
1185
1186 sub inspect_operating_systems
1187 {
1188     local $_;
1189     my $g = shift;
1190     my $fses = shift;
1191
1192     my %oses = ();
1193
1194     foreach (sort keys %$fses) {
1195         if ($fses->{$_}->{is_root}) {
1196             my %r = (
1197                 root => $fses->{$_},
1198                 root_device => $_
1199                 );
1200             _get_os_version ($g, \%r);
1201             _assign_mount_points ($g, $fses, \%r);
1202             $oses{$_} = \%r;
1203         }
1204     }
1205
1206     # If we didn't find any operating systems then it's an error (RHBZ#591142).
1207     if (0 == keys %oses) {
1208         die __"No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by virt-inspector.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n";
1209     }
1210
1211     return \%oses;
1212 }
1213
1214 sub _get_os_version
1215 {
1216     local $_;
1217     my $g = shift;
1218     my $r = shift;
1219
1220     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1221     $r->{product_name} = $r->{root}->{product_name}
1222         if exists $r->{root}->{product_name};
1223     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1224     $r->{major_version} = $r->{root}->{os_major_version}
1225         if exists $r->{root}->{os_major_version};
1226     $r->{minor_version} = $r->{root}->{os_minor_version}
1227         if exists $r->{root}->{os_minor_version};
1228     $r->{package_format} = $r->{root}->{package_format}
1229         if exists $r->{root}->{package_format};
1230     $r->{package_management} = $r->{root}->{package_management}
1231         if exists $r->{root}->{package_management};
1232     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1233 }
1234
1235 sub _assign_mount_points
1236 {
1237     local $_;
1238     my $g = shift;
1239     my $fses = shift;
1240     my $r = shift;
1241
1242     $r->{mounts} = { "/" => $r->{root_device} };
1243     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1244
1245     # Use /etc/fstab if we have it to mount the rest.
1246     if (exists $r->{root}->{fstab}) {
1247         my @fstab = @{$r->{root}->{fstab}};
1248         foreach (@fstab) {
1249             my ($spec, $file) = @$_;
1250
1251             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1252             if ($dev) {
1253                 $r->{mounts}->{$file} = $dev;
1254                 $r->{filesystems}->{$dev} = $fs;
1255                 if (exists $fs->{used}) {
1256                     $fs->{used}++
1257                 } else {
1258                     $fs->{used} = 1
1259                 }
1260                 $fs->{spec} = $spec;
1261             }
1262         }
1263     }
1264 }
1265
1266 # Find filesystem by device name, LABEL=.. or UUID=..
1267 sub _find_filesystem
1268 {
1269     my $g = shift;
1270     my $fses = shift;
1271     local $_ = shift;
1272
1273     if (/^LABEL=(.*)/) {
1274         my $label = $1;
1275         foreach (sort keys %$fses) {
1276             if (exists $fses->{$_}->{label} &&
1277                 $fses->{$_}->{label} eq $label) {
1278                 return ($_, $fses->{$_});
1279             }
1280         }
1281         warn __x("unknown filesystem label {label}\n", label => $label);
1282         return ();
1283     } elsif (/^UUID=(.*)/) {
1284         my $uuid = $1;
1285         foreach (sort keys %$fses) {
1286             if (exists $fses->{$_}->{uuid} &&
1287                 $fses->{$_}->{uuid} eq $uuid) {
1288                 return ($_, $fses->{$_});
1289             }
1290         }
1291         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1292         return ();
1293     } else {
1294         return ($_, $fses->{$_}) if exists $fses->{$_};
1295
1296         # The following is to handle the case where an fstab entry specifies a
1297         # specific device rather than its label or uuid, and the libguestfs
1298         # appliance has named the device differently due to the use of a
1299         # different driver.
1300         # This will work as long as the underlying drivers recognise devices in
1301         # the same order.
1302         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1303             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1304         }
1305         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1306             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1307         }
1308         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1309             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1310         }
1311
1312         return () if m{/dev/cdrom};
1313
1314         warn __x("unknown filesystem {fs}\n", fs => $_);
1315         return ();
1316     }
1317 }
1318
1319 =head2 mount_operating_system
1320
1321  mount_operating_system ($g, \%os, [$ro]);
1322
1323 This function mounts the operating system described in the
1324 C<%os> hash according to the C<mounts> table in that hash (see
1325 C<inspect_operating_systems>).
1326
1327 The partitions are mounted read-only unless the third parameter
1328 is specified as zero explicitly.
1329
1330 To reverse the effect of this call, use the standard
1331 libguestfs API call C<$g-E<gt>umount_all ()>.
1332
1333 =cut
1334
1335 sub mount_operating_system
1336 {
1337     local $_;
1338     my $g = shift;
1339     my $os = shift;
1340     my $ro = shift;             # Read-only?
1341
1342     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1343
1344     my $mounts = $os->{mounts};
1345
1346     # Have to mount / first.  Luckily '/' is early in the ASCII
1347     # character set, so this should be OK.
1348     foreach (sort keys %$mounts) {
1349         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1350             if($ro) {
1351                 $g->mount_ro ($mounts->{$_}, $_)
1352             } else {
1353                 $g->mount_options ("", $mounts->{$_}, $_)
1354             }
1355         }
1356     }
1357 }
1358
1359 =head2 inspect_in_detail
1360
1361  mount_operating_system ($g, \%os);
1362  inspect_in_detail ($g, \%os);
1363  $g->umount_all ();
1364
1365 The C<inspect_in_detail> function inspects the mounted operating
1366 system for installed applications, installed kernels, kernel modules,
1367 system architecture, and more.
1368
1369 It adds extra keys to the existing C<%os> hash reflecting what it
1370 finds.  These extra keys are:
1371
1372 =over 4
1373
1374 =item apps
1375
1376 List of applications.
1377
1378 =item boot
1379
1380 Boot configurations. A hash containing:
1381
1382 =over 4
1383
1384 =item configs
1385
1386 An array of boot configurations. Each array entry is a hash containing:
1387
1388 =over 4
1389
1390 =item initrd
1391
1392 A reference to the expanded initrd structure (see below) for the initrd used by
1393 this boot configuration.
1394
1395 =item kernel
1396
1397 A reference to the expanded kernel structure (see below) for the kernel used by
1398 this boot configuration.
1399
1400 =item title
1401
1402 The human readable name of the configuration.
1403
1404 =item cmdline
1405
1406 The kernel command line.
1407
1408 =back
1409
1410 =item default
1411
1412 The index of the default configuration in the configs array.
1413
1414 =item grub_fs
1415
1416 The path of the filesystem containing the grub partition.
1417
1418 =back
1419
1420 =item kernels
1421
1422 List of kernels.
1423
1424 This is a hash of kernel version =E<gt> a hash with the following keys:
1425
1426 =over 4
1427
1428 =item version
1429
1430 Kernel version.
1431
1432 =item arch
1433
1434 Kernel architecture (eg. C<x86-64>).
1435
1436 =item modules
1437
1438 List of modules.
1439
1440 =item path
1441
1442 The path to the kernel's vmlinuz file.
1443
1444 =item package
1445
1446 If the kernel was installed in a package, the name of that package.
1447
1448 =back
1449
1450 =item modprobe_aliases
1451
1452 (For Linux VMs).
1453 The contents of the modprobe configuration.
1454
1455 =item initrd_modules
1456
1457 (For Linux VMs).
1458 The kernel modules installed in the initrd.  The value is
1459 a hashref of kernel version to list of modules.
1460
1461 =back
1462
1463 =cut
1464
1465 sub inspect_in_detail
1466 {
1467     local $_;
1468     my $g = shift;
1469     my $os = shift;
1470
1471     _check_for_applications ($g, $os);
1472     _check_for_kernels ($g, $os);
1473     if ($os->{os} eq "linux") {
1474         _find_modprobe_aliases ($g, $os);
1475     }
1476 }
1477
1478 sub _check_for_applications
1479 {
1480     local $_;
1481     my $g = shift;
1482     my $os = shift;
1483
1484     my @apps;
1485
1486     my $osn = $os->{os};
1487     if ($osn eq "linux") {
1488         my $package_format = $os->{package_format};
1489         if (defined $package_format && $package_format eq "rpm") {
1490             my @lines = ();
1491             eval {
1492                 @lines = $g->command_lines
1493                     (["rpm",
1494                       "-q", "-a", "--qf",
1495                       "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1496             };
1497
1498             warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@);
1499
1500             @lines = sort @lines;
1501             foreach (@lines) {
1502                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1503                     my $epoch = $2;
1504                     undef $epoch if $epoch eq "(none)";
1505                     my $app = {
1506                         name => $1,
1507                         epoch => $epoch,
1508                         version => $3,
1509                         release => $4,
1510                         arch => $5
1511                     };
1512                     push @apps, $app
1513                 }
1514             }
1515         } elsif (defined $package_format && $package_format eq "deb") {
1516             my @lines = ();
1517             eval {
1518                 @lines = $g->command_lines
1519                     (["dpkg-query",
1520                       "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1521                       "-W"]);
1522             };
1523
1524             warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@);
1525
1526             @lines = sort @lines;
1527             foreach (@lines) {
1528                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1529                     if ( $6 eq "installed" ) {
1530                         my $app = {
1531                             name => $1,
1532                             version => $2,
1533                             arch => $3
1534                         };
1535                         push @apps, $app
1536                     }
1537                 }
1538             }
1539         }
1540     } elsif ($osn eq "windows") {
1541         # XXX
1542         # I worked out a general plan for this, but haven't
1543         # implemented it yet.  We can iterate over /Program Files
1544         # looking for *.EXE files, which we download, then use
1545         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1546         # section, which has a lot of useful information.
1547     }
1548
1549     $os->{apps} = \@apps;
1550 }
1551
1552 # Find the path which needs to be prepended to paths in grub.conf to make them
1553 # absolute
1554 sub _find_grub_prefix
1555 {
1556     my ($g, $os) = @_;
1557
1558     my $fses = $os->{filesystems};
1559     die("filesystems undefined") unless(defined($fses));
1560
1561     # Look for the filesystem which contains grub
1562     my $grubdev;
1563     foreach my $dev (keys(%$fses)) {
1564         my $fsinfo = $fses->{$dev};
1565         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1566             $grubdev = $dev;
1567             last;
1568         }
1569     }
1570
1571     my $mounts = $os->{mounts};
1572     die("mounts undefined") unless(defined($mounts));
1573
1574     # Find where the filesystem is mounted
1575     if(defined($grubdev)) {
1576         foreach my $mount (keys(%$mounts)) {
1577             if($mounts->{$mount} eq $grubdev) {
1578                 return "" if($mount eq '/');
1579                 return $mount;
1580             }
1581         }
1582
1583         die("$grubdev defined in filesystems, but not in mounts");
1584     }
1585
1586     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1587     # what filesystem it's on. We use menu.lst rather than grub.conf because
1588     # debian only uses menu.lst, and anaconda creates a symlink for it.
1589     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1590
1591     # Look for the most specific mount point in mounts
1592     foreach my $path qw(/boot/grub /boot /) {
1593         if(exists($mounts->{$path})) {
1594             return "" if($path eq '/');
1595             return $path;
1596         }
1597     }
1598
1599     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1600 }
1601
1602 sub _check_for_kernels
1603 {
1604     my ($g, $os) = @_;
1605
1606     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1607         # Iterate over entries in grub.conf, populating $os->{boot}
1608         # For every kernel we find, inspect it and add to $os->{kernels}
1609
1610         my $grub = _find_grub_prefix($g, $os);
1611         my $grub_conf = "/etc/grub.conf";
1612
1613         # Debian and other's have no /etc/grub.conf:
1614         if ( ! -f "$grub_conf" ) {
1615             $grub_conf = "$grub/grub/menu.lst";
1616         }
1617
1618         my @boot_configs;
1619
1620         # We want
1621         #  $os->{boot}
1622         #       ->{configs}
1623         #         ->[0]
1624         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1625         #           ->{kernel}  = \kernel
1626         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1627         #           ->{initrd}  = \initrd
1628         #       ->{default} = \config
1629         #       ->{grub_fs} = "/boot"
1630         # Initialise augeas
1631         $g->aug_init("/", 16);
1632
1633         my @configs = ();
1634         # Get all configurations from grub
1635         foreach my $bootable
1636             ($g->aug_match("/files/$grub_conf/title"))
1637         {
1638             my %config = ();
1639             $config{title} = $g->aug_get($bootable);
1640
1641             my $grub_kernel;
1642             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1643             if($@) {
1644                 warn __x("Grub entry {title} has no kernel",
1645                          title => $config{title});
1646             }
1647
1648             # Check we've got a kernel entry
1649             if(defined($grub_kernel)) {
1650                 my $path = "$grub$grub_kernel";
1651
1652                 # Reconstruct the kernel command line
1653                 my @args = ();
1654                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1655                     $arg =~ m{/kernel/([^/]*)$}
1656                         or die("Unexpected return from aug_match: $arg");
1657
1658                     my $name = $1;
1659                     my $value;
1660                     eval { $value = $g->aug_get($arg); };
1661
1662                     if(defined($value)) {
1663                         push(@args, "$name=$value");
1664                     } else {
1665                         push(@args, $name);
1666                     }
1667                 }
1668                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1669
1670                 my $kernel;
1671                 if ($g->exists($path)) {
1672                     $kernel =
1673                         inspect_linux_kernel($g, $path, $os->{package_format});
1674                 } else {
1675                     warn __x("grub refers to {path}, which doesn't exist\n",
1676                              path => $path);
1677                 }
1678
1679                 # Check the kernel was recognised
1680                 if(defined($kernel)) {
1681                     # Put this kernel on the top level kernel list
1682                     $os->{kernels} ||= [];
1683                     push(@{$os->{kernels}}, $kernel);
1684
1685                     $config{kernel} = $kernel;
1686
1687                     # Look for an initrd entry
1688                     my $initrd;
1689                     eval {
1690                         $initrd = $g->aug_get("$bootable/initrd");
1691                     };
1692
1693                     unless($@) {
1694                         $config{initrd} =
1695                             _inspect_initrd($g, $os, "$grub$initrd",
1696                                             $kernel->{version});
1697                     } else {
1698                         warn __x("Grub entry {title} does not specify an ".
1699                                  "initrd", title => $config{title});
1700                     }
1701                 }
1702             }
1703
1704             push(@configs, \%config);
1705         }
1706
1707
1708         # Create the top level boot entry
1709         my %boot;
1710         $boot{configs} = \@configs;
1711         $boot{grub_fs} = $grub;
1712
1713         # Add the default configuration
1714         eval {
1715             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1716         };
1717
1718         $os->{boot} = \%boot;
1719     }
1720
1721     elsif ($os->{os} eq "windows") {
1722         # XXX
1723     }
1724 }
1725
1726 =head2 inspect_linux_kernel
1727
1728  my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
1729
1730 inspect_linux_kernel returns a hash describing the target linux kernel. For the
1731 contents of the hash, see the I<kernels> structure described under
1732 L</inspect_in_detail>.
1733
1734 =cut
1735
1736 sub inspect_linux_kernel
1737 {
1738     my ($g, $path, $package_format) = @_;
1739
1740     my %kernel = ();
1741
1742     $kernel{path} = $path;
1743
1744     # If this is a packaged kernel, try to work out the name of the package
1745     # which installed it. This lets us know what to install to replace it with,
1746     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1747     if($package_format eq "rpm") {
1748         my $package;
1749         eval { $package = $g->command(['rpm', '-qf', '--qf',
1750                                        '%{NAME}', $path]); };
1751         $kernel{package} = $package if defined($package);;
1752     }
1753
1754     # Try to get the kernel version by running file against it
1755     my $version;
1756     my $filedesc = $g->file($path);
1757     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1758         $version = $1;
1759     }
1760
1761     # Sometimes file can't work out the kernel version, for example because it's
1762     # a Xen PV kernel. In this case try to guess the version from the filename
1763     else {
1764         if($path =~ m{/boot/vmlinuz-(.*)}) {
1765             $version = $1;
1766
1767             # Check /lib/modules/$version exists
1768             if(!$g->is_dir("/lib/modules/$version")) {
1769                 warn __x("Didn't find modules directory {modules} for kernel ".
1770                          "{path}", modules => "/lib/modules/$version",
1771                          path => $path);
1772
1773                 # Give up
1774                 return undef;
1775             }
1776         } else {
1777             warn __x("Couldn't guess kernel version number from path for ".
1778                      "kernel {path}", path => $path);
1779
1780             # Give up
1781             return undef;
1782         }
1783     }
1784
1785     $kernel{version} = $version;
1786
1787     # List modules.
1788     my @modules;
1789     my $any_module;
1790     my $prefix = "/lib/modules/$version";
1791     foreach my $module ($g->find ($prefix)) {
1792         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1793             $any_module = "$prefix$module" unless defined $any_module;
1794             push @modules, $1;
1795         }
1796     }
1797
1798     $kernel{modules} = \@modules;
1799
1800     # Determine kernel architecture by looking at the arch
1801     # of any kernel module.
1802     $kernel{arch} = file_architecture ($g, $any_module);
1803
1804     return \%kernel;
1805 }
1806
1807 # Find all modprobe aliases. Specifically, this looks in the following
1808 # locations:
1809 #  * /etc/conf.modules
1810 #  * /etc/modules.conf
1811 #  * /etc/modprobe.conf
1812 #  * /etc/modprobe.d/*
1813
1814 sub _find_modprobe_aliases
1815 {
1816     local $_;
1817     my $g = shift;
1818     my $os = shift;
1819
1820     # Initialise augeas
1821     $g->aug_init("/", 16);
1822
1823     # Register additional paths to the Modprobe lens
1824     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/modules.conf");
1825     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/conf.modules");
1826
1827     # Make augeas reload
1828     $g->aug_load();
1829
1830     my %modprobe_aliases;
1831
1832     for my $pattern qw(/files/etc/conf.modules/alias
1833                        /files/etc/modules.conf/alias
1834                        /files/etc/modprobe.conf/alias
1835                        /files/etc/modprobe.d/*/alias) {
1836         for my $path ( $g->aug_match($pattern) ) {
1837             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1838                 or die __x("{path} doesn't match augeas pattern",
1839                            path => $path);
1840             my $file = $1;
1841
1842             my $alias;
1843             $alias = $g->aug_get($path);
1844
1845             my $modulename;
1846             $modulename = $g->aug_get($path.'/modulename');
1847
1848             my %aliasinfo;
1849             $aliasinfo{modulename} = $modulename;
1850             $aliasinfo{augeas} = $path;
1851             $aliasinfo{file} = $file;
1852
1853             $modprobe_aliases{$alias} = \%aliasinfo;
1854         }
1855     }
1856
1857     $os->{modprobe_aliases} = \%modprobe_aliases;
1858 }
1859
1860 # Get a listing of device drivers from an initrd
1861 sub _inspect_initrd
1862 {
1863     my ($g, $os, $path, $version) = @_;
1864
1865     my @modules;
1866
1867     # Disregard old-style compressed ext2 files and only work with real
1868     # compressed cpio files, since cpio takes ages to (fail to) process anything
1869     # else.
1870     if ($g->exists($path) && $g->file($path) =~ /cpio/) {
1871         eval {
1872             @modules = $g->initrd_list ($path);
1873         };
1874         unless ($@) {
1875             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1876         } else {
1877             warn __x("{filename}: could not read initrd format",
1878                      filename => "$path");
1879         }
1880     }
1881
1882     # Add to the top level initrd_modules entry
1883     $os->{initrd_modules} ||= {};
1884     $os->{initrd_modules}->{$version} = \@modules;
1885
1886     return \@modules;
1887 }
1888
1889 1;
1890
1891 =head1 COPYRIGHT
1892
1893 Copyright (C) 2009 Red Hat Inc.
1894
1895 =head1 LICENSE
1896
1897 Please see the file COPYING.LIB for the full license.
1898
1899 =head1 SEE ALSO
1900
1901 L<virt-inspector(1)>,
1902 L<Sys::Guestfs(3)>,
1903 L<guestfs(3)>,
1904 L<http://libguestfs.org/>,
1905 L<Sys::Virt(3)>,
1906 L<http://libvirt.org/>,
1907 L<guestfish(1)>.
1908
1909 =cut