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