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