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