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