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