perl/lib/Sys/Guestfs/Lib.pm

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