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