perl/lib/Sys/Guestfs/Lib.pm

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