perl/lib/Sys/Guestfs/Lib.pm

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