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, but this function
1105 will throw an error if no roots (ie. OSes) could be found.
1106
1107 The C<\%os> hash contains the following keys (any can be omitted):
1108
1109 =over 4
1110
1111 =item os
1112
1113 Operating system type, eg. "linux", "windows".
1114
1115 =item arch
1116
1117 Operating system userspace architecture, eg. "i386", "x86_64".
1118
1119 =item distro
1120
1121 Operating system distribution, eg. "debian".
1122
1123 =item product_name
1124
1125 Free text product name.
1126
1127 =item major_version
1128
1129 Operating system major version, eg. "4".
1130
1131 =item minor_version
1132
1133 Operating system minor version, eg "3".
1134
1135 =item root
1136
1137 The value is a reference to the root partition C<%fs> hash.
1138
1139 =item root_device
1140
1141 The value is the name of the root partition (as a string).
1142
1143 =item mounts
1144
1145 Mountpoints.
1146 The value is a hashref like this:
1147
1148  mounts => {
1149    '/' => '/dev/VG/Root',
1150    '/boot' => '/dev/sda1',
1151  }
1152
1153 =item filesystems
1154
1155 Filesystems (including swap devices and unmounted partitions).
1156 The value is a hashref like this:
1157
1158  filesystems => {
1159    '/dev/sda1' => \%fs,
1160    '/dev/VG/Root' => \%fs,
1161    '/dev/VG/Swap' => \%fs,
1162  }
1163
1164 =back
1165
1166 =cut
1167
1168 sub inspect_operating_systems
1169 {
1170     local $_;
1171     my $g = shift;
1172     my $fses = shift;
1173
1174     my %oses = ();
1175
1176     foreach (sort keys %$fses) {
1177         if ($fses->{$_}->{is_root}) {
1178             my %r = (
1179                 root => $fses->{$_},
1180                 root_device => $_
1181                 );
1182             _get_os_version ($g, \%r);
1183             _assign_mount_points ($g, $fses, \%r);
1184             $oses{$_} = \%r;
1185         }
1186     }
1187
1188     # If we didn't find any operating systems then it's an error (RHBZ#591142).
1189     if (0 == keys %oses) {
1190         die __"No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by virt-inspector.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n";
1191     }
1192
1193     return \%oses;
1194 }
1195
1196 sub _get_os_version
1197 {
1198     local $_;
1199     my $g = shift;
1200     my $r = shift;
1201
1202     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1203     $r->{product_name} = $r->{root}->{product_name}
1204         if exists $r->{root}->{product_name};
1205     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1206     $r->{major_version} = $r->{root}->{os_major_version}
1207         if exists $r->{root}->{os_major_version};
1208     $r->{minor_version} = $r->{root}->{os_minor_version}
1209         if exists $r->{root}->{os_minor_version};
1210     $r->{package_format} = $r->{root}->{package_format}
1211         if exists $r->{root}->{package_format};
1212     $r->{package_management} = $r->{root}->{package_management}
1213         if exists $r->{root}->{package_management};
1214     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1215 }
1216
1217 sub _assign_mount_points
1218 {
1219     local $_;
1220     my $g = shift;
1221     my $fses = shift;
1222     my $r = shift;
1223
1224     $r->{mounts} = { "/" => $r->{root_device} };
1225     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1226
1227     # Use /etc/fstab if we have it to mount the rest.
1228     if (exists $r->{root}->{fstab}) {
1229         my @fstab = @{$r->{root}->{fstab}};
1230         foreach (@fstab) {
1231             my ($spec, $file) = @$_;
1232
1233             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1234             if ($dev) {
1235                 $r->{mounts}->{$file} = $dev;
1236                 $r->{filesystems}->{$dev} = $fs;
1237                 if (exists $fs->{used}) {
1238                     $fs->{used}++
1239                 } else {
1240                     $fs->{used} = 1
1241                 }
1242                 $fs->{spec} = $spec;
1243             }
1244         }
1245     }
1246 }
1247
1248 # Find filesystem by device name, LABEL=.. or UUID=..
1249 sub _find_filesystem
1250 {
1251     my $g = shift;
1252     my $fses = shift;
1253     local $_ = shift;
1254
1255     if (/^LABEL=(.*)/) {
1256         my $label = $1;
1257         foreach (sort keys %$fses) {
1258             if (exists $fses->{$_}->{label} &&
1259                 $fses->{$_}->{label} eq $label) {
1260                 return ($_, $fses->{$_});
1261             }
1262         }
1263         warn __x("unknown filesystem label {label}\n", label => $label);
1264         return ();
1265     } elsif (/^UUID=(.*)/) {
1266         my $uuid = $1;
1267         foreach (sort keys %$fses) {
1268             if (exists $fses->{$_}->{uuid} &&
1269                 $fses->{$_}->{uuid} eq $uuid) {
1270                 return ($_, $fses->{$_});
1271             }
1272         }
1273         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1274         return ();
1275     } else {
1276         return ($_, $fses->{$_}) if exists $fses->{$_};
1277
1278         # The following is to handle the case where an fstab entry specifies a
1279         # specific device rather than its label or uuid, and the libguestfs
1280         # appliance has named the device differently due to the use of a
1281         # different driver.
1282         # This will work as long as the underlying drivers recognise devices in
1283         # the same order.
1284         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1285             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1286         }
1287         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1288             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1289         }
1290         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1291             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1292         }
1293
1294         return () if m{/dev/cdrom};
1295
1296         warn __x("unknown filesystem {fs}\n", fs => $_);
1297         return ();
1298     }
1299 }
1300
1301 =head2 mount_operating_system
1302
1303  mount_operating_system ($g, \%os, [$ro]);
1304
1305 This function mounts the operating system described in the
1306 C<%os> hash according to the C<mounts> table in that hash (see
1307 C<inspect_operating_systems>).
1308
1309 The partitions are mounted read-only unless the third parameter
1310 is specified as zero explicitly.
1311
1312 To reverse the effect of this call, use the standard
1313 libguestfs API call C<$g-E<gt>umount_all ()>.
1314
1315 =cut
1316
1317 sub mount_operating_system
1318 {
1319     local $_;
1320     my $g = shift;
1321     my $os = shift;
1322     my $ro = shift;             # Read-only?
1323
1324     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1325
1326     my $mounts = $os->{mounts};
1327
1328     # Have to mount / first.  Luckily '/' is early in the ASCII
1329     # character set, so this should be OK.
1330     foreach (sort keys %$mounts) {
1331         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1332             if($ro) {
1333                 $g->mount_ro ($mounts->{$_}, $_)
1334             } else {
1335                 $g->mount_options ("", $mounts->{$_}, $_)
1336             }
1337         }
1338     }
1339 }
1340
1341 =head2 inspect_in_detail
1342
1343  mount_operating_system ($g, \%os);
1344  inspect_in_detail ($g, \%os);
1345  $g->umount_all ();
1346
1347 The C<inspect_in_detail> function inspects the mounted operating
1348 system for installed applications, installed kernels, kernel modules,
1349 system architecture, and more.
1350
1351 It adds extra keys to the existing C<%os> hash reflecting what it
1352 finds.  These extra keys are:
1353
1354 =over 4
1355
1356 =item apps
1357
1358 List of applications.
1359
1360 =item boot
1361
1362 Boot configurations. A hash containing:
1363
1364 =over 4
1365
1366 =item configs
1367
1368 An array of boot configurations. Each array entry is a hash containing:
1369
1370 =over 4
1371
1372 =item initrd
1373
1374 A reference to the expanded initrd structure (see below) for the initrd used by
1375 this boot configuration.
1376
1377 =item kernel
1378
1379 A reference to the expanded kernel structure (see below) for the kernel used by
1380 this boot configuration.
1381
1382 =item title
1383
1384 The human readable name of the configuration.
1385
1386 =item cmdline
1387
1388 The kernel command line.
1389
1390 =back
1391
1392 =item default
1393
1394 The index of the default configuration in the configs array.
1395
1396 =item grub_fs
1397
1398 The path of the filesystem containing the grub partition.
1399
1400 =back
1401
1402 =item kernels
1403
1404 List of kernels.
1405
1406 This is a hash of kernel version =E<gt> a hash with the following keys:
1407
1408 =over 4
1409
1410 =item version
1411
1412 Kernel version.
1413
1414 =item arch
1415
1416 Kernel architecture (eg. C<x86-64>).
1417
1418 =item modules
1419
1420 List of modules.
1421
1422 =item path
1423
1424 The path to the kernel's vmlinuz file.
1425
1426 =item package
1427
1428 If the kernel was installed in a package, the name of that package.
1429
1430 =back
1431
1432 =item modprobe_aliases
1433
1434 (For Linux VMs).
1435 The contents of the modprobe configuration.
1436
1437 =item initrd_modules
1438
1439 (For Linux VMs).
1440 The kernel modules installed in the initrd.  The value is
1441 a hashref of kernel version to list of modules.
1442
1443 =back
1444
1445 =cut
1446
1447 sub inspect_in_detail
1448 {
1449     local $_;
1450     my $g = shift;
1451     my $os = shift;
1452
1453     _check_for_applications ($g, $os);
1454     _check_for_kernels ($g, $os);
1455     if ($os->{os} eq "linux") {
1456         _find_modprobe_aliases ($g, $os);
1457     }
1458 }
1459
1460 sub _check_for_applications
1461 {
1462     local $_;
1463     my $g = shift;
1464     my $os = shift;
1465
1466     my @apps;
1467
1468     my $osn = $os->{os};
1469     if ($osn eq "linux") {
1470         my $package_format = $os->{package_format};
1471         if (defined $package_format && $package_format eq "rpm") {
1472             my @lines = ();
1473             eval {
1474                 @lines = $g->command_lines
1475                     (["rpm",
1476                       "-q", "-a", "--qf",
1477                       "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1478             };
1479
1480             warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@);
1481
1482             @lines = sort @lines;
1483             foreach (@lines) {
1484                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1485                     my $epoch = $2;
1486                     undef $epoch if $epoch eq "(none)";
1487                     my $app = {
1488                         name => $1,
1489                         epoch => $epoch,
1490                         version => $3,
1491                         release => $4,
1492                         arch => $5
1493                     };
1494                     push @apps, $app
1495                 }
1496             }
1497         } elsif (defined $package_format && $package_format eq "deb") {
1498             my @lines = ();
1499             eval {
1500                 @lines = $g->command_lines
1501                     (["dpkg-query",
1502                       "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1503                       "-W"]);
1504             };
1505
1506             warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@);
1507
1508             @lines = sort @lines;
1509             foreach (@lines) {
1510                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1511                     if ( $6 eq "installed" ) {
1512                         my $app = {
1513                             name => $1,
1514                             version => $2,
1515                             arch => $3
1516                         };
1517                         push @apps, $app
1518                     }
1519                 }
1520             }
1521         }
1522     } elsif ($osn eq "windows") {
1523         # XXX
1524         # I worked out a general plan for this, but haven't
1525         # implemented it yet.  We can iterate over /Program Files
1526         # looking for *.EXE files, which we download, then use
1527         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1528         # section, which has a lot of useful information.
1529     }
1530
1531     $os->{apps} = \@apps;
1532 }
1533
1534 # Find the path which needs to be prepended to paths in grub.conf to make them
1535 # absolute
1536 sub _find_grub_prefix
1537 {
1538     my ($g, $os) = @_;
1539
1540     my $fses = $os->{filesystems};
1541     die("filesystems undefined") unless(defined($fses));
1542
1543     # Look for the filesystem which contains grub
1544     my $grubdev;
1545     foreach my $dev (keys(%$fses)) {
1546         my $fsinfo = $fses->{$dev};
1547         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1548             $grubdev = $dev;
1549             last;
1550         }
1551     }
1552
1553     my $mounts = $os->{mounts};
1554     die("mounts undefined") unless(defined($mounts));
1555
1556     # Find where the filesystem is mounted
1557     if(defined($grubdev)) {
1558         foreach my $mount (keys(%$mounts)) {
1559             if($mounts->{$mount} eq $grubdev) {
1560                 return "" if($mount eq '/');
1561                 return $mount;
1562             }
1563         }
1564
1565         die("$grubdev defined in filesystems, but not in mounts");
1566     }
1567
1568     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1569     # what filesystem it's on. We use menu.lst rather than grub.conf because
1570     # debian only uses menu.lst, and anaconda creates a symlink for it.
1571     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1572
1573     # Look for the most specific mount point in mounts
1574     foreach my $path qw(/boot/grub /boot /) {
1575         if(exists($mounts->{$path})) {
1576             return "" if($path eq '/');
1577             return $path;
1578         }
1579     }
1580
1581     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1582 }
1583
1584 sub _check_for_kernels
1585 {
1586     my ($g, $os) = @_;
1587
1588     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1589         # Iterate over entries in grub.conf, populating $os->{boot}
1590         # For every kernel we find, inspect it and add to $os->{kernels}
1591
1592         my $grub = _find_grub_prefix($g, $os);
1593         my $grub_conf = "/etc/grub.conf";
1594
1595         # Debian and other's have no /etc/grub.conf:
1596         if ( ! -f "$grub_conf" ) {
1597             $grub_conf = "$grub/grub/menu.lst";
1598         }
1599
1600         my @boot_configs;
1601
1602         # We want
1603         #  $os->{boot}
1604         #       ->{configs}
1605         #         ->[0]
1606         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1607         #           ->{kernel}  = \kernel
1608         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1609         #           ->{initrd}  = \initrd
1610         #       ->{default} = \config
1611         #       ->{grub_fs} = "/boot"
1612         # Initialise augeas
1613         $g->aug_init("/", 16);
1614
1615         my @configs = ();
1616         # Get all configurations from grub
1617         foreach my $bootable
1618             ($g->aug_match("/files/$grub_conf/title"))
1619         {
1620             my %config = ();
1621             $config{title} = $g->aug_get($bootable);
1622
1623             my $grub_kernel;
1624             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1625             if($@) {
1626                 warn __x("Grub entry {title} has no kernel",
1627                          title => $config{title});
1628             }
1629
1630             # Check we've got a kernel entry
1631             if(defined($grub_kernel)) {
1632                 my $path = "$grub$grub_kernel";
1633
1634                 # Reconstruct the kernel command line
1635                 my @args = ();
1636                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1637                     $arg =~ m{/kernel/([^/]*)$}
1638                         or die("Unexpected return from aug_match: $arg");
1639
1640                     my $name = $1;
1641                     my $value;
1642                     eval { $value = $g->aug_get($arg); };
1643
1644                     if(defined($value)) {
1645                         push(@args, "$name=$value");
1646                     } else {
1647                         push(@args, $name);
1648                     }
1649                 }
1650                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1651
1652                 my $kernel;
1653                 if ($g->exists($path)) {
1654                     $kernel =
1655                         inspect_linux_kernel($g, $path, $os->{package_format});
1656                 } else {
1657                     warn __x("grub refers to {path}, which doesn't exist\n",
1658                              path => $path);
1659                 }
1660
1661                 # Check the kernel was recognised
1662                 if(defined($kernel)) {
1663                     # Put this kernel on the top level kernel list
1664                     $os->{kernels} ||= [];
1665                     push(@{$os->{kernels}}, $kernel);
1666
1667                     $config{kernel} = $kernel;
1668
1669                     # Look for an initrd entry
1670                     my $initrd;
1671                     eval {
1672                         $initrd = $g->aug_get("$bootable/initrd");
1673                     };
1674
1675                     unless($@) {
1676                         $config{initrd} =
1677                             _inspect_initrd($g, $os, "$grub$initrd",
1678                                             $kernel->{version});
1679                     } else {
1680                         warn __x("Grub entry {title} does not specify an ".
1681                                  "initrd", title => $config{title});
1682                     }
1683                 }
1684             }
1685
1686             push(@configs, \%config);
1687         }
1688
1689
1690         # Create the top level boot entry
1691         my %boot;
1692         $boot{configs} = \@configs;
1693         $boot{grub_fs} = $grub;
1694
1695         # Add the default configuration
1696         eval {
1697             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1698         };
1699
1700         $os->{boot} = \%boot;
1701     }
1702
1703     elsif ($os->{os} eq "windows") {
1704         # XXX
1705     }
1706 }
1707
1708 =head2 inspect_linux_kernel
1709
1710  my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
1711
1712 inspect_linux_kernel returns a hash describing the target linux kernel. For the
1713 contents of the hash, see the I<kernels> structure described under
1714 L</inspect_in_detail>.
1715
1716 =cut
1717
1718 sub inspect_linux_kernel
1719 {
1720     my ($g, $path, $package_format) = @_;
1721
1722     my %kernel = ();
1723
1724     $kernel{path} = $path;
1725
1726     # If this is a packaged kernel, try to work out the name of the package
1727     # which installed it. This lets us know what to install to replace it with,
1728     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1729     if($package_format eq "rpm") {
1730         my $package;
1731         eval { $package = $g->command(['rpm', '-qf', '--qf',
1732                                        '%{NAME}', $path]); };
1733         $kernel{package} = $package if defined($package);;
1734     }
1735
1736     # Try to get the kernel version by running file against it
1737     my $version;
1738     my $filedesc = $g->file($path);
1739     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1740         $version = $1;
1741     }
1742
1743     # Sometimes file can't work out the kernel version, for example because it's
1744     # a Xen PV kernel. In this case try to guess the version from the filename
1745     else {
1746         if($path =~ m{/boot/vmlinuz-(.*)}) {
1747             $version = $1;
1748
1749             # Check /lib/modules/$version exists
1750             if(!$g->is_dir("/lib/modules/$version")) {
1751                 warn __x("Didn't find modules directory {modules} for kernel ".
1752                          "{path}", modules => "/lib/modules/$version",
1753                          path => $path);
1754
1755                 # Give up
1756                 return undef;
1757             }
1758         } else {
1759             warn __x("Couldn't guess kernel version number from path for ".
1760                      "kernel {path}", path => $path);
1761
1762             # Give up
1763             return undef;
1764         }
1765     }
1766
1767     $kernel{version} = $version;
1768
1769     # List modules.
1770     my @modules;
1771     my $any_module;
1772     my $prefix = "/lib/modules/$version";
1773     foreach my $module ($g->find ($prefix)) {
1774         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1775             $any_module = "$prefix$module" unless defined $any_module;
1776             push @modules, $1;
1777         }
1778     }
1779
1780     $kernel{modules} = \@modules;
1781
1782     # Determine kernel architecture by looking at the arch
1783     # of any kernel module.
1784     $kernel{arch} = file_architecture ($g, $any_module);
1785
1786     return \%kernel;
1787 }
1788
1789 # Find all modprobe aliases. Specifically, this looks in the following
1790 # locations:
1791 #  * /etc/conf.modules
1792 #  * /etc/modules.conf
1793 #  * /etc/modprobe.conf
1794 #  * /etc/modprobe.d/*
1795
1796 sub _find_modprobe_aliases
1797 {
1798     local $_;
1799     my $g = shift;
1800     my $os = shift;
1801
1802     # Initialise augeas
1803     $g->aug_init("/", 16);
1804
1805     my %modprobe_aliases;
1806
1807     for my $pattern qw(/files/etc/conf.modules/alias
1808                        /files/etc/modules.conf/alias
1809                        /files/etc/modprobe.conf/alias
1810                        /files/etc/modprobe.d/*/alias) {
1811         for my $path ( $g->aug_match($pattern) ) {
1812             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1813                 or die __x("{path} doesn't match augeas pattern",
1814                            path => $path);
1815             my $file = $1;
1816
1817             my $alias;
1818             $alias = $g->aug_get($path);
1819
1820             my $modulename;
1821             $modulename = $g->aug_get($path.'/modulename');
1822
1823             my %aliasinfo;
1824             $aliasinfo{modulename} = $modulename;
1825             $aliasinfo{augeas} = $path;
1826             $aliasinfo{file} = $file;
1827
1828             $modprobe_aliases{$alias} = \%aliasinfo;
1829         }
1830     }
1831
1832     $os->{modprobe_aliases} = \%modprobe_aliases;
1833 }
1834
1835 # Get a listing of device drivers from an initrd
1836 sub _inspect_initrd
1837 {
1838     my ($g, $os, $path, $version) = @_;
1839
1840     my @modules;
1841
1842     # Disregard old-style compressed ext2 files and only work with real
1843     # compressed cpio files, since cpio takes ages to (fail to) process anything
1844     # else.
1845     if ($g->exists($path) && $g->file($path) =~ /cpio/) {
1846         eval {
1847             @modules = $g->initrd_list ($path);
1848         };
1849         unless ($@) {
1850             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1851         } else {
1852             warn __x("{filename}: could not read initrd format",
1853                      filename => "$path");
1854         }
1855     }
1856
1857     # Add to the top level initrd_modules entry
1858     $os->{initrd_modules} ||= {};
1859     $os->{initrd_modules}->{$version} = \@modules;
1860
1861     return \@modules;
1862 }
1863
1864 1;
1865
1866 =head1 COPYRIGHT
1867
1868 Copyright (C) 2009 Red Hat Inc.
1869
1870 =head1 LICENSE
1871
1872 Please see the file COPYING.LIB for the full license.
1873
1874 =head1 SEE ALSO
1875
1876 L<virt-inspector(1)>,
1877 L<Sys::Guestfs(3)>,
1878 L<guestfs(3)>,
1879 L<http://libguestfs.org/>,
1880 L<Sys::Virt(3)>,
1881 L<http://libvirt.org/>,
1882 L<guestfish(1)>.
1883
1884 =cut