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