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", "rhel", "centos",
 479 "scientific", "debian".
 480
 481 =item package_format
 482
 483 (For Linux root partitions only)
 484 The package format used by the guest distribution. One of: "rpm", "dpkg".
 485
 486 =item package_management
 487
 488 (For Linux root partitions only)
 489 The package management tool used by the guest distribution. One of: "rhn",
 490 "yum", "apt".
 491
 492 =item osversion
 493
 494 (For root partitions only).
 495 Operating system version.
 496
 497 =item fstab
 498
 499 (For Linux root partitions only).
 500 The contents of the C</etc/fstab> file.
 501
 502 =item boot_ini
 503
 504 (For Windows root partitions only).
 505 The contents of the C</boot.ini> (NTLDR) file.
 506
 507 =item registry
 508
 509 The value is an arrayref, which is a list of Windows registry
 510 file contents, in Windows C<.REG> format.
 511
 512 =back
 513
 514 =cut
 515
 516 sub inspect_partition
 517 {
 518     local $_;
 519     my $g = shift;
 520     my $dev = shift;            # LV or partition name.
 521     my %params = @_;
 522
 523     my $use_windows_registry = $params{use_windows_registry};
 524
 525     my %r;                      # Result hash.
 526
 527     # First try 'file(1)' on it.
 528     my $file = $g->file ($dev);
 529     if ($file =~ /ext2 filesystem data/) {
 530         $r{fstype} = "ext2";
 531         $r{fsos} = "linux";
 532     } elsif ($file =~ /ext3 filesystem data/) {
 533         $r{fstype} = "ext3";
 534         $r{fsos} = "linux";
 535     } elsif ($file =~ /ext4 filesystem data/) {
 536         $r{fstype} = "ext4";
 537         $r{fsos} = "linux";
 538     } elsif ($file =~ m{Linux/i386 swap file}) {
 539         $r{fstype} = "swap";
 540         $r{fsos} = "linux";
 541         $r{is_swap} = 1;
 542     }
 543
 544     # If it's ext2/3/4, then we want the UUID and label.
 545     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 546         $r{uuid} = $g->get_e2uuid ($dev);
 547         $r{label} = $g->get_e2label ($dev);
 548     }
 549
 550     # Try mounting it, fnarrr.
 551     if (!$r{is_swap}) {
 552         $r{is_mountable} = 1;
 553         eval { $g->mount_ro ($dev, "/") };
 554         if ($@) {
 555             # It's not mountable, probably empty or some format
 556             # we don't understand.
 557             $r{is_mountable} = 0;
 558             goto OUT;
 559         }
 560
 561         # Grub /boot?
 562         if ($g->is_file ("/grub/menu.lst") ||
 563             $g->is_file ("/grub/grub.conf")) {
 564             $r{content} = "linux-grub";
 565             _check_grub ($g, \%r);
 566             goto OUT;
 567         }
 568
 569         # Linux root?
 570         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 571             $g->is_file ("/etc/fstab")) {
 572             $r{content} = "linux-root";
 573             $r{is_root} = 1;
 574             _check_linux_root ($g, \%r);
 575             goto OUT;
 576         }
 577
 578         # Linux /usr/local.
 579         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 580             $g->is_dir ("/share") && !$g->exists ("/local") &&
 581             !$g->is_file ("/etc/fstab")) {
 582             $r{content} = "linux-usrlocal";
 583             goto OUT;
 584         }
 585
 586         # Linux /usr.
 587         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 588             $g->is_dir ("/share") && $g->exists ("/local") &&
 589             !$g->is_file ("/etc/fstab")) {
 590             $r{content} = "linux-usr";
 591             goto OUT;
 592         }
 593
 594         # Windows root?
 595         if ($g->is_file ("/AUTOEXEC.BAT") ||
 596             $g->is_file ("/autoexec.bat") ||
 597             $g->is_dir ("/Program Files") ||
 598             $g->is_dir ("/WINDOWS") ||
 599             $g->is_file ("/boot.ini") ||
 600             $g->is_file ("/ntldr")) {
 601             $r{fstype} = "ntfs"; # XXX this is a guess
 602             $r{fsos} = "windows";
 603             $r{content} = "windows-root";
 604             $r{is_root} = 1;
 605             _check_windows_root ($g, \%r, $use_windows_registry);
 606             goto OUT;
 607         }
 608     }
 609
 610   OUT:
 611     $g->umount_all ();
 612     return \%r;
 613 }
 614
 615 sub _check_linux_root
 616 {
 617     local $_;
 618     my $g = shift;
 619     my $r = shift;
 620
 621     # Look into /etc to see if we recognise the operating system.
 622     if ($g->is_file ("/etc/redhat-release")) {
 623         $r->{package_format} = "rpm";
 624
 625         $_ = $g->cat ("/etc/redhat-release");
 626         if (/Fedora release (\d+\.\d+)/) {
 627             $r->{osdistro} = "fedora";
 628             $r->{osversion} = "$1";
 629             $r->{package_management} = "yum";
 630         }
 631
 632         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
 633             my $distro = $1;
 634
 635             if($distro eq "Red Hat Enterprise Linux") {
 636                 $r->{osdistro} = "rhel";
 637             }
 638
 639             elsif($distro eq "CentOS") {
 640                 $r->{osdistro} = "centos";
 641                 $r->{package_management} = "yum";
 642             }
 643
 644             elsif($distro eq "Scientific Linux") {
 645                 $r->{osdistro} = "scientific";
 646                 $r->{package_management} = "yum";
 647             }
 648
 649             # Shouldn't be possible
 650             else { die };
 651
 652             if (/$distro.*release (\d+).*Update (\d+)/) {
 653                 $r->{osversion} = "$1.$2";
 654             }
 655
 656             elsif (/$distro.*release (\d+(?:\.(?:\d+))?)/) {
 657                 $r->{osversion} = "$1";
 658             }
 659
 660             # Package management in RHEL changed in version 5
 661             if ($r->{osdistro} eq "rhel") {
 662                 if ($r->{osversion} >= 5) {
 663                     $r->{package_management} = "yum";
 664                 } else {
 665                     $r->{package_management} = "rhn";
 666                 }
 667             }
 668         }
 669
 670         else {
 671             $r->{osdistro} = "redhat-based";
 672         }
 673     } elsif ($g->is_file ("/etc/debian_version")) {
 674         $r->{package_format} = "dpkg";
 675         $r->{package_management} = "apt";
 676
 677         $_ = $g->cat ("/etc/debian_version");
 678         if (/(\d+\.\d+)/) {
 679             $r->{osdistro} = "debian";
 680             $r->{osversion} = "$1";
 681         } else {
 682             $r->{osdistro} = "debian";
 683         }
 684     }
 685
 686     # Parse the contents of /etc/fstab.  This is pretty vital so
 687     # we can determine where filesystems are supposed to be mounted.
 688     eval "\$_ = \$g->cat ('/etc/fstab');";
 689     if (!$@ && $_) {
 690         my @lines = split /\n/;
 691         my @fstab;
 692         foreach (@lines) {
 693             my @fields = split /[ \t]+/;
 694             if (@fields >= 2) {
 695                 my $spec = $fields[0]; # first column (dev/label/uuid)
 696                 my $file = $fields[1]; # second column (mountpoint)
 697                 if ($spec =~ m{^/} ||
 698                     $spec =~ m{^LABEL=} ||
 699                     $spec =~ m{^UUID=} ||
 700                     $file eq "swap") {
 701                     push @fstab, [$spec, $file]
 702                 }
 703             }
 704         }
 705         $r->{fstab} = \@fstab if @fstab;
 706     }
 707 }
 708
 709 # We only support NT.  The control file /boot.ini contains a list of
 710 # Windows installations and their %systemroot%s in a simple text
 711 # format.
 712 #
 713 # XXX We could parse this better.  This won't work if /boot.ini is on
 714 # a different drive from the %systemroot%, and in other unusual cases.
 715
 716 sub _check_windows_root
 717 {
 718     local $_;
 719     my $g = shift;
 720     my $r = shift;
 721     my $use_windows_registry = shift;
 722
 723     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 724     $r->{boot_ini} = $boot_ini;
 725
 726     if (defined $r->{boot_ini}) {
 727         $_ = $g->cat ($boot_ini);
 728         my @lines = split /\n/;
 729         my $section;
 730         my $systemroot;
 731         foreach (@lines) {
 732             if (m/\[.*\]/) {
 733                 $section = $1;
 734             } elsif (m/^default=.*?\\(\w+)$/i) {
 735                 $systemroot = $1;
 736                 last;
 737             } elsif (m/\\(\w+)=/) {
 738                 $systemroot = $1;
 739                 last;
 740             }
 741         }
 742
 743         if (defined $systemroot) {
 744             $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 745             if (defined $r->{systemroot} && $use_windows_registry) {
 746                 _check_windows_registry ($g, $r, $r->{systemroot});
 747             }
 748         }
 749     }
 750 }
 751
 752 sub _check_windows_registry
 753 {
 754     local $_;
 755     my $g = shift;
 756     my $r = shift;
 757     my $systemroot = shift;
 758
 759     # Download the system registry files.  Only download the
 760     # interesting ones, and we don't bother with user profiles at all.
 761
 762     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 763     if (defined $configdir) {
 764         my $softwaredir = resolve_windows_path ($g, "$configdir/software");
 765         if (defined $softwaredir) {
 766             _load_windows_registry ($g, $r, $softwaredir,
 767                                     "HKEY_LOCAL_MACHINE\\SOFTWARE");
 768         }
 769         my $systemdir = resolve_windows_path ($g, "$configdir/system");
 770         if (defined $systemdir) {
 771             _load_windows_registry ($g, $r, $systemdir,
 772                                     "HKEY_LOCAL_MACHINE\\System");
 773         }
 774     }
 775 }
 776
 777 sub _load_windows_registry
 778 {
 779     local $_;
 780     my $g = shift;
 781     my $r = shift;
 782     my $regfile = shift;
 783     my $prefix = shift;
 784
 785     my $dir = tempdir (CLEANUP => 1);
 786
 787     $g->download ($regfile, "$dir/reg");
 788
 789     # 'reged' command is particularly noisy.  Redirect stdout and
 790     # stderr to /dev/null temporarily.
 791     open SAVEOUT, ">&STDOUT";
 792     open SAVEERR, ">&STDERR";
 793     open STDOUT, ">/dev/null";
 794     open STDERR, ">/dev/null";
 795
 796     my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
 797     my $res = system (@cmd);
 798
 799     close STDOUT;
 800     close STDERR;
 801     open STDOUT, ">&SAVEOUT";
 802     open STDERR, ">&SAVEERR";
 803     close SAVEOUT;
 804     close SAVEERR;
 805
 806     unless ($res == 0) {
 807         warn __x("reged command failed: {errormsg}", errormsg => $?);
 808         return;
 809     }
 810
 811     # Some versions of reged segfault on inputs.  If that happens we
 812     # may get no / partial output file.  Anyway, if it exists, load
 813     # it.
 814     my $content;
 815     unless (open F, "$dir/out") {
 816         warn __x("no output from reged command: {errormsg}", errormsg => $!);
 817         return;
 818     }
 819     { local $/ = undef; $content = <F>; }
 820     close F;
 821
 822     my @registry = ();
 823     @registry = @{$r->{registry}} if exists $r->{registry};
 824     push @registry, $content;
 825     $r->{registry} = \@registry;
 826 }
 827
 828 sub _check_grub
 829 {
 830     local $_;
 831     my $g = shift;
 832     my $r = shift;
 833
 834     # Grub version, if we care.
 835 }
 836
 837 =head2 inspect_operating_systems
 838
 839  \%oses = inspect_operating_systems ($g, \%fses);
 840
 841 This function works out how partitions are related to each other.  In
 842 the case of a single-boot VM, we work out how the partitions are
 843 mounted in respect of each other (eg. C</dev/sda1> is mounted as
 844 C</boot>).  In the case of a multi-boot VM where there are several
 845 roots, we may identify several operating system roots, and mountpoints
 846 can even be shared.
 847
 848 This function returns a hashref C<\%oses> which at the top level looks
 849 like:
 850
 851  %oses = {
 852    '/dev/VG/Root' => \%os,
 853  }
 854
 855 (There can be multiple roots for a multi-boot VM).
 856
 857 The C<\%os> hash contains the following keys (any can be omitted):
 858
 859 =over 4
 860
 861 =item os
 862
 863 Operating system type, eg. "linux", "windows".
 864
 865 =item distro
 866
 867 Operating system distribution, eg. "debian".
 868
 869 =item version
 870
 871 Operating system version, eg. "4.0".
 872
 873 =item root
 874
 875 The value is a reference to the root partition C<%fs> hash.
 876
 877 =item root_device
 878
 879 The value is the name of the root partition (as a string).
 880
 881 =item mounts
 882
 883 Mountpoints.
 884 The value is a hashref like this:
 885
 886  mounts => {
 887    '/' => '/dev/VG/Root',
 888    '/boot' => '/dev/sda1',
 889  }
 890
 891 =item filesystems
 892
 893 Filesystems (including swap devices and unmounted partitions).
 894 The value is a hashref like this:
 895
 896  filesystems => {
 897    '/dev/sda1' => \%fs,
 898    '/dev/VG/Root' => \%fs,
 899    '/dev/VG/Swap' => \%fs,
 900  }
 901
 902 =back
 903
 904 =cut
 905
 906 sub inspect_operating_systems
 907 {
 908     local $_;
 909     my $g = shift;
 910     my $fses = shift;
 911
 912     my %oses = ();
 913
 914     foreach (sort keys %$fses) {
 915         if ($fses->{$_}->{is_root}) {
 916             my %r = (
 917                 root => $fses->{$_},
 918                 root_device => $_
 919                 );
 920             _get_os_version ($g, \%r);
 921             _assign_mount_points ($g, $fses, \%r);
 922             $oses{$_} = \%r;
 923         }
 924     }
 925
 926     return \%oses;
 927 }
 928
 929 sub _get_os_version
 930 {
 931     local $_;
 932     my $g = shift;
 933     my $r = shift;
 934
 935     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 936     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 937     $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
 938     $r->{package_format} = $r->{root}->{package_format}
 939         if exists $r->{root}->{package_format};
 940     $r->{package_management} = $r->{root}->{package_management}
 941         if exists $r->{root}->{package_management};
 942 }
 943
 944 sub _assign_mount_points
 945 {
 946     local $_;
 947     my $g = shift;
 948     my $fses = shift;
 949     my $r = shift;
 950
 951     $r->{mounts} = { "/" => $r->{root_device} };
 952     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 953
 954     # Use /etc/fstab if we have it to mount the rest.
 955     if (exists $r->{root}->{fstab}) {
 956         my @fstab = @{$r->{root}->{fstab}};
 957         foreach (@fstab) {
 958             my ($spec, $file) = @$_;
 959
 960             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
 961             if ($dev) {
 962                 $r->{mounts}->{$file} = $dev;
 963                 $r->{filesystems}->{$dev} = $fs;
 964                 if (exists $fs->{used}) {
 965                     $fs->{used}++
 966                 } else {
 967                     $fs->{used} = 1
 968                 }
 969                 $fs->{spec} = $spec;
 970             }
 971         }
 972     }
 973 }
 974
 975 # Find filesystem by device name, LABEL=.. or UUID=..
 976 sub _find_filesystem
 977 {
 978     my $g = shift;
 979     my $fses = shift;
 980     local $_ = shift;
 981
 982     if (/^LABEL=(.*)/) {
 983         my $label = $1;
 984         foreach (sort keys %$fses) {
 985             if (exists $fses->{$_}->{label} &&
 986                 $fses->{$_}->{label} eq $label) {
 987                 return ($_, $fses->{$_});
 988             }
 989         }
 990         warn __x("unknown filesystem label {label}\n", label => $label);
 991         return ();
 992     } elsif (/^UUID=(.*)/) {
 993         my $uuid = $1;
 994         foreach (sort keys %$fses) {
 995             if (exists $fses->{$_}->{uuid} &&
 996                 $fses->{$_}->{uuid} eq $uuid) {
 997                 return ($_, $fses->{$_});
 998             }
 999         }
1000         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1001         return ();
1002     } else {
1003         return ($_, $fses->{$_}) if exists $fses->{$_};
1004
1005         # The following is to handle the case where an fstab entry specifies a
1006         # specific device rather than its label or uuid, and the libguestfs
1007         # appliance has named the device differently due to the use of a
1008         # different driver.
1009         # This will work as long as the underlying drivers recognise devices in
1010         # the same order.
1011         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1012             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1013         }
1014         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1015             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1016         }
1017         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1018             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1019         }
1020
1021         return () if m{/dev/cdrom};
1022
1023         warn __x("unknown filesystem {fs}\n", fs => $_);
1024         return ();
1025     }
1026 }
1027
1028 =head2 mount_operating_system
1029
1030  mount_operating_system ($g, \%os);
1031
1032 This function mounts the operating system described in the
1033 C<%os> hash according to the C<mounts> table in that hash (see
1034 C<inspect_operating_systems>).
1035
1036 The partitions are mounted read-only.
1037
1038 To reverse the effect of this call, use the standard
1039 libguestfs API call C<$g-E<gt>umount_all ()>.
1040
1041 =cut
1042
1043 sub mount_operating_system
1044 {
1045     local $_;
1046     my $g = shift;
1047     my $os = shift;
1048
1049     my $mounts = $os->{mounts};
1050
1051     # Have to mount / first.  Luckily '/' is early in the ASCII
1052     # character set, so this should be OK.
1053     foreach (sort keys %$mounts) {
1054         $g->mount_ro ($mounts->{$_}, $_)
1055             if $_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_));
1056     }
1057 }
1058
1059 =head2 inspect_in_detail
1060
1061  mount_operating_system ($g, \%os);
1062  inspect_in_detail ($g, \%os);
1063  $g->umount_all ();
1064
1065 The C<inspect_in_detail> function inspects the mounted operating
1066 system for installed applications, installed kernels, kernel modules
1067 and more.
1068
1069 It adds extra keys to the existing C<%os> hash reflecting what it
1070 finds.  These extra keys are:
1071
1072 =over 4
1073
1074 =item apps
1075
1076 List of applications.
1077
1078 =item kernels
1079
1080 List of kernels.
1081
1082 =item modprobe_aliases
1083
1084 (For Linux VMs).
1085 The contents of the modprobe configuration.
1086
1087 =item initrd_modules
1088
1089 (For Linux VMs).
1090 The kernel modules installed in the initrd.  The value is
1091 a hashref of kernel version to list of modules.
1092
1093 =back
1094
1095 =cut
1096
1097 sub inspect_in_detail
1098 {
1099     local $_;
1100     my $g = shift;
1101     my $os = shift;
1102
1103     _check_for_applications ($g, $os);
1104     _check_for_kernels ($g, $os);
1105     if ($os->{os} eq "linux") {
1106         _check_for_modprobe_aliases ($g, $os);
1107         _check_for_initrd ($g, $os);
1108     }
1109 }
1110
1111 sub _check_for_applications
1112 {
1113     local $_;
1114     my $g = shift;
1115     my $os = shift;
1116
1117     my @apps;
1118
1119     my $osn = $os->{os};
1120     if ($osn eq "linux") {
1121         my $package_format = $os->{package_format};
1122         if (defined $package_format && $package_format eq "rpm") {
1123             my @lines = $g->command_lines
1124                 (["rpm",
1125                   "-q", "-a",
1126                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1127             foreach (@lines) {
1128                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1129                     my $epoch = $2;
1130                     $epoch = "" if $epoch eq "(none)";
1131                     my $app = {
1132                         name => $1,
1133                         epoch => $epoch,
1134                         version => $3,
1135                         release => $4,
1136                         arch => $5
1137                     };
1138                     push @apps, $app
1139                 }
1140             }
1141         }
1142     } elsif ($osn eq "windows") {
1143         # XXX
1144         # I worked out a general plan for this, but haven't
1145         # implemented it yet.  We can iterate over /Program Files
1146         # looking for *.EXE files, which we download, then use
1147         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1148         # section, which has a lot of useful information.
1149     }
1150
1151     $os->{apps} = \@apps;
1152 }
1153
1154 sub _check_for_kernels
1155 {
1156     local $_;
1157     my $g = shift;
1158     my $os = shift;
1159
1160     my @kernels;
1161
1162     my $osn = $os->{os};
1163     if ($osn eq "linux") {
1164         # Installed kernels will have a corresponding /lib/modules/<version>
1165         # directory, which is the easiest way to find out what kernels
1166         # are installed, and what modules are available.
1167         foreach ($g->ls ("/lib/modules")) {
1168             if ($g->is_dir ("/lib/modules/$_")) {
1169                 my %kernel;
1170                 $kernel{version} = $_;
1171
1172                 # List modules.
1173                 my @modules;
1174                 foreach ($g->find ("/lib/modules/$_")) {
1175                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
1176                         push @modules, $1;
1177                     }
1178                 }
1179
1180                 $kernel{modules} = \@modules;
1181
1182                 push @kernels, \%kernel;
1183             }
1184         }
1185
1186     } elsif ($osn eq "windows") {
1187         # XXX
1188     }
1189
1190     $os->{kernels} = \@kernels;
1191 }
1192
1193 # Check /etc/modprobe.conf to see if there are any specified
1194 # drivers associated with network (ethX) or hard drives.  Normally
1195 # one might find something like:
1196 #
1197 #  alias eth0 xennet
1198 #  alias scsi_hostadapter xenblk
1199 #
1200 # XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
1201
1202 sub _check_for_modprobe_aliases
1203 {
1204     local $_;
1205     my $g = shift;
1206     my $os = shift;
1207
1208     # Initialise augeas
1209     my $success = 0;
1210     $success = $g->aug_init("/", 16);
1211
1212     # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens
1213     my @results;
1214     @results = $g->aug_match("/augeas/load/Modprobe/incl");
1215
1216     # Calculate the next index of /augeas/load/Modprobe/incl
1217     my $i = 1;
1218     foreach ( @results ) {
1219         next unless m{/augeas/load/Modprobe/incl\[(\d*)]};
1220         $i = $1 + 1 if ($1 == $i);
1221     }
1222
1223     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1224                            "/etc/modules.conf");
1225     $i++;
1226     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1227                                   "/etc/conf.modules");
1228
1229     # Make augeas reload
1230     $success = $g->aug_load();
1231
1232     my %modprobe_aliases;
1233
1234     for my $pattern qw(/files/etc/conf.modules/alias
1235                        /files/etc/modules.conf/alias
1236                        /files/etc/modprobe.conf/alias
1237                        /files/etc/modprobe.d/*/alias) {
1238         @results = $g->aug_match($pattern);
1239
1240         for my $path ( @results ) {
1241             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1242                 or die __x("{path} doesn't match augeas pattern",
1243                            path => $path);
1244             my $file = $1;
1245
1246             my $alias;
1247             $alias = $g->aug_get($path);
1248
1249             my $modulename;
1250             $modulename = $g->aug_get($path.'/modulename');
1251
1252             my %aliasinfo;
1253             $aliasinfo{modulename} = $modulename;
1254             $aliasinfo{augeas} = $path;
1255             $aliasinfo{file} = $file;
1256
1257             $modprobe_aliases{$alias} = \%aliasinfo;
1258         }
1259     }
1260
1261     $os->{modprobe_aliases} = \%modprobe_aliases;
1262 }
1263
1264 # Get a listing of device drivers in any initrd corresponding to a
1265 # kernel.  This is an indication of what can possibly be booted.
1266
1267 sub _check_for_initrd
1268 {
1269     local $_;
1270     my $g = shift;
1271     my $os = shift;
1272
1273     my %initrd_modules;
1274
1275     foreach my $initrd ($g->ls ("/boot")) {
1276         if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
1277             my $version = $1;
1278             my @modules;
1279
1280             # Disregard old-style compressed ext2 files, since cpio
1281             # takes ages to (fail to) process these.
1282             if ($g->file ("/boot/$initrd") !~ /gzip compressed/ ||
1283                 $g->zfile ("gzip", "/boot/$initrd") !~ /ext2 filesystem/) {
1284                 eval {
1285                     @modules = $g->initrd_list ("/boot/$initrd");
1286                 };
1287                 unless ($@) {
1288                     @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, }
1289                     @modules;
1290                     $initrd_modules{$version} = \@modules
1291                 } else {
1292                     warn __x("{filename}: could not read initrd format",
1293                              filename => "/boot/$initrd");
1294                 }
1295             }
1296         }
1297     }
1298
1299     $os->{initrd_modules} = \%initrd_modules;
1300 }
1301
1302
1303 1;
1304
1305 =head1 COPYRIGHT
1306
1307 Copyright (C) 2009 Red Hat Inc.
1308
1309 =head1 LICENSE
1310
1311 Please see the file COPYING.LIB for the full license.
1312
1313 =head1 SEE ALSO
1314
1315 L<virt-inspector(1)>,
1316 L<Sys::Guestfs(3)>,
1317 L<guestfs(3)>,
1318 L<http://libguestfs.org/>,
1319 L<Sys::Virt(3)>,
1320 L<http://libvirt.org/>,
1321 L<guestfish(1)>.
1322
1323 =cut