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", "deb".
 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             chomp; $r->{product_name} = $_;
 818             $r->{osdistro} = "fedora";
 819             $r->{os_major_version} = "$1";
 820             $r->{os_minor_version} = "$2" if(defined($2));
 821             $r->{package_management} = "yum";
 822         }
 823
 824         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
 825             chomp; $r->{product_name} = $_;
 826
 827             my $distro = $1;
 828
 829             if($distro eq "Red Hat Enterprise Linux") {
 830                 $r->{osdistro} = "rhel";
 831             }
 832
 833             elsif($distro eq "CentOS") {
 834                 $r->{osdistro} = "centos";
 835                 $r->{package_management} = "yum";
 836             }
 837
 838             elsif($distro eq "Scientific Linux") {
 839                 $r->{osdistro} = "scientific";
 840                 $r->{package_management} = "yum";
 841             }
 842
 843             # Shouldn't be possible
 844             else { die };
 845
 846             if (/$distro.*release (\d+).*Update (\d+)/) {
 847                 $r->{os_major_version} = "$1";
 848                 $r->{os_minor_version} = "$2";
 849             }
 850
 851             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
 852                 $r->{os_major_version} = "$1";
 853
 854                 if(defined($2)) {
 855                     $r->{os_minor_version} = "$2";
 856                 } else {
 857                     $r->{os_minor_version} = "0";
 858                 }
 859             }
 860
 861             # Package management in RHEL changed in version 5
 862             if ($r->{osdistro} eq "rhel") {
 863                 if ($r->{os_major_version} >= 5) {
 864                     $r->{package_management} = "yum";
 865                 } else {
 866                     $r->{package_management} = "rhn";
 867                 }
 868             }
 869         }
 870
 871         else {
 872             $r->{osdistro} = "redhat-based";
 873         }
 874     } elsif ($g->is_file ("/etc/debian_version")) {
 875         $r->{package_format} = "deb";
 876         $r->{package_management} = "apt";
 877
 878         $_ = $g->cat ("/etc/debian_version");
 879         if (/(\d+)\.(\d+)/) {
 880             chomp; $r->{product_name} = $_;
 881             $r->{osdistro} = "debian";
 882             $r->{os_major_version} = "$1";
 883             $r->{os_minor_version} = "$2";
 884         } else {
 885             $r->{osdistro} = "debian";
 886         }
 887     }
 888
 889     # Parse the contents of /etc/fstab.  This is pretty vital so
 890     # we can determine where filesystems are supposed to be mounted.
 891     eval "\$_ = \$g->cat ('/etc/fstab');";
 892     if (!$@ && $_) {
 893         my @lines = split /\n/;
 894         my @fstab;
 895         foreach (@lines) {
 896             my @fields = split /[ \t]+/;
 897             if (@fields >= 2) {
 898                 my $spec = $fields[0]; # first column (dev/label/uuid)
 899                 my $file = $fields[1]; # second column (mountpoint)
 900                 if ($spec =~ m{^/} ||
 901                     $spec =~ m{^LABEL=} ||
 902                     $spec =~ m{^UUID=} ||
 903                     $file eq "swap") {
 904                     push @fstab, [$spec, $file]
 905                 }
 906             }
 907         }
 908         $r->{fstab} = \@fstab if @fstab;
 909     }
 910
 911     # Determine the architecture of this root.
 912     my $arch;
 913     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
 914         if ($g->is_file ($_)) {
 915             $arch = file_architecture ($g, $_);
 916             last;
 917         }
 918     }
 919
 920     $r->{arch} = $arch if defined $arch;
 921 }
 922
 923 # We only support NT.  The control file /boot.ini contains a list of
 924 # Windows installations and their %systemroot%s in a simple text
 925 # format.
 926 #
 927 # XXX We could parse this better.  This won't work if /boot.ini is on
 928 # a different drive from the %systemroot%, and in other unusual cases.
 929
 930 sub _check_windows_root
 931 {
 932     local $_;
 933     my $g = shift;
 934     my $r = shift;
 935     my $use_windows_registry = shift;
 936
 937     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 938     $r->{boot_ini} = $boot_ini;
 939
 940     if (defined $r->{boot_ini}) {
 941         $_ = $g->cat ($boot_ini);
 942         my @lines = split /\n/;
 943         my $section;
 944         my $systemroot;
 945         foreach (@lines) {
 946             if (m/\[.*\]/) {
 947                 $section = $1;
 948             } elsif (m/^default=.*?\\(\w+)$/i) {
 949                 $systemroot = $1;
 950                 last;
 951             } elsif (m/\\(\w+)=/) {
 952                 $systemroot = $1;
 953                 last;
 954             }
 955         }
 956
 957         if (defined $systemroot) {
 958             $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 959             if (defined $r->{systemroot}) {
 960                 _check_windows_arch ($g, $r, $r->{systemroot});
 961                 if ($use_windows_registry) {
 962                     _check_windows_registry ($g, $r, $r->{systemroot});
 963                 }
 964             }
 965         }
 966     }
 967 }
 968
 969 # Find Windows userspace arch.
 970
 971 sub _check_windows_arch
 972 {
 973     local $_;
 974     my $g = shift;
 975     my $r = shift;
 976     my $systemroot = shift;
 977
 978     my $cmd_exe =
 979         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
 980     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
 981 }
 982
 983 sub _check_windows_registry
 984 {
 985     local $_;
 986     my $g = shift;
 987     my $r = shift;
 988     my $systemroot = shift;
 989
 990     # Download the system registry files.  Only download the
 991     # interesting ones, and we don't bother with user profiles at all.
 992
 993     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 994     if (defined $configdir) {
 995         my $softwaredir = resolve_windows_path ($g, "$configdir/software");
 996         if (defined $softwaredir) {
 997             _load_windows_registry ($g, $r, $softwaredir,
 998                                     "HKEY_LOCAL_MACHINE\\SOFTWARE");
 999         }
1000         my $systemdir = resolve_windows_path ($g, "$configdir/system");
1001         if (defined $systemdir) {
1002             _load_windows_registry ($g, $r, $systemdir,
1003                                     "HKEY_LOCAL_MACHINE\\System");
1004         }
1005     }
1006 }
1007
1008 sub _load_windows_registry
1009 {
1010     local $_;
1011     my $g = shift;
1012     my $r = shift;
1013     my $regfile = shift;
1014     my $prefix = shift;
1015
1016     my $dir = tempdir (CLEANUP => 1);
1017
1018     $g->download ($regfile, "$dir/reg");
1019
1020     # 'reged' command is particularly noisy.  Redirect stdout and
1021     # stderr to /dev/null temporarily.
1022     open SAVEOUT, ">&STDOUT";
1023     open SAVEERR, ">&STDERR";
1024     open STDOUT, ">/dev/null";
1025     open STDERR, ">/dev/null";
1026
1027     my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
1028     my $res = system (@cmd);
1029
1030     close STDOUT;
1031     close STDERR;
1032     open STDOUT, ">&SAVEOUT";
1033     open STDERR, ">&SAVEERR";
1034     close SAVEOUT;
1035     close SAVEERR;
1036
1037     unless ($res == 0) {
1038         warn __x("reged command failed: {errormsg}", errormsg => $?);
1039         return;
1040     }
1041
1042     # Some versions of reged segfault on inputs.  If that happens we
1043     # may get no / partial output file.  Anyway, if it exists, load
1044     # it.
1045     my $content;
1046     unless (open F, "$dir/out") {
1047         warn __x("no output from reged command: {errormsg}", errormsg => $!);
1048         return;
1049     }
1050     { local $/ = undef; $content = <F>; }
1051     close F;
1052
1053     my @registry = ();
1054     @registry = @{$r->{registry}} if exists $r->{registry};
1055     push @registry, $content;
1056     $r->{registry} = \@registry;
1057 }
1058
1059 sub _check_grub
1060 {
1061     local $_;
1062     my $g = shift;
1063     my $r = shift;
1064
1065     # Grub version, if we care.
1066 }
1067
1068 =head2 inspect_operating_systems
1069
1070  \%oses = inspect_operating_systems ($g, \%fses);
1071
1072 This function works out how partitions are related to each other.  In
1073 the case of a single-boot VM, we work out how the partitions are
1074 mounted in respect of each other (eg. C</dev/sda1> is mounted as
1075 C</boot>).  In the case of a multi-boot VM where there are several
1076 roots, we may identify several operating system roots, and mountpoints
1077 can even be shared.
1078
1079 This function returns a hashref C<\%oses> which at the top level looks
1080 like:
1081
1082  %oses = {
1083    '/dev/VG/Root' => \%os,
1084  }
1085
1086 (There can be multiple roots for a multi-boot VM).
1087
1088 The C<\%os> hash contains the following keys (any can be omitted):
1089
1090 =over 4
1091
1092 =item os
1093
1094 Operating system type, eg. "linux", "windows".
1095
1096 =item arch
1097
1098 Operating system userspace architecture, eg. "i386", "x86_64".
1099
1100 =item distro
1101
1102 Operating system distribution, eg. "debian".
1103
1104 =item product_name
1105
1106 Free text product name.
1107
1108 =item major_version
1109
1110 Operating system major version, eg. "4".
1111
1112 =item minor_version
1113
1114 Operating system minor version, eg "3".
1115
1116 =item root
1117
1118 The value is a reference to the root partition C<%fs> hash.
1119
1120 =item root_device
1121
1122 The value is the name of the root partition (as a string).
1123
1124 =item mounts
1125
1126 Mountpoints.
1127 The value is a hashref like this:
1128
1129  mounts => {
1130    '/' => '/dev/VG/Root',
1131    '/boot' => '/dev/sda1',
1132  }
1133
1134 =item filesystems
1135
1136 Filesystems (including swap devices and unmounted partitions).
1137 The value is a hashref like this:
1138
1139  filesystems => {
1140    '/dev/sda1' => \%fs,
1141    '/dev/VG/Root' => \%fs,
1142    '/dev/VG/Swap' => \%fs,
1143  }
1144
1145 =back
1146
1147 =cut
1148
1149 sub inspect_operating_systems
1150 {
1151     local $_;
1152     my $g = shift;
1153     my $fses = shift;
1154
1155     my %oses = ();
1156
1157     foreach (sort keys %$fses) {
1158         if ($fses->{$_}->{is_root}) {
1159             my %r = (
1160                 root => $fses->{$_},
1161                 root_device => $_
1162                 );
1163             _get_os_version ($g, \%r);
1164             _assign_mount_points ($g, $fses, \%r);
1165             $oses{$_} = \%r;
1166         }
1167     }
1168
1169     return \%oses;
1170 }
1171
1172 sub _get_os_version
1173 {
1174     local $_;
1175     my $g = shift;
1176     my $r = shift;
1177
1178     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1179     $r->{product_name} = $r->{root}->{product_name}
1180         if exists $r->{root}->{product_name};
1181     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1182     $r->{major_version} = $r->{root}->{os_major_version}
1183         if exists $r->{root}->{os_major_version};
1184     $r->{minor_version} = $r->{root}->{os_minor_version}
1185         if exists $r->{root}->{os_minor_version};
1186     $r->{package_format} = $r->{root}->{package_format}
1187         if exists $r->{root}->{package_format};
1188     $r->{package_management} = $r->{root}->{package_management}
1189         if exists $r->{root}->{package_management};
1190     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1191 }
1192
1193 sub _assign_mount_points
1194 {
1195     local $_;
1196     my $g = shift;
1197     my $fses = shift;
1198     my $r = shift;
1199
1200     $r->{mounts} = { "/" => $r->{root_device} };
1201     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1202
1203     # Use /etc/fstab if we have it to mount the rest.
1204     if (exists $r->{root}->{fstab}) {
1205         my @fstab = @{$r->{root}->{fstab}};
1206         foreach (@fstab) {
1207             my ($spec, $file) = @$_;
1208
1209             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1210             if ($dev) {
1211                 $r->{mounts}->{$file} = $dev;
1212                 $r->{filesystems}->{$dev} = $fs;
1213                 if (exists $fs->{used}) {
1214                     $fs->{used}++
1215                 } else {
1216                     $fs->{used} = 1
1217                 }
1218                 $fs->{spec} = $spec;
1219             }
1220         }
1221     }
1222 }
1223
1224 # Find filesystem by device name, LABEL=.. or UUID=..
1225 sub _find_filesystem
1226 {
1227     my $g = shift;
1228     my $fses = shift;
1229     local $_ = shift;
1230
1231     if (/^LABEL=(.*)/) {
1232         my $label = $1;
1233         foreach (sort keys %$fses) {
1234             if (exists $fses->{$_}->{label} &&
1235                 $fses->{$_}->{label} eq $label) {
1236                 return ($_, $fses->{$_});
1237             }
1238         }
1239         warn __x("unknown filesystem label {label}\n", label => $label);
1240         return ();
1241     } elsif (/^UUID=(.*)/) {
1242         my $uuid = $1;
1243         foreach (sort keys %$fses) {
1244             if (exists $fses->{$_}->{uuid} &&
1245                 $fses->{$_}->{uuid} eq $uuid) {
1246                 return ($_, $fses->{$_});
1247             }
1248         }
1249         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1250         return ();
1251     } else {
1252         return ($_, $fses->{$_}) if exists $fses->{$_};
1253
1254         # The following is to handle the case where an fstab entry specifies a
1255         # specific device rather than its label or uuid, and the libguestfs
1256         # appliance has named the device differently due to the use of a
1257         # different driver.
1258         # This will work as long as the underlying drivers recognise devices in
1259         # the same order.
1260         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1261             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1262         }
1263         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1264             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1265         }
1266         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1267             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1268         }
1269
1270         return () if m{/dev/cdrom};
1271
1272         warn __x("unknown filesystem {fs}\n", fs => $_);
1273         return ();
1274     }
1275 }
1276
1277 =head2 mount_operating_system
1278
1279  mount_operating_system ($g, \%os, [$ro]);
1280
1281 This function mounts the operating system described in the
1282 C<%os> hash according to the C<mounts> table in that hash (see
1283 C<inspect_operating_systems>).
1284
1285 The partitions are mounted read-only unless the third parameter
1286 is specified as zero explicitly.
1287
1288 To reverse the effect of this call, use the standard
1289 libguestfs API call C<$g-E<gt>umount_all ()>.
1290
1291 =cut
1292
1293 sub mount_operating_system
1294 {
1295     local $_;
1296     my $g = shift;
1297     my $os = shift;
1298     my $ro = shift;             # Read-only?
1299
1300     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1301
1302     my $mounts = $os->{mounts};
1303
1304     # Have to mount / first.  Luckily '/' is early in the ASCII
1305     # character set, so this should be OK.
1306     foreach (sort keys %$mounts) {
1307         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1308             if($ro) {
1309                 $g->mount_ro ($mounts->{$_}, $_)
1310             } else {
1311                 $g->mount_options ("", $mounts->{$_}, $_)
1312             }
1313         }
1314     }
1315 }
1316
1317 =head2 inspect_in_detail
1318
1319  mount_operating_system ($g, \%os);
1320  inspect_in_detail ($g, \%os);
1321  $g->umount_all ();
1322
1323 The C<inspect_in_detail> function inspects the mounted operating
1324 system for installed applications, installed kernels, kernel modules,
1325 system architecture, and more.
1326
1327 It adds extra keys to the existing C<%os> hash reflecting what it
1328 finds.  These extra keys are:
1329
1330 =over 4
1331
1332 =item apps
1333
1334 List of applications.
1335
1336 =item boot
1337
1338 Boot configurations. A hash containing:
1339
1340 =over 4
1341
1342 =item configs
1343
1344 An array of boot configurations. Each array entry is a hash containing:
1345
1346 =over 4
1347
1348 =item initrd
1349
1350 A reference to the expanded initrd structure (see below) for the initrd used by
1351 this boot configuration.
1352
1353 =item kernel
1354
1355 A reference to the expanded kernel structure (see below) for the kernel used by
1356 this boot configuration.
1357
1358 =item title
1359
1360 The human readable name of the configuration.
1361
1362 =item cmdline
1363
1364 The kernel command line.
1365
1366 =back
1367
1368 =item default
1369
1370 The index of the default configuration in the configs array.
1371
1372 =item grub_fs
1373
1374 The path of the filesystem containing the grub partition.
1375
1376 =back
1377
1378 =item kernels
1379
1380 List of kernels.
1381
1382 This is a hash of kernel version =E<gt> a hash with the following keys:
1383
1384 =over 4
1385
1386 =item version
1387
1388 Kernel version.
1389
1390 =item arch
1391
1392 Kernel architecture (eg. C<x86-64>).
1393
1394 =item modules
1395
1396 List of modules.
1397
1398 =item path
1399
1400 The path to the kernel's vmlinuz file.
1401
1402 =item package
1403
1404 If the kernel was installed in a package, the name of that package.
1405
1406 =back
1407
1408 =item modprobe_aliases
1409
1410 (For Linux VMs).
1411 The contents of the modprobe configuration.
1412
1413 =item initrd_modules
1414
1415 (For Linux VMs).
1416 The kernel modules installed in the initrd.  The value is
1417 a hashref of kernel version to list of modules.
1418
1419 =back
1420
1421 =cut
1422
1423 sub inspect_in_detail
1424 {
1425     local $_;
1426     my $g = shift;
1427     my $os = shift;
1428
1429     _check_for_applications ($g, $os);
1430     _check_for_kernels ($g, $os);
1431     if ($os->{os} eq "linux") {
1432         _find_modprobe_aliases ($g, $os);
1433     }
1434 }
1435
1436 sub _check_for_applications
1437 {
1438     local $_;
1439     my $g = shift;
1440     my $os = shift;
1441
1442     my @apps;
1443
1444     my $osn = $os->{os};
1445     if ($osn eq "linux") {
1446         my $package_format = $os->{package_format};
1447         if (defined $package_format && $package_format eq "rpm") {
1448             my @lines = $g->command_lines
1449                 (["rpm",
1450                   "-q", "-a",
1451                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1452             @lines = sort @lines;
1453             foreach (@lines) {
1454                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1455                     my $epoch = $2;
1456                     undef $epoch if $epoch eq "(none)";
1457                     my $app = {
1458                         name => $1,
1459                         epoch => $epoch,
1460                         version => $3,
1461                         release => $4,
1462                         arch => $5
1463                     };
1464                     push @apps, $app
1465                 }
1466             }
1467         } elsif (defined $package_format && $package_format eq "deb") {
1468             my @lines = $g->command_lines
1469                 (["dpkg-query",
1470                   "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1471                   "-W"]);
1472             @lines = sort @lines;
1473             foreach (@lines) {
1474                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1475                     if ( $6 eq "installed" ) {
1476                         my $app = {
1477                             name => $1,
1478                             version => $2,
1479                             arch => $3
1480                         };
1481                         push @apps, $app
1482                     }
1483                 }
1484             }
1485         }
1486     } elsif ($osn eq "windows") {
1487         # XXX
1488         # I worked out a general plan for this, but haven't
1489         # implemented it yet.  We can iterate over /Program Files
1490         # looking for *.EXE files, which we download, then use
1491         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1492         # section, which has a lot of useful information.
1493     }
1494
1495     $os->{apps} = \@apps;
1496 }
1497
1498 # Find the path which needs to be prepended to paths in grub.conf to make them
1499 # absolute
1500 sub _find_grub_prefix
1501 {
1502     my ($g, $os) = @_;
1503
1504     my $fses = $os->{filesystems};
1505     die("filesystems undefined") unless(defined($fses));
1506
1507     # Look for the filesystem which contains grub
1508     my $grubdev;
1509     foreach my $dev (keys(%$fses)) {
1510         my $fsinfo = $fses->{$dev};
1511         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1512             $grubdev = $dev;
1513             last;
1514         }
1515     }
1516
1517     my $mounts = $os->{mounts};
1518     die("mounts undefined") unless(defined($mounts));
1519
1520     # Find where the filesystem is mounted
1521     if(defined($grubdev)) {
1522         foreach my $mount (keys(%$mounts)) {
1523             if($mounts->{$mount} eq $grubdev) {
1524                 return "" if($mount eq '/');
1525                 return $mount;
1526             }
1527         }
1528
1529         die("$grubdev defined in filesystems, but not in mounts");
1530     }
1531
1532     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1533     # what filesystem it's on. We use menu.lst rather than grub.conf because
1534     # debian only uses menu.lst, and anaconda creates a symlink for it.
1535     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1536
1537     # Look for the most specific mount point in mounts
1538     foreach my $path qw(/boot/grub /boot /) {
1539         if(exists($mounts->{$path})) {
1540             return "" if($path eq '/');
1541             return $path;
1542         }
1543     }
1544
1545     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1546 }
1547
1548 sub _check_for_kernels
1549 {
1550     my ($g, $os) = @_;
1551
1552     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1553         # Iterate over entries in grub.conf, populating $os->{boot}
1554         # For every kernel we find, inspect it and add to $os->{kernels}
1555
1556         my $grub = _find_grub_prefix($g, $os);
1557         my $grub_conf = "/etc/grub.conf";
1558
1559         # Debian and other's have no /etc/grub.conf:
1560         if ( ! -f "$grub_conf" ) {
1561             $grub_conf = "$grub/grub/menu.lst";
1562         }
1563
1564         my @boot_configs;
1565
1566         # We want
1567         #  $os->{boot}
1568         #       ->{configs}
1569         #         ->[0]
1570         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1571         #           ->{kernel}  = \kernel
1572         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1573         #           ->{initrd}  = \initrd
1574         #       ->{default} = \config
1575         #       ->{grub_fs} = "/boot"
1576         # Initialise augeas
1577         $g->aug_init("/", 16);
1578
1579         my @configs = ();
1580         # Get all configurations from grub
1581         foreach my $bootable
1582             ($g->aug_match("/files/$grub_conf/title"))
1583         {
1584             my %config = ();
1585             $config{title} = $g->aug_get($bootable);
1586
1587             my $grub_kernel;
1588             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1589             if($@) {
1590                 warn __x("Grub entry {title} has no kernel",
1591                          title => $config{title});
1592             }
1593
1594             # Check we've got a kernel entry
1595             if(defined($grub_kernel)) {
1596                 my $path = "$grub$grub_kernel";
1597
1598                 # Reconstruct the kernel command line
1599                 my @args = ();
1600                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1601                     $arg =~ m{/kernel/([^/]*)$}
1602                         or die("Unexpected return from aug_match: $arg");
1603
1604                     my $name = $1;
1605                     my $value;
1606                     eval { $value = $g->aug_get($arg); };
1607
1608                     if(defined($value)) {
1609                         push(@args, "$name=$value");
1610                     } else {
1611                         push(@args, $name);
1612                     }
1613                 }
1614                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1615
1616                 my $kernel =
1617                     inspect_linux_kernel($g, $path, $os->{package_format});
1618
1619                 # Check the kernel was recognised
1620                 if(defined($kernel)) {
1621                     # Put this kernel on the top level kernel list
1622                     $os->{kernels} ||= [];
1623                     push(@{$os->{kernels}}, $kernel);
1624
1625                     $config{kernel} = $kernel;
1626
1627                     # Look for an initrd entry
1628                     my $initrd;
1629                     eval {
1630                         $initrd = $g->aug_get("$bootable/initrd");
1631                     };
1632
1633                     unless($@) {
1634                         $config{initrd} =
1635                             _inspect_initrd($g, $os, "$grub$initrd",
1636                                             $kernel->{version});
1637                     } else {
1638                         warn __x("Grub entry {title} does not specify an ".
1639                                  "initrd", title => $config{title});
1640                     }
1641                 }
1642             }
1643
1644             push(@configs, \%config);
1645         }
1646
1647
1648         # Create the top level boot entry
1649         my %boot;
1650         $boot{configs} = \@configs;
1651         $boot{grub_fs} = $grub;
1652
1653         # Add the default configuration
1654         eval {
1655             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1656         };
1657         if($@) {
1658             warn __"No grub default specified";
1659         }
1660
1661         $os->{boot} = \%boot;
1662     }
1663
1664     elsif ($os->{os} eq "windows") {
1665         # XXX
1666     }
1667 }
1668
1669 =head2 inspect_linux_kernel
1670
1671  my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
1672
1673 inspect_linux_kernel returns a hash describing the target linux kernel. For the
1674 contents of the hash, see the I<kernels> structure described under
1675 L</inspect_in_detail>.
1676
1677 =cut
1678
1679 sub inspect_linux_kernel
1680 {
1681     my ($g, $path, $package_format) = @_;
1682
1683     my %kernel = ();
1684
1685     $kernel{path} = $path;
1686
1687     # If this is a packaged kernel, try to work out the name of the package
1688     # which installed it. This lets us know what to install to replace it with,
1689     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1690     if($package_format eq "rpm") {
1691         my $package;
1692         eval { $package = $g->command(['rpm', '-qf', '--qf',
1693                                        '%{NAME}', $path]); };
1694         $kernel{package} = $package if defined($package);;
1695     }
1696
1697     # Try to get the kernel version by running file against it
1698     my $version;
1699     my $filedesc = $g->file($path);
1700     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1701         $version = $1;
1702     }
1703
1704     # Sometimes file can't work out the kernel version, for example because it's
1705     # a Xen PV kernel. In this case try to guess the version from the filename
1706     else {
1707         if($path =~ m{/boot/vmlinuz-(.*)}) {
1708             $version = $1;
1709
1710             # Check /lib/modules/$version exists
1711             if(!$g->is_dir("/lib/modules/$version")) {
1712                 warn __x("Didn't find modules directory {modules} for kernel ".
1713                          "{path}", modules => "/lib/modules/$version",
1714                          path => $path);
1715
1716                 # Give up
1717                 return undef;
1718             }
1719         } else {
1720             warn __x("Couldn't guess kernel version number from path for ".
1721                      "kernel {path}", path => $path);
1722
1723             # Give up
1724             return undef;
1725         }
1726     }
1727
1728     $kernel{version} = $version;
1729
1730     # List modules.
1731     my @modules;
1732     my $any_module;
1733     my $prefix = "/lib/modules/$version";
1734     foreach my $module ($g->find ($prefix)) {
1735         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1736             $any_module = "$prefix$module" unless defined $any_module;
1737             push @modules, $1;
1738         }
1739     }
1740
1741     $kernel{modules} = \@modules;
1742
1743     # Determine kernel architecture by looking at the arch
1744     # of any kernel module.
1745     $kernel{arch} = file_architecture ($g, $any_module);
1746
1747     return \%kernel;
1748 }
1749
1750 # Find all modprobe aliases. Specifically, this looks in the following
1751 # locations:
1752 #  * /etc/conf.modules
1753 #  * /etc/modules.conf
1754 #  * /etc/modprobe.conf
1755 #  * /etc/modprobe.d/*
1756
1757 sub _find_modprobe_aliases
1758 {
1759     local $_;
1760     my $g = shift;
1761     my $os = shift;
1762
1763     # Initialise augeas
1764     $g->aug_init("/", 16);
1765
1766     # Register additional paths to the Modprobe lens
1767     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/modules.conf");
1768     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/conf.modules");
1769
1770     # Make augeas reload
1771     $g->aug_load();
1772
1773     my %modprobe_aliases;
1774
1775     for my $pattern qw(/files/etc/conf.modules/alias
1776                        /files/etc/modules.conf/alias
1777                        /files/etc/modprobe.conf/alias
1778                        /files/etc/modprobe.d/*/alias) {
1779         for my $path ( $g->aug_match($pattern) ) {
1780             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1781                 or die __x("{path} doesn't match augeas pattern",
1782                            path => $path);
1783             my $file = $1;
1784
1785             my $alias;
1786             $alias = $g->aug_get($path);
1787
1788             my $modulename;
1789             $modulename = $g->aug_get($path.'/modulename');
1790
1791             my %aliasinfo;
1792             $aliasinfo{modulename} = $modulename;
1793             $aliasinfo{augeas} = $path;
1794             $aliasinfo{file} = $file;
1795
1796             $modprobe_aliases{$alias} = \%aliasinfo;
1797         }
1798     }
1799
1800     $os->{modprobe_aliases} = \%modprobe_aliases;
1801 }
1802
1803 # Get a listing of device drivers from an initrd
1804 sub _inspect_initrd
1805 {
1806     my ($g, $os, $path, $version) = @_;
1807
1808     my @modules;
1809
1810     # Disregard old-style compressed ext2 files and only work with real
1811     # compressed cpio files, since cpio takes ages to (fail to) process anything
1812     # else.
1813     if ($g->file ($path) =~ /cpio/) {
1814         eval {
1815             @modules = $g->initrd_list ($path);
1816         };
1817         unless ($@) {
1818             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1819         } else {
1820             warn __x("{filename}: could not read initrd format",
1821                      filename => "$path");
1822         }
1823     }
1824
1825     # Add to the top level initrd_modules entry
1826     $os->{initrd_modules} ||= {};
1827     $os->{initrd_modules}->{$version} = \@modules;
1828
1829     return \@modules;
1830 }
1831
1832 1;
1833
1834 =head1 COPYRIGHT
1835
1836 Copyright (C) 2009 Red Hat Inc.
1837
1838 =head1 LICENSE
1839
1840 Please see the file COPYING.LIB for the full license.
1841
1842 =head1 SEE ALSO
1843
1844 L<virt-inspector(1)>,
1845 L<Sys::Guestfs(3)>,
1846 L<guestfs(3)>,
1847 L<http://libguestfs.org/>,
1848 L<Sys::Virt(3)>,
1849 L<http://libvirt.org/>,
1850 L<guestfish(1)>.
1851
1852 =cut