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