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