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