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