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