perl/lib/Sys/Guestfs/Lib.pm

   1 # Sys::Guestfs::Lib
   2 # Copyright (C) 2009 Red Hat Inc.
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 package Sys::Guestfs::Lib;
  19
  20 use strict;
  21 use warnings;
  22
  23 use Sys::Guestfs;
  24
  25 # Optional:
  26 eval "use Sys::Virt;";
  27 eval "use XML::XPath;";
  28 eval "use XML::XPath::XMLParser;";
  29
  30 =pod
  31
  32 =head1 NAME
  33
  34 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
  35
  36 =head1 SYNOPSIS
  37
  38  use Sys::Guestfs::Lib qw(#any symbols you want to use);
  39
  40  $g = open_guest ($name);
  41
  42 =head1 DESCRIPTION
  43
  44 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
  45 the libguestfs API from Perl.  It also provides tighter integration
  46 with libvirt.
  47
  48 The basic libguestfs API is not covered by this manpage.  Please refer
  49 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
  50 also not covered.  For that, see L<Sys::Virt(3)>.
  51
  52 =head1 BASIC FUNCTIONS
  53
  54 =cut
  55
  56 require Exporter;
  57
  58 use vars qw(@EXPORT_OK @ISA);
  59
  60 @ISA = qw(Exporter);
  61 @EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
  62   inspect_all_partitions inspect_partition
  63   inspect_operating_systems mount_operating_system inspect_in_detail);
  64
  65 =head2 open_guest
  66
  67  $g = open_guest ($name);
  68
  69  $g = open_guest ($name, rw => 1, ...);
  70
  71  $g = open_guest ($name, address => $uri, ...);
  72
  73  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
  74
  75  ($g, $conn, $dom) = open_guest ($name);
  76
  77 This function opens a libguestfs handle for either the libvirt domain
  78 called C<$name>, or the disk image called C<$name>.  Any disk images
  79 found through libvirt or specified explicitly are attached to the
  80 libguestfs handle.
  81
  82 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
  83 it throws an exception.  To catch errors, wrap the call in an eval
  84 block.
  85
  86 The first parameter is either a string referring to a libvirt domain
  87 or a disk image, or (if a guest has several disk images) an arrayref
  88 C<[$img1, $img2, ...]>.
  89
  90 The handle is I<read-only> by default.  Use the optional parameter
  91 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
  92 read-write handle, this function will refuse to use active libvirt
  93 domains.
  94
  95 The handle is still in the config state when it is returned, so you
  96 have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
  97
  98 The optional C<address> parameter can be added to specify the libvirt
  99 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
 100 passed through to C<Sys::Virt-E<gt>new> unchanged.
 101
 102 The implicit libvirt handle is closed after this function, I<unless>
 103 you call the function in C<wantarray> context, in which case the
 104 function returns a tuple of: the open libguestfs handle, the open
 105 libvirt handle, and the open libvirt domain handle.  (This is useful
 106 if you want to do other things like pulling the XML description of the
 107 guest).  Note that if this is a straight disk image, then C<$conn> and
 108 C<$dom> will be C<undef>.
 109
 110 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 111 and this function can only open disk images.
 112
 113 =cut
 114
 115 sub open_guest
 116 {
 117     my $first = shift;
 118     my %params = @_;
 119
 120     my $readwrite = $params{rw};
 121
 122     my @images = ();
 123     if (ref ($first) eq "ARRAY") {
 124         @images = @$first;
 125     } elsif (ref ($first) eq "SCALAR") {
 126         @images = ($first);
 127     } else {
 128         die "open_guest: first parameter must be a string or an arrayref"
 129     }
 130
 131     my ($conn, $dom);
 132
 133     if (-e $images[0]) {
 134         foreach (@images) {
 135             die "guest image $_ does not exist or is not readable"
 136                 unless -r $_;
 137         }
 138     } else {
 139         die "open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
 140             unless exists $INC{"Sys/Virt.pm"} &&
 141             exists $INC{"XML/XPath.pm"} &&
 142             exists $INC{"XML/XPath/XMLParser.pm"};
 143
 144         die "open_guest: too many domains listed on command line"
 145             if @images > 1;
 146
 147         $conn = Sys::Virt->new (readonly => 1, @_);
 148         die "open_guest: cannot connect to libvirt" unless $conn;
 149
 150         my @doms = $conn->list_defined_domains ();
 151         my $isitinactive = "an inactive libvirt domain";
 152         unless ($readwrite) {
 153             # In the case where we want read-only access to a domain,
 154             # allow the user to specify an active domain too.
 155             push @doms, $conn->list_domains ();
 156             $isitinactive = "a libvirt domain";
 157         }
 158         foreach (@doms) {
 159             if ($_->get_name () eq $images[0]) {
 160                 $dom = $_;
 161                 last;
 162             }
 163         }
 164         die "$images[0] is not the name of $isitinactive\n" unless $dom;
 165
 166         # Get the names of the image(s).
 167         my $xml = $dom->get_xml_description ();
 168
 169         my $p = XML::XPath->new (xml => $xml);
 170         my @disks = $p->findnodes ('//devices/disk/source/@dev');
 171         @images = map { $_->getData } @disks;
 172     }
 173
 174     # We've now got the list of @images, so feed them to libguestfs.
 175     my $g = Sys::Guestfs->new ();
 176     foreach (@images) {
 177         if ($readwrite) {
 178             $g->add_drive ($_);
 179         } else {
 180             $g->add_drive_ro ($_);
 181         }
 182     }
 183
 184     return wantarray ? ($g, $conn, $dom) : $g
 185 }
 186
 187 =head2 get_partitions
 188
 189  @partitions = get_partitions ($g);
 190
 191 This function takes an open libguestfs handle C<$g> and returns all
 192 partitions and logical volumes found on it.
 193
 194 What is returned is everything that could contain a filesystem (or
 195 swap).  Physical volumes are excluded from the list, and so are any
 196 devices which are partitioned (eg. C</dev/sda> would not be returned
 197 if C</dev/sda1> exists).
 198
 199 =cut
 200
 201 sub get_partitions
 202 {
 203     my $g = shift;
 204
 205     my @partitions = $g->list_partitions ();
 206     my @pvs = $g->pvs ();
 207     @partitions = grep { ! is_pv ($_, @pvs) } @partitions;
 208
 209     my @lvs = $g->lvs ();
 210
 211     return sort (@lvs, @partitions);
 212 }
 213
 214 sub is_pv {
 215     local $_;
 216     my $t = shift;
 217
 218     foreach (@_) {
 219         return 1 if $_ eq $t;
 220     }
 221     0;
 222 }
 223
 224 =head2 resolve_windows_path
 225
 226  $path = resolve_windows_path ($g, $path);
 227
 228  $path = resolve_windows_path ($g, "/windows/system");
 229    ==> "/WINDOWS/System"
 230        or undef if no path exists
 231
 232 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
 233 guests), lets you look up a case insensitive C<$path> in the
 234 filesystem and returns the true, case sensitive path as required by
 235 the underlying kernel or NTFS-3g driver.
 236
 237 If C<$path> does not exist then this function returns C<undef>.
 238
 239 The C<$path> parameter must begin with C</> character and be separated
 240 by C</> characters.  Do not use C<\>, drive names, etc.
 241
 242 =cut
 243
 244 sub resolve_windows_path
 245 {
 246     local $_;
 247     my $g = shift;
 248     my $path = shift;
 249
 250     if (substr ($path, 0, 1) ne "/") {
 251         warn "resolve_windows_path: path must start with a / character";
 252         return undef;
 253     }
 254
 255     my @elems = split (/\//, $path);
 256     shift @elems;
 257
 258     # Start reconstructing the path at the top.
 259     $path = "/";
 260
 261     foreach my $dir (@elems) {
 262         my $found = 0;
 263         foreach ($g->ls ($path)) {
 264             if (lc ($_) eq lc ($dir)) {
 265                 if ($path eq "/") {
 266                     $path = "/$_";
 267                     $found = 1;
 268                 } else {
 269                     $path = "$path/$_";
 270                     $found = 1;
 271                 }
 272             }
 273         }
 274         return undef unless $found;
 275     }
 276
 277     return $path;
 278 }
 279
 280 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
 281
 282 The functions in this section can be used to inspect the operating
 283 system(s) available inside a virtual machine image.  For example, you
 284 can find out if the VM is Linux or Windows, how the partitions are
 285 meant to be mounted, and what applications are installed.
 286
 287 If you just want a simple command-line interface to this
 288 functionality, use the L<virt-inspector(1)> tool.  The documentation
 289 below covers the case where you want to access this functionality from
 290 a Perl program.
 291
 292 Once you have the list of partitions (from C<get_partitions>) there
 293 are several steps involved:
 294
 295 =over 4
 296
 297 =item 1.
 298
 299 Look at each partition separately and find out what is on it.
 300
 301 The information you get back includes whether the partition contains a
 302 filesystem or swapspace, what sort of filesystem (eg. ext3, ntfs), and
 303 a first pass guess at the content of the filesystem (eg. Linux boot,
 304 Windows root).
 305
 306 The result of this step is a C<%fs> hash of information, one hash for
 307 each partition.
 308
 309 See: C<inspect_partition>, C<inspect_all_partitions>
 310
 311 =item 2.
 312
 313 Work out the relationship between partitions.
 314
 315 In this step we work out how partitions are related to each other.  In
 316 the case of a single-boot VM, we work out how the partitions are
 317 mounted in respect of each other (eg. C</dev/sda1> is mounted as
 318 C</boot>).  In the case of a multi-boot VM where there are several
 319 roots, we may identify several operating system roots, and mountpoints
 320 can even be shared.
 321
 322 The result of this step is a single hash called C<%oses> which is
 323 described in more detail below, but at the top level looks like:
 324
 325  %oses = {
 326    '/dev/VG/Root1' => \%os1,
 327    '/dev/VG/Root2' => \%os2,
 328  }
 329
 330  %os1 = {
 331    os => 'linux',
 332    mounts => {
 333      '/' => '/dev/VG/Root1',
 334      '/boot' => '/dev/sda1',
 335    },
 336    ...
 337  }
 338
 339 (example shows a multi-boot VM containing two root partitions).
 340
 341 See: C<inspect_operating_systems>
 342
 343 =item 3.
 344
 345 Mount up the disks.
 346
 347 Previous to this point we've essentially been looking at each
 348 partition in isolation.  Now we construct a true guest filesystem by
 349 mounting up all of the disks.  Only once everything is mounted up can
 350 we run commands in the OS context to do more detailed inspection.
 351
 352 See: C<mount_operating_system>
 353
 354 =item 4.
 355
 356 Check for kernels and applications.
 357
 358 This step now does more detailed inspection, where we can look for
 359 kernels, applications and more installed in the guest.
 360
 361 The result of this is an enhanced C<%os> hash.
 362
 363 See: C<inspect_in_detail>
 364
 365 =item 5.
 366
 367 Generate output.
 368
 369 This library does not contain functions for generating output based on
 370 the analysis steps above.  Use a command line tool such as
 371 L<virt-inspector(1)> to get useful output.
 372
 373 =back
 374
 375 =head2 inspect_all_partitions
 376
 377  %fses = inspect_all_partitions ($g, \@partitions);
 378
 379  %fses = inspect_all_partitions ($g, \@partitions, use_windows_registry => 1);
 380
 381 This calls C<inspect_partition> for each partition in the list
 382 C<@partitions>.
 383
 384 The result is a hash which maps partition name to C<\%fs> hashref.
 385
 386 The contents of the C<%fs> hash and the meaning of the
 387 C<use_windows_registry> flag are explained below.
 388
 389 =cut
 390
 391 sub inspect_all_partitions
 392 {
 393     local $_;
 394     my $g = shift;
 395     my $parts = shift;
 396     my @parts = @$parts;
 397     return map { $_ => inspect_partition ($g, $_, @_) } @parts;
 398 }
 399
 400 =head2 inspect_partition
 401
 402  \%fs = inspect_partition ($g, $partition);
 403
 404  \%fs = inspect_partition ($g, $partition, use_windows_registry => 1);
 405
 406 This function inspects the device named C<$partition> in isolation and
 407 tries to determine what it is.  It returns information such as whether
 408 the partition is formatted, and with what, whether it is mountable,
 409 and what it appears to contain (eg. a Windows root, or a Linux /usr).
 410
 411 If C<use_windows_registry> is set to 1, then we will try to download
 412 and parse the content of the Windows registry (for Windows root
 413 devices).  However since this is an expensive and error-prone
 414 operation, we don't do this by default.  It also requires the external
 415 program C<reged>, patched to remove numerous crashing bugs in the
 416 upstream version.
 417
 418 The returned value is a hashref C<\%fs> which may contain the
 419 following top-level keys (any key can be missing):
 420
 421 =over 4
 422
 423 =item fstype
 424
 425 Filesystem type, eg. "ext2" or "ntfs"
 426
 427 =item fsos
 428
 429 Apparent filesystem OS, eg. "linux" or "windows"
 430
 431 =item is_swap
 432
 433 If set, the partition is a swap partition.
 434
 435 =item uuid
 436
 437 Filesystem UUID.
 438
 439 =item label
 440
 441 Filesystem label.
 442
 443 =item is_mountable
 444
 445 If set, the partition could be mounted by libguestfs.
 446
 447 =item content
 448
 449 Filesystem content, if we could determine it.  One of: "linux-grub",
 450 "linux-root", "linux-usrlocal", "linux-usr", "windows-root".
 451
 452 =item osdistro
 453
 454 (For Linux root partitions only).
 455 Operating system distribution.  One of: "fedora", "redhat",
 456 "debian".
 457
 458 =item osversion
 459
 460 (For root partitions only).
 461 Operating system version.
 462
 463 =item fstab
 464
 465 (For Linux root partitions only).
 466 The contents of the C</etc/fstab> file.
 467
 468 =item boot_ini
 469
 470 (For Windows root partitions only).
 471 The contents of the C</boot.ini> (NTLDR) file.
 472
 473 =item registry
 474
 475 The value is an arrayref, which is a list of Windows registry
 476 file contents, in Windows C<.REG> format.
 477
 478 =back
 479
 480 =cut
 481
 482 sub inspect_partition
 483 {
 484     local $_;
 485     my $g = shift;
 486     my $dev = shift;            # LV or partition name.
 487     my %params = @_;
 488
 489     my $use_windows_registry = $params{use_windows_registry};
 490
 491     my %r;                      # Result hash.
 492
 493     # First try 'file(1)' on it.
 494     my $file = $g->file ($dev);
 495     if ($file =~ /ext2 filesystem data/) {
 496         $r{fstype} = "ext2";
 497         $r{fsos} = "linux";
 498     } elsif ($file =~ /ext3 filesystem data/) {
 499         $r{fstype} = "ext3";
 500         $r{fsos} = "linux";
 501     } elsif ($file =~ /ext4 filesystem data/) {
 502         $r{fstype} = "ext4";
 503         $r{fsos} = "linux";
 504     } elsif ($file =~ m{Linux/i386 swap file}) {
 505         $r{fstype} = "swap";
 506         $r{fsos} = "linux";
 507         $r{is_swap} = 1;
 508     }
 509
 510     # If it's ext2/3/4, then we want the UUID and label.
 511     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 512         $r{uuid} = $g->get_e2uuid ($dev);
 513         $r{label} = $g->get_e2label ($dev);
 514     }
 515
 516     # Try mounting it, fnarrr.
 517     if (!$r{is_swap}) {
 518         $r{is_mountable} = 1;
 519         eval { $g->mount_ro ($dev, "/") };
 520         if ($@) {
 521             # It's not mountable, probably empty or some format
 522             # we don't understand.
 523             $r{is_mountable} = 0;
 524             goto OUT;
 525         }
 526
 527         # Grub /boot?
 528         if ($g->is_file ("/grub/menu.lst") ||
 529             $g->is_file ("/grub/grub.conf")) {
 530             $r{content} = "linux-grub";
 531             check_grub ($g, \%r);
 532             goto OUT;
 533         }
 534
 535         # Linux root?
 536         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 537             $g->is_file ("/etc/fstab")) {
 538             $r{content} = "linux-root";
 539             $r{is_root} = 1;
 540             check_linux_root ($g, \%r);
 541             goto OUT;
 542         }
 543
 544         # Linux /usr/local.
 545         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 546             $g->is_dir ("/share") && !$g->exists ("/local") &&
 547             !$g->is_file ("/etc/fstab")) {
 548             $r{content} = "linux-usrlocal";
 549             goto OUT;
 550         }
 551
 552         # Linux /usr.
 553         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 554             $g->is_dir ("/share") && $g->exists ("/local") &&
 555             !$g->is_file ("/etc/fstab")) {
 556             $r{content} = "linux-usr";
 557             goto OUT;
 558         }
 559
 560         # Windows root?
 561         if ($g->is_file ("/AUTOEXEC.BAT") ||
 562             $g->is_file ("/autoexec.bat") ||
 563             $g->is_dir ("/Program Files") ||
 564             $g->is_dir ("/WINDOWS") ||
 565             $g->is_file ("/boot.ini") ||
 566             $g->is_file ("/ntldr")) {
 567             $r{fstype} = "ntfs"; # XXX this is a guess
 568             $r{fsos} = "windows";
 569             $r{content} = "windows-root";
 570             $r{is_root} = 1;
 571             check_windows_root ($g, \%r, $use_windows_registry);
 572             goto OUT;
 573         }
 574     }
 575
 576   OUT:
 577     $g->umount_all ();
 578     return \%r;
 579 }
 580
 581 sub check_linux_root
 582 {
 583     local $_;
 584     my $g = shift;
 585     my $r = shift;
 586
 587     # Look into /etc to see if we recognise the operating system.
 588     if ($g->is_file ("/etc/redhat-release")) {
 589         $_ = $g->cat ("/etc/redhat-release");
 590         if (/Fedora release (\d+\.\d+)/) {
 591             $r->{osdistro} = "fedora";
 592             $r->{osversion} = "$1"
 593         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) {
 594             $r->{osdistro} = "redhat";
 595             $r->{osversion} = "$2.$3";
 596         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) {
 597             $r->{osdistro} = "redhat";
 598             $r->{osversion} = "$2";
 599         } else {
 600             $r->{osdistro} = "redhat";
 601         }
 602     } elsif ($g->is_file ("/etc/debian_version")) {
 603         $_ = $g->cat ("/etc/debian_version");
 604         if (/(\d+\.\d+)/) {
 605             $r->{osdistro} = "debian";
 606             $r->{osversion} = "$1";
 607         } else {
 608             $r->{osdistro} = "debian";
 609         }
 610     }
 611
 612     # Parse the contents of /etc/fstab.  This is pretty vital so
 613     # we can determine where filesystems are supposed to be mounted.
 614     eval "\$_ = \$g->cat ('/etc/fstab');";
 615     if (!$@ && $_) {
 616         my @lines = split /\n/;
 617         my @fstab;
 618         foreach (@lines) {
 619             my @fields = split /[ \t]+/;
 620             if (@fields >= 2) {
 621                 my $spec = $fields[0]; # first column (dev/label/uuid)
 622                 my $file = $fields[1]; # second column (mountpoint)
 623                 if ($spec =~ m{^/} ||
 624                     $spec =~ m{^LABEL=} ||
 625                     $spec =~ m{^UUID=} ||
 626                     $file eq "swap") {
 627                     push @fstab, [$spec, $file]
 628                 }
 629             }
 630         }
 631         $r->{fstab} = \@fstab if @fstab;
 632     }
 633 }
 634
 635 # We only support NT.  The control file /boot.ini contains a list of
 636 # Windows installations and their %systemroot%s in a simple text
 637 # format.
 638 #
 639 # XXX We could parse this better.  This won't work if /boot.ini is on
 640 # a different drive from the %systemroot%, and in other unusual cases.
 641
 642 sub check_windows_root
 643 {
 644     local $_;
 645     my $g = shift;
 646     my $r = shift;
 647     my $use_windows_registry = shift;
 648
 649     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 650     $r->{boot_ini} = $boot_ini;
 651
 652     if (defined $r->{boot_ini}) {
 653         $_ = $g->cat ($boot_ini);
 654         my @lines = split /\n/;
 655         my $section;
 656         my $systemroot;
 657         foreach (@lines) {
 658             if (m/\[.*\]/) {
 659                 $section = $1;
 660             } elsif (m/^default=.*?\\(\w+)$/i) {
 661                 $systemroot = $1;
 662                 last;
 663             } elsif (m/\\(\w+)=/) {
 664                 $systemroot = $1;
 665                 last;
 666             }
 667         }
 668
 669         if (defined $systemroot) {
 670             $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 671             if (defined $r->{systemroot} && $use_windows_registry) {
 672                 check_windows_registry ($g, $r, $r->{systemroot});
 673             }
 674         }
 675     }
 676 }
 677
 678 sub check_windows_registry
 679 {
 680     local $_;
 681     my $g = shift;
 682     my $r = shift;
 683     my $systemroot = shift;
 684
 685     # Download the system registry files.  Only download the
 686     # interesting ones, and we don't bother with user profiles at all.
 687
 688     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 689     if (defined $configdir) {
 690         my $softwaredir = resolve_windows_path ($g, "$configdir/software");
 691         if (defined $softwaredir) {
 692             load_windows_registry ($g, $r, $softwaredir,
 693                                    "HKEY_LOCAL_MACHINE\\SOFTWARE");
 694         }
 695         my $systemdir = resolve_windows_path ($g, "$configdir/system");
 696         if (defined $systemdir) {
 697             load_windows_registry ($g, $r, $systemdir,
 698                                    "HKEY_LOCAL_MACHINE\\System");
 699         }
 700     }
 701 }
 702
 703 sub load_windows_registry
 704 {
 705     local $_;
 706     my $g = shift;
 707     my $r = shift;
 708     my $regfile = shift;
 709     my $prefix = shift;
 710
 711     my $dir = tempdir (CLEANUP => 1);
 712
 713     $g->download ($regfile, "$dir/reg");
 714
 715     # 'reged' command is particularly noisy.  Redirect stdout and
 716     # stderr to /dev/null temporarily.
 717     open SAVEOUT, ">&STDOUT";
 718     open SAVEERR, ">&STDERR";
 719     open STDOUT, ">/dev/null";
 720     open STDERR, ">/dev/null";
 721
 722     my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
 723     my $res = system (@cmd);
 724
 725     close STDOUT;
 726     close STDERR;
 727     open STDOUT, ">&SAVEOUT";
 728     open STDERR, ">&SAVEERR";
 729     close SAVEOUT;
 730     close SAVEERR;
 731
 732     unless ($res == 0) {
 733         warn "reged command failed: $?";
 734         return;
 735     }
 736
 737     # Some versions of reged segfault on inputs.  If that happens we
 738     # may get no / partial output file.  Anyway, if it exists, load
 739     # it.
 740     my $content;
 741     unless (open F, "$dir/out") {
 742         warn "no output from reged command: $!";
 743         return;
 744     }
 745     { local $/ = undef; $content = <F>; }
 746     close F;
 747
 748     my @registry = ();
 749     @registry = @{$r->{registry}} if exists $r->{registry};
 750     push @registry, $content;
 751     $r->{registry} = \@registry;
 752 }
 753
 754 sub check_grub
 755 {
 756     local $_;
 757     my $g = shift;
 758     my $r = shift;
 759
 760     # Grub version, if we care.
 761 }
 762
 763 =head2 inspect_operating_systems
 764
 765  \%oses = inspect_operating_systems ($g, \%fses);
 766
 767 This function works out how partitions are related to each other.  In
 768 the case of a single-boot VM, we work out how the partitions are
 769 mounted in respect of each other (eg. C</dev/sda1> is mounted as
 770 C</boot>).  In the case of a multi-boot VM where there are several
 771 roots, we may identify several operating system roots, and mountpoints
 772 can even be shared.
 773
 774 This function returns a hashref C<\%oses> which at the top level looks
 775 like:
 776
 777  %oses = {
 778    '/dev/VG/Root' => \%os,
 779  }
 780
 781 (There can be multiple roots for a multi-boot VM).
 782
 783 The C<\%os> hash contains the following keys (any can be omitted):
 784
 785 =over 4
 786
 787 =item os
 788
 789 Operating system type, eg. "linux", "windows".
 790
 791 =item distro
 792
 793 Operating system distribution, eg. "debian".
 794
 795 =item version
 796
 797 Operating system version, eg. "4.0".
 798
 799 =item root
 800
 801 The value is a reference to the root partition C<%fs> hash.
 802
 803 =item root_device
 804
 805 The value is the name of the root partition (as a string).
 806
 807 =item mounts
 808
 809 Mountpoints.
 810 The value is a hashref like this:
 811
 812  mounts => {
 813    '/' => '/dev/VG/Root',
 814    '/boot' => '/dev/sda1',
 815  }
 816
 817 =item filesystems
 818
 819 Filesystems (including swap devices and unmounted partitions).
 820 The value is a hashref like this:
 821
 822  filesystems => {
 823    '/dev/sda1' => \%fs,
 824    '/dev/VG/Root' => \%fs,
 825    '/dev/VG/Swap' => \%fs,
 826  }
 827
 828 =back
 829
 830 =cut
 831
 832 sub inspect_operating_systems
 833 {
 834     local $_;
 835     my $g = shift;
 836     my $fses = shift;
 837
 838     my %oses = ();
 839
 840     foreach (sort keys %$fses) {
 841         if ($fses->{$_}->{is_root}) {
 842             my %r = (
 843                 root => $fses->{$_},
 844                 root_device => $_
 845                 );
 846             get_os_version ($g, \%r);
 847             assign_mount_points ($g, $fses, \%r);
 848             $oses{$_} = \%r;
 849         }
 850     }
 851
 852     return \%oses;
 853 }
 854
 855 sub get_os_version
 856 {
 857     local $_;
 858     my $g = shift;
 859     my $r = shift;
 860
 861     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 862     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 863     $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
 864 }
 865
 866 sub assign_mount_points
 867 {
 868     local $_;
 869     my $g = shift;
 870     my $fses = shift;
 871     my $r = shift;
 872
 873     $r->{mounts} = { "/" => $r->{root_device} };
 874     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 875
 876     # Use /etc/fstab if we have it to mount the rest.
 877     if (exists $r->{root}->{fstab}) {
 878         my @fstab = @{$r->{root}->{fstab}};
 879         foreach (@fstab) {
 880             my ($spec, $file) = @$_;
 881
 882             my ($dev, $fs) = find_filesystem ($g, $fses, $spec);
 883             if ($dev) {
 884                 $r->{mounts}->{$file} = $dev;
 885                 $r->{filesystems}->{$dev} = $fs;
 886                 if (exists $fs->{used}) {
 887                     $fs->{used}++
 888                 } else {
 889                     $fs->{used} = 1
 890                 }
 891                 $fs->{spec} = $spec;
 892             }
 893         }
 894     }
 895 }
 896
 897 # Find filesystem by device name, LABEL=.. or UUID=..
 898 sub find_filesystem
 899 {
 900     my $g = shift;
 901     my $fses = shift;
 902     local $_ = shift;
 903
 904     if (/^LABEL=(.*)/) {
 905         my $label = $1;
 906         foreach (sort keys %$fses) {
 907             if (exists $fses->{$_}->{label} &&
 908                 $fses->{$_}->{label} eq $label) {
 909                 return ($_, $fses->{$_});
 910             }
 911         }
 912         warn "unknown filesystem label $label\n";
 913         return ();
 914     } elsif (/^UUID=(.*)/) {
 915         my $uuid = $1;
 916         foreach (sort keys %$fses) {
 917             if (exists $fses->{$_}->{uuid} &&
 918                 $fses->{$_}->{uuid} eq $uuid) {
 919                 return ($_, $fses->{$_});
 920             }
 921         }
 922         warn "unknown filesystem UUID $uuid\n";
 923         return ();
 924     } else {
 925         return ($_, $fses->{$_}) if exists $fses->{$_};
 926
 927         # The following is to handle the case where an fstab entry specifies a
 928         # specific device rather than its label or uuid, and the libguestfs
 929         # appliance has named the device differently due to the use of a
 930         # different driver.
 931         # This will work as long as the underlying drivers recognise devices in
 932         # the same order.
 933         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
 934             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 935         }
 936         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
 937             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 938         }
 939         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
 940             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
 941         }
 942
 943         return () if m{/dev/cdrom};
 944
 945         warn "unknown filesystem $_\n";
 946         return ();
 947     }
 948 }
 949
 950 =head2 mount_operating_system
 951
 952  mount_operating_system ($g, \%os);
 953
 954 This function mounts the operating system described in the
 955 C<%os> hash according to the C<mounts> table in that hash (see
 956 C<inspect_operating_systems>).
 957
 958 The partitions are mounted read-only.
 959
 960 To reverse the effect of this call, use the standard
 961 libguestfs API call C<$g-E<gt>umount_all ()>.
 962
 963 =cut
 964
 965 sub mount_operating_system
 966 {
 967     local $_;
 968     my $g = shift;
 969     my $os = shift;
 970
 971     my $mounts = $os->{mounts};
 972
 973     # Have to mount / first.  Luckily '/' is early in the ASCII
 974     # character set, so this should be OK.
 975     foreach (sort keys %$mounts) {
 976         $g->mount_ro ($mounts->{$_}, $_)
 977             if $_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_));
 978     }
 979 }
 980
 981 =head2 inspect_in_detail
 982
 983  mount_operating_system ($g, \%os);
 984  inspect_in_detail ($g, \%os);
 985  $g->umount_all ();
 986
 987 The C<inspect_in_detail> function inspects the mounted operating
 988 system for installed applications, installed kernels, kernel modules
 989 and more.
 990
 991 It adds extra keys to the existing C<%os> hash reflecting what it
 992 finds.  These extra keys are:
 993
 994 =over 4
 995
 996 =item apps
 997
 998 List of applications.
 999
