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