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