1000 =item kernels
1001
1002 List of kernels.
1003
1004 =item modprobe_aliases
1005
1006 (For Linux VMs).
1007 The contents of the modprobe configuration.
1008
1009 =item initrd_modules
1010
1011 (For Linux VMs).
1012 The kernel modules installed in the initrd.  The value is
1013 a hashref of kernel version to list of modules.
1014
1015 =back
1016
1017 =cut
1018
1019 sub inspect_in_detail
1020 {
1021     local $_;
1022     my $g = shift;
1023     my $os = shift;
1024
1025     check_for_applications ($g, $os);
1026     check_for_kernels ($g, $os);
1027     if ($os->{os} eq "linux") {
1028         check_for_modprobe_aliases ($g, $os);
1029         check_for_initrd ($g, $os);
1030     }
1031 }
1032
1033 sub check_for_applications
1034 {
1035     local $_;
1036     my $g = shift;
1037     my $os = shift;
1038
1039     my @apps;
1040
1041     my $osn = $os->{os};
1042     if ($osn eq "linux") {
1043         my $distro = $os->{distro};
1044         if (defined $distro && ($distro eq "redhat" || $distro eq "fedora")) {
1045             my @lines = $g->command_lines
1046                 (["rpm",
1047                   "-q", "-a",
1048                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1049             foreach (@lines) {
1050                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1051                     my $epoch = $2;
1052                     $epoch = "" if $epoch eq "(none)";
1053                     my $app = {
1054                         name => $1,
1055                         epoch => $epoch,
1056                         version => $3,
1057                         release => $4,
1058                         arch => $5
1059                     };
1060                     push @apps, $app
1061                 }
1062             }
1063         }
1064     } elsif ($osn eq "windows") {
1065         # XXX
1066         # I worked out a general plan for this, but haven't
1067         # implemented it yet.  We can iterate over /Program Files
1068         # looking for *.EXE files, which we download, then use
1069         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1070         # section, which has a lot of useful information.
1071     }
1072
1073     $os->{apps} = \@apps;
1074 }
1075
1076 sub check_for_kernels
1077 {
1078     local $_;
1079     my $g = shift;
1080     my $os = shift;
1081
1082     my @kernels;
1083
1084     my $osn = $os->{os};
1085     if ($osn eq "linux") {
1086         # Installed kernels will have a corresponding /lib/modules/<version>
1087         # directory, which is the easiest way to find out what kernels
1088         # are installed, and what modules are available.
1089         foreach ($g->ls ("/lib/modules")) {
1090             if ($g->is_dir ("/lib/modules/$_")) {
1091                 my %kernel;
1092                 $kernel{version} = $_;
1093
1094                 # List modules.
1095                 my @modules;
1096                 foreach ($g->find ("/lib/modules/$_")) {
1097                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
1098                         push @modules, $1;
1099                     }
1100                 }
1101
1102                 $kernel{modules} = \@modules;
1103
1104                 push @kernels, \%kernel;
1105             }
1106         }
1107
1108     } elsif ($osn eq "windows") {
1109         # XXX
1110     }
1111
1112     $os->{kernels} = \@kernels;
1113 }
1114
1115 # Check /etc/modprobe.conf to see if there are any specified
1116 # drivers associated with network (ethX) or hard drives.  Normally
1117 # one might find something like:
1118 #
1119 #  alias eth0 xennet
1120 #  alias scsi_hostadapter xenblk
1121 #
1122 # XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
1123
1124 sub check_for_modprobe_aliases
1125 {
1126     local $_;
1127     my $g = shift;
1128     my $os = shift;
1129
1130     # Initialise augeas
1131     my $success = 0;
1132     $success = $g->aug_init("/", 16);
1133
1134     # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens
1135     my @results;
1136     @results = $g->aug_match("/augeas/load/Modprobe/incl");
1137
1138     # Calculate the next index of /augeas/load/Modprobe/incl
1139     my $i = 1;
1140     foreach ( @results ) {
1141         next unless m{/augeas/load/Modprobe/incl\[(\d*)]};
1142         $i = $1 + 1 if ($1 == $i);
1143     }
1144
1145     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1146                            "/etc/modules.conf");
1147     $i++;
1148     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1149                                   "/etc/conf.modules");
1150
1151     # Make augeas reload
1152     $success = $g->aug_load();
1153
1154     my %modprobe_aliases;
1155
1156     for my $pattern qw(/files/etc/conf.modules/alias
1157                        /files/etc/modules.conf/alias
1158                        /files/etc/modprobe.conf/alias
1159                        /files/etc/modprobe.d/*/alias) {
1160         @results = $g->aug_match($pattern);
1161
1162         for my $path ( @results ) {
1163             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1164                 or die("$path doesn't match augeas pattern");
1165             my $file = $1;
1166
1167             my $alias;
1168             $alias = $g->aug_get($path);
1169
1170             my $modulename;
1171             $modulename = $g->aug_get($path.'/modulename');
1172
1173             my %aliasinfo;
1174             $aliasinfo{modulename} = $modulename;
1175             $aliasinfo{augeas} = $path;
1176             $aliasinfo{file} = $file;
1177
1178             $modprobe_aliases{$alias} = \%aliasinfo;
1179         }
1180     }
1181
1182     $os->{modprobe_aliases} = \%modprobe_aliases;
1183 }
1184
1185 # Get a listing of device drivers in any initrd corresponding to a
1186 # kernel.  This is an indication of what can possibly be booted.
1187
1188 sub check_for_initrd
1189 {
1190     local $_;
1191     my $g = shift;
1192     my $os = shift;
1193
1194     my %initrd_modules;
1195
1196     foreach my $initrd ($g->ls ("/boot")) {
1197         if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
1198             my $version = $1;
1199             my @modules;
1200
1201             eval {
1202                 @modules = $g->initrd_list ("/boot/$initrd");
1203             };
1204             unless ($@) {
1205                 @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, } @modules;
1206                 $initrd_modules{$version} = \@modules
1207             } else {
1208                 warn "/boot/$initrd: could not read initrd format"
1209             }
1210         }
1211     }
1212
1213     $os->{initrd_modules} = \%initrd_modules;
1214 }
1215
1216
1217 1;
1218
1219 =head1 COPYRIGHT
1220
1221 Copyright (C) 2009 Red Hat Inc.
1222
1223 =head1 LICENSE
1224
1225 Please see the file COPYING.LIB for the full license.
1226
1227 =head1 SEE ALSO
1228
1229 L<virt-inspector(1)>,
1230 L<Sys::Guestfs(3)>,
1231 L<guestfs(3)>,
1232 L<http://libguestfs.org/>,
1233 L<Sys::Virt(3)>,
1234 L<http://libvirt.org/>,
1235 L<guestfish(1)>.
1236
1237 =cut