perl/lib/Sys/Guestfs/Lib.pm

   1 # Sys::Guestfs::Lib
   2 # Copyright (C) 2009-2010 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 # The minor part of this version number is incremented when some
  24 # change is made to this module.  The major part is incremented if we
  25 # make a change which is not backwards compatible.  It is not related
  26 # to the libguestfs version number.
  27 use vars qw($VERSION);
  28 $VERSION = '0.3';
  29
  30 use Carp qw(croak);
  31
  32 use Sys::Guestfs;
  33 use File::Temp qw/tempdir/;
  34 use Locale::TextDomain 'libguestfs';
  35
  36 # Optional:
  37 eval "use Sys::Virt;";
  38 eval "use XML::XPath;";
  39 eval "use XML::XPath::XMLParser;";
  40 eval "use Win::Hivex;";
  41
  42 =pod
  43
  44 =head1 NAME
  45
  46 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
  47
  48 =head1 SYNOPSIS
  49
  50  use Sys::Guestfs::Lib qw(open_guest ...);
  51
  52  $g = open_guest ($name);
  53
  54 =head1 DESCRIPTION
  55
  56 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
  57 the libguestfs API from Perl.  It also provides tighter integration
  58 with libvirt.
  59
  60 The basic libguestfs API is not covered by this manpage.  Please refer
  61 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
  62 also not covered.  For that, see L<Sys::Virt(3)>.
  63
  64 =head1 DEPRECATION OF SOME FUNCTIONS
  65
  66 This module contains functions and code to perform inspection of guest
  67 images.  Since libguestfs 1.5.3 this ability has moved into the core
  68 API (see L<guestfs(3)/INSPECTION>).  The inspection functions in this
  69 module are deprecated and will not be updated.  Each deprecated
  70 function is marked in the documentation below.
  71
  72 =head1 BASIC FUNCTIONS
  73
  74 =cut
  75
  76 require Exporter;
  77
  78 use vars qw(@EXPORT_OK @ISA);
  79
  80 @ISA = qw(Exporter);
  81 @EXPORT_OK = qw(open_guest feature_available
  82   get_partitions resolve_windows_path
  83   inspect_all_partitions inspect_partition
  84   inspect_operating_systems mount_operating_system inspect_in_detail
  85   inspect_linux_kernel);
  86
  87 =head2 open_guest
  88
  89  $g = open_guest ($name);
  90
  91  $g = open_guest ($name, rw => 1, ...);
  92
  93  $g = open_guest ($name, address => $uri, ...);
  94
  95  $g = open_guest ([$img1, $img2, ...], address => $uri, format => $format, ...);
  96
  97  ($g, $conn, $dom, @images) = open_guest ($name);
  98
  99 This function opens a libguestfs handle for either the libvirt domain
 100 called C<$name>, or the disk image called C<$name>.  Any disk images
 101 found through libvirt or specified explicitly are attached to the
 102 libguestfs handle.
 103
 104 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
 105 it throws an exception.  To catch errors, wrap the call in an eval
 106 block.
 107
 108 The first parameter is either a string referring to a libvirt domain
 109 or a disk image, or (if a guest has several disk images) an arrayref
 110 C<[$img1, $img2, ...]>.  For disk images, if the C<format> parameter
 111 is specified then that format is forced.
 112
 113 The handle is I<read-only> by default.  Use the optional parameter
 114 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
 115 read-write handle, this function will refuse to use active libvirt
 116 domains.
 117
 118 The handle is still in the config state when it is returned, so you
 119 have to call C<$g-E<gt>launch ()>.
 120
 121 The optional C<address> parameter can be added to specify the libvirt
 122 URI.
 123
 124 The implicit libvirt handle is closed after this function, I<unless>
 125 you call the function in C<wantarray> context, in which case the
 126 function returns a tuple of: the open libguestfs handle, the open
 127 libvirt handle, and the open libvirt domain handle, and a list of
 128 [image,format] pairs.  (This is useful if you want to do other things
 129 like pulling the XML description of the guest).  Note that if this is
 130 a straight disk image, then C<$conn> and C<$dom> will be C<undef>.
 131
 132 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 133 and this function can only open disk images.
 134
 135 The optional C<interface> parameter can be used to open devices with a
 136 specified qemu interface.  See L<Sys::Guestfs/guestfs_add_drive_opts>
 137 for more details.
 138
 139 =cut
 140
 141 sub open_guest
 142 {
 143     local $_;
 144     my $first = shift;
 145     my %params = @_;
 146
 147     my $rw = $params{rw};
 148     my $address = $params{address};
 149     my $interface = $params{interface};
 150     my $format = $params{format}; # undef == autodetect
 151
 152     my @images = ();
 153     if (ref ($first) eq "ARRAY") {
 154         @images = @$first;
 155     } elsif (ref ($first) eq "SCALAR") {
 156         @images = ($first);
 157     } else {
 158         croak __"open_guest: first parameter must be a string or an arrayref"
 159     }
 160
 161     # Check each element of @images is defined.
 162     # (See https://bugzilla.redhat.com/show_bug.cgi?id=601092#c3).
 163     foreach (@images) {
 164         croak __"open_guest: first argument contains undefined element"
 165             unless defined $_;
 166     }
 167
 168     my ($conn, $dom);
 169
 170     if (-e $images[0]) {
 171         foreach (@images) {
 172             croak __x("guest image {imagename} does not exist or is not readable",
 173                     imagename => $_)
 174                 unless -r $_;
 175         }
 176
 177         @images = map { [ $_, $format ] } @images;
 178     } else {
 179         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
 180             unless exists $INC{"Sys/Virt.pm"} &&
 181             exists $INC{"XML/XPath.pm"} &&
 182             exists $INC{"XML/XPath/XMLParser.pm"};
 183
 184         die __"open_guest: too many domains listed on command line"
 185             if @images > 1;
 186
 187         my @libvirt_args = ();
 188         push @libvirt_args, address => $address if defined $address;
 189
 190         $conn = Sys::Virt->new (readonly => 1, @libvirt_args);
 191         die __"open_guest: cannot connect to libvirt" unless $conn;
 192
 193         my @doms = $conn->list_defined_domains ();
 194         my $isitinactive = 1;
 195         unless ($rw) {
 196             # In the case where we want read-only access to a domain,
 197             # allow the user to specify an active domain too.
 198             push @doms, $conn->list_domains ();
 199             $isitinactive = 0;
 200         }
 201         foreach (@doms) {
 202             if ($_->get_name () eq $images[0]) {
 203                 $dom = $_;
 204                 last;
 205             }
 206         }
 207
 208         unless ($dom) {
 209             if ($isitinactive) {
 210                 die __x("{imagename} is not the name of an inactive libvirt domain\n",
 211                         imagename => $images[0]);
 212             } else {
 213                 die __x("{imagename} is not the name of a libvirt domain\n",
 214                         imagename => $images[0]);
 215             }
 216         }
 217
 218         # Get the names of the image(s).
 219         my $xml = $dom->get_xml_description ();
 220
 221         my $p = XML::XPath->new (xml => $xml);
 222         my $nodes = $p->find ('//devices/disk');
 223
 224         my @disks = ();
 225         my $node;
 226         foreach $node ($nodes->get_nodelist) {
 227             # The filename can be in dev or file attribute, hence:
 228             my $filename = $p->find ('./source/@dev', $node);
 229             unless ($filename) {
 230                 $filename = $p->find ('./source/@file', $node);
 231                 next unless $filename;
 232             }
 233             $filename = $filename->to_literal;
 234
 235             # Get the disk format (may not be set).
 236             my $format = $p->find ('./driver/@type', $node);
 237             $format = $format->to_literal if $format;
 238
 239             push @disks, [ $filename, $format ];
 240         }
 241
 242         die __x("{imagename} seems to have no disk devices\n",
 243                 imagename => $images[0])
 244             unless @disks;
 245
 246         @images = @disks;
 247     }
 248
 249     # We've now got the list of @images, so feed them to libguestfs.
 250     my $g = Sys::Guestfs->new ();
 251     foreach (@images) {
 252         my @args = ($_->[0]);
 253         push @args, format => $_->[1] if defined $_->[1];
 254         push @args, readonly => 1 unless $rw;
 255         push @args, iface => $interface if defined $interface;
 256         $g->add_drive_opts (@args);
 257     }
 258
 259     return wantarray ? ($g, $conn, $dom, @images) : $g
 260 }
 261
 262 =head2 feature_available
 263
 264  $bool = feature_available ($g, $feature [, $feature ...]);
 265
 266 This function is a useful wrapper around the basic
 267 C<$g-E<gt>available> call.
 268
 269 C<$g-E<gt>available> tests for availability of a list of features and
 270 dies with an error if any is not available.
 271
 272 This call tests for the list of features and returns true if all are
 273 available, or false otherwise.
 274
 275 For a list of features you can test for, see L<guestfs(3)/AVAILABILITY>.
 276
 277 =cut
 278
 279 sub feature_available {
 280     my $g = shift;
 281
 282     eval { $g->available (\@_); };
 283     return $@ ? 0 : 1;
 284 }
 285
 286 =head2 get_partitions
 287
 288  @partitions = get_partitions ($g);
 289
 290 This function takes an open libguestfs handle C<$g> and returns all
 291 partitions and logical volumes found on it.
 292
 293 What is returned is everything that could contain a filesystem (or
 294 swap).  Physical volumes are not normally included from the list
 295 except if they contain a filesystem directly.  Nor are devices which
 296 are partitioned (eg. C</dev/sda> would not be returned if C</dev/sda1>
 297 exists).
 298
 299 =cut
 300
 301 sub get_partitions
 302 {
 303     local $_;
 304     my $g = shift;
 305
 306     # Look to see if any devices directly contain filesystems (RHBZ#590167).
 307     my @devices = $g->list_devices ();
 308     my @fses_on_device = ();
 309     foreach (@devices) {
 310         eval { $g->mount_ro ($_, "/"); };
 311         push @fses_on_device, $_ unless $@;
 312         $g->umount_all ();
 313     }
 314
 315     my @partitions = $g->list_partitions ();
 316     my @pvs = $g->pvs ();
 317     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 318
 319     my @lvs;
 320     @lvs = $g->lvs () if feature_available ($g, "lvm2");
 321
 322     return sort (@fses_on_device, @lvs, @partitions);
 323 }
 324
 325 sub _is_pv {
 326     local $_;
 327     my $t = shift;
 328
 329     foreach (@_) {
 330         return 1 if $_ eq $t;
 331     }
 332     0;
 333 }
 334
 335 =head2 resolve_windows_path
 336
 337  $path = resolve_windows_path ($g, $path);
 338
 339  $path = resolve_windows_path ($g, "/windows/system");
 340    ==> "/WINDOWS/System"
 341        or undef if no path exists
 342
 343 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
 344 guests), lets you look up a case insensitive C<$path> in the
 345 filesystem and returns the true, case sensitive path as required by
 346 the underlying kernel or NTFS-3g driver.
 347
 348 If C<$path> does not exist then this function returns C<undef>.
 349
 350 The C<$path> parameter must begin with C</> character and be separated
 351 by C</> characters.  Do not use C<\>, drive names, etc.
 352
 353 =cut
 354
 355 sub resolve_windows_path
 356 {
 357     my $g = shift;
 358     my $path = shift;
 359
 360     my $r;
 361     eval { $r = $g->case_sensitive_path ($path); };
 362     return $r;
 363 }
 364
 365 =head2 file_architecture
 366
 367 Deprecated function.  Replace any calls to this function with:
 368
 369  $g->file_architecture ($path);
 370
 371 =cut
 372
 373 sub file_architecture
 374 {
 375     my $g = shift;
 376     my $path = shift;
 377
 378     return $g->file_architecture ($path);
 379 }
 380
 381 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
 382
 383 =head2 inspect_all_partitions
 384
 385 This function is deprecated.  It will not be updated in future
 386 versions of libguestfs.  New code should not use this function.  Use
 387 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 388
 389 =cut
 390
 391 # Turn /dev/vd* and /dev/hd* into canonical device names
 392 # (see BLOCK DEVICE NAMING in guestfs(3)).
 393
 394 sub _canonical_dev ($)
 395 {
 396     my ($dev) = @_;
 397     return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
 398     return $dev;
 399 }
 400
 401 sub inspect_all_partitions
 402 {
 403     local $_;
 404     my $g = shift;
 405     my $parts = shift;
 406     my @parts = @$parts;
 407     return map { _canonical_dev ($_) => inspect_partition ($g, $_) } @parts;
 408 }
 409
 410 =head2 inspect_partition
 411
 412 This function is deprecated.  It will not be updated in future
 413 versions of libguestfs.  New code should not use this function.  Use
 414 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 415
 416 =cut
 417
 418 sub inspect_partition
 419 {
 420     local $_;
 421     my $g = shift;
 422     my $dev = shift;            # LV or partition name.
 423
 424     my %r;                      # Result hash.
 425
 426     # First try 'file(1)' on it.
 427     my $file = $g->file ($dev);
 428     if ($file =~ /ext2 filesystem data/) {
 429         $r{fstype} = "ext2";
 430         $r{fsos} = "linux";
 431     } elsif ($file =~ /ext3 filesystem data/) {
 432         $r{fstype} = "ext3";
 433         $r{fsos} = "linux";
 434     } elsif ($file =~ /ext4 filesystem data/) {
 435         $r{fstype} = "ext4";
 436         $r{fsos} = "linux";
 437     } elsif ($file =~ m{Linux/i386 swap file}) {
 438         $r{fstype} = "swap";
 439         $r{fsos} = "linux";
 440         $r{is_swap} = 1;
 441     }
 442
 443     # If it's ext2/3/4, then we want the UUID and label.
 444     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 445         $r{uuid} = $g->get_e2uuid ($dev);
 446         $r{label} = $g->get_e2label ($dev);
 447     }
 448
 449     # Try mounting it, fnarrr.
 450     if (!$r{is_swap}) {
 451         $r{is_mountable} = 1;
 452         eval { $g->mount_ro ($dev, "/") };
 453         if ($@) {
 454             # It's not mountable, probably empty or some format
 455             # we don't understand.
 456             $r{is_mountable} = 0;
 457             goto OUT;
 458         }
 459
 460         # Grub /boot?
 461         if ($g->is_file ("/grub/menu.lst") ||
 462             $g->is_file ("/grub/grub.conf")) {
 463             $r{content} = "linux-grub";
 464             _check_grub ($g, \%r);
 465             goto OUT;
 466         }
 467
 468         # Linux root?
 469         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 470             $g->is_file ("/etc/fstab")) {
 471             $r{content} = "linux-root";
 472             $r{is_root} = 1;
 473             _check_linux_root ($g, \%r);
 474             goto OUT;
 475         }
 476
 477         # Linux /usr/local.
 478         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 479             $g->is_dir ("/share") && !$g->exists ("/local") &&
 480             !$g->is_file ("/etc/fstab")) {
 481             $r{content} = "linux-usrlocal";
 482             goto OUT;
 483         }
 484
 485         # Linux /usr.
 486         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 487             $g->is_dir ("/share") && $g->exists ("/local") &&
 488             !$g->is_file ("/etc/fstab")) {
 489             $r{content} = "linux-usr";
 490             goto OUT;
 491         }
 492
 493         # Windows root?
 494         if ($g->is_file ("/AUTOEXEC.BAT") ||
 495             $g->is_file ("/autoexec.bat") ||
 496             $g->is_dir ("/Program Files") ||
 497             $g->is_dir ("/WINDOWS") ||
 498             $g->is_file ("/boot.ini") ||
 499             $g->is_file ("/ntldr")) {
 500             $r{fstype} = "ntfs"; # XXX this is a guess
 501             $r{fsos} = "windows";
 502             $r{content} = "windows-root";
 503             $r{is_root} = 1;
 504             _check_windows_root ($g, \%r);
 505             goto OUT;
 506         }
 507     }
 508
 509   OUT:
 510     $g->umount_all ();
 511     return \%r;
 512 }
 513
 514 sub _check_linux_root
 515 {
 516     local $_;
 517     my $g = shift;
 518     my $r = shift;
 519
 520     # Look into /etc to see if we recognise the operating system.
 521     # N.B. don't use $g->is_file here, because it might be a symlink
 522     if ($g->exists ("/etc/redhat-release")) {
 523         $r->{package_format} = "rpm";
 524
 525         $_ = $g->cat ("/etc/redhat-release");
 526         if (/Fedora release (\d+)(?:\.(\d+))?/) {
 527             chomp; $r->{product_name} = $_;
 528             $r->{osdistro} = "fedora";
 529             $r->{os_major_version} = "$1";
 530             $r->{os_minor_version} = "$2" if(defined($2));
 531             $r->{package_management} = "yum";
 532         }
 533
 534         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
 535             chomp; $r->{product_name} = $_;
 536
 537             my $distro = $1;
 538
 539             if($distro eq "Red Hat Enterprise Linux") {
 540                 $r->{osdistro} = "rhel";
 541             }
 542
 543             elsif($distro eq "CentOS") {
 544                 $r->{osdistro} = "centos";
 545                 $r->{package_management} = "yum";
 546             }
 547
 548             elsif($distro eq "Scientific Linux") {
 549                 $r->{osdistro} = "scientific";
 550                 $r->{package_management} = "yum";
 551             }
 552
 553             # Shouldn't be possible
 554             else { die };
 555
 556             if (/$distro.*release (\d+).*Update (\d+)/) {
 557                 $r->{os_major_version} = "$1";
 558                 $r->{os_minor_version} = "$2";
 559             }
 560
 561             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
 562                 $r->{os_major_version} = "$1";
 563
 564                 if(defined($2)) {
 565                     $r->{os_minor_version} = "$2";
 566                 } else {
 567                     $r->{os_minor_version} = "0";
 568                 }
 569             }
 570
 571             # Package management in RHEL changed in version 5
 572             if ($r->{osdistro} eq "rhel") {
 573                 if ($r->{os_major_version} >= 5) {
 574                     $r->{package_management} = "yum";
 575                 } else {
 576                     $r->{package_management} = "rhn";
 577                 }
 578             }
 579         }
 580
 581         else {
 582             $r->{osdistro} = "redhat-based";
 583         }
 584     } elsif ($g->is_file ("/etc/debian_version")) {
 585         $r->{package_format} = "deb";
 586         $r->{package_management} = "apt";
 587
 588         $_ = $g->cat ("/etc/debian_version");
 589         if (/(\d+)\.(\d+)/) {
 590             chomp; $r->{product_name} = $_;
 591             $r->{osdistro} = "debian";
 592             $r->{os_major_version} = "$1";
 593             $r->{os_minor_version} = "$2";
 594         } else {
 595             $r->{osdistro} = "debian";
 596         }
 597     }
 598
 599     # Parse the contents of /etc/fstab.  This is pretty vital so
 600     # we can determine where filesystems are supposed to be mounted.
 601     eval "\$_ = \$g->cat ('/etc/fstab');";
 602     if (!$@ && $_) {
 603         my @lines = split /\n/;
 604         my @fstab;
 605         foreach (@lines) {
 606             my @fields = split /[ \t]+/;
 607             if (@fields >= 2) {
 608                 my $spec = $fields[0]; # first column (dev/label/uuid)
 609                 my $file = $fields[1]; # second column (mountpoint)
 610                 if ($spec =~ m{^/} ||
 611                     $spec =~ m{^LABEL=} ||
 612                     $spec =~ m{^UUID=} ||
 613                     $file eq "swap") {
 614                     push @fstab, [$spec, $file]
 615                 }
 616             }
 617         }
 618         $r->{fstab} = \@fstab if @fstab;
 619     }
 620
 621     # Determine the architecture of this root.
 622     my $arch;
 623     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
 624         if ($g->is_file ($_)) {
 625             $arch = file_architecture ($g, $_);
 626             last;
 627         }
 628     }
 629
 630     $r->{arch} = $arch if defined $arch;
 631 }
 632
 633 # We only support NT.  The control file /boot.ini contains a list of
 634 # Windows installations and their %systemroot%s in a simple text
 635 # format.
 636 #
 637 # XXX We don't handle the case where /boot.ini is on a different
 638 # partition very well (Windows Vista and later).
 639
 640 sub _check_windows_root
 641 {
 642     local $_;
 643     my $g = shift;
 644     my $r = shift;
 645
 646     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 647     $r->{boot_ini} = $boot_ini;
 648
 649     my $systemroot;
 650     if (defined $r->{boot_ini}) {
 651         $_ = $g->cat ($boot_ini);
 652         my @lines = split /\n/;
 653         my $section;
 654         foreach (@lines) {
 655             if (m/\[.*\]/) {
 656                 $section = $1;
 657             } elsif (m/^default=.*?\\(\w+)$/i) {
 658                 $systemroot = $1;
 659                 last;
 660             } elsif (m/\\(\w+)=/) {
 661                 $systemroot = $1;
 662                 last;
 663             }
 664         }
 665     }
 666
 667     if (!defined $systemroot) {
 668         # Last ditch ... try to guess %systemroot% location.
 669         foreach ("windows", "winnt") {
 670             my $dir = resolve_windows_path ($g, "/$_/system32");
 671             if (defined $dir) {
 672                 $systemroot = $_;
 673                 last;
 674             }
 675         }
 676     }
 677
 678     if (defined $systemroot) {
 679         $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 680         if (defined $r->{systemroot}) {
 681             _check_windows_arch ($g, $r, $r->{systemroot});
 682             _check_windows_registry ($g, $r, $r->{systemroot});
 683         }
 684     }
 685 }
 686
 687 # Find Windows userspace arch.
 688
 689 sub _check_windows_arch
 690 {
 691     local $_;
 692     my $g = shift;
 693     my $r = shift;
 694     my $systemroot = shift;
 695
 696     my $cmd_exe =
 697         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
 698     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
 699 }
 700
 701 sub _check_windows_registry
 702 {
 703     local $_;
 704     my $g = shift;
 705     my $r = shift;
 706     my $systemroot = shift;
 707
 708     # Download the system registry files.  Only download the
 709     # interesting ones (SOFTWARE and SYSTEM).  We don't bother with
 710     # the user ones.
 711
 712     return unless exists $INC{"Win/Hivex.pm"};
 713
 714     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 715     return unless defined $configdir;
 716
 717     my $tmpdir = tempdir (CLEANUP => 1);
 718
 719     my $software = resolve_windows_path ($g, "$configdir/software");
 720     my $software_hive;
 721     if (defined $software) {
 722         eval {
 723             $g->download ($software, "$tmpdir/software");
 724             $software_hive = Win::Hivex->open ("$tmpdir/software");
 725         };
 726         warn "$@\n" if $@;
 727         $r->{windows_software_hive} = $software;
 728     }
 729
 730     my $system = resolve_windows_path ($g, "$configdir/system");
 731     my $system_hive;
 732     if (defined $system) {
 733         eval {
 734             $g->download ($system, "$tmpdir/system");
 735             $system_hive = Win::Hivex->open ("$tmpdir/system");
 736         };
 737         warn "$@\n" if $@;
 738         $r->{windows_system_hive} = $system;
 739     }
 740
 741     # Get the ProductName, major and minor version, etc.
 742     if (defined $software_hive) {
 743         my $cv_node;
 744         eval {
 745             $cv_node = $software_hive->root;
 746             $cv_node = $software_hive->node_get_child ($cv_node, $_)
 747                 foreach ("Microsoft", "Windows NT", "CurrentVersion");
 748         };
 749         warn "$@\n" if $@;
 750
 751         if ($cv_node) {
 752             my @values = $software_hive->node_values ($cv_node);
 753
 754             foreach (@values) {
 755                 my $k = $software_hive->value_key ($_);
 756                 if ($k eq "ProductName") {
 757                     $_ = $software_hive->value_string ($_);
 758                     $r->{product_name} = $_ if defined $_;
 759                 } elsif ($k eq "CurrentVersion") {
 760                     $_ = $software_hive->value_string ($_);
 761                     if (defined $_ && m/^(\d+)\.(\d+)/) {
 762                         $r->{os_major_version} = $1;
 763                         $r->{os_minor_version} = $2;
 764                     }
 765                 } elsif ($k eq "CurrentBuild") {
 766                     $_ = $software_hive->value_string ($_);
 767                     $r->{windows_current_build} = $_ if defined $_;
 768                 } elsif ($k eq "SoftwareType") {
 769                     $_ = $software_hive->value_string ($_);
 770                     $r->{windows_software_type} = $_ if defined $_;
 771                 } elsif ($k eq "CurrentType") {
 772                     $_ = $software_hive->value_string ($_);
 773                     $r->{windows_current_type} = $_ if defined $_;
 774                 } elsif ($k eq "RegisteredOwner") {
 775                     $_ = $software_hive->value_string ($_);
 776                     $r->{windows_registered_owner} = $_ if defined $_;
 777                 } elsif ($k eq "RegisteredOrganization") {
 778                     $_ = $software_hive->value_string ($_);
 779                     $r->{windows_registered_organization} = $_ if defined $_;
 780                 } elsif ($k eq "InstallationType") {
 781                     $_ = $software_hive->value_string ($_);
 782                     $r->{windows_installation_type} = $_ if defined $_;
 783                 } elsif ($k eq "EditionID") {
 784                     $_ = $software_hive->value_string ($_);
 785                     $r->{windows_edition_id} = $_ if defined $_;
 786                 } elsif ($k eq "ProductID") {
 787                     $_ = $software_hive->value_string ($_);
 788                     $r->{windows_product_id} = $_ if defined $_;
 789                 }
 790             }
 791         }
 792     }
 793 }
 794
 795 sub _check_grub
 796 {
 797     local $_;
 798     my $g = shift;
 799     my $r = shift;
 800
 801     # Grub version, if we care.
 802 }
 803
 804 =head2 inspect_operating_systems
 805
 806 This function is deprecated.  It will not be updated in future
 807 versions of libguestfs.  New code should not use this function.  Use
 808 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 809
 810 =cut
 811
 812 sub inspect_operating_systems
 813 {
 814     local $_;
 815     my $g = shift;
 816     my $fses = shift;
 817
 818     my %oses = ();
 819
 820     foreach (sort keys %$fses) {
 821         if ($fses->{$_}->{is_root}) {
 822             my %r = (
 823                 root => $fses->{$_},
 824                 root_device => $_
 825                 );
 826             _get_os_version ($g, \%r);
 827             _assign_mount_points ($g, $fses, \%r);
 828             $oses{$_} = \%r;
 829         }
 830     }
 831
 832     # If we didn't find any operating systems then it's an error (RHBZ#591142).
 833     if (0 == keys %oses) {
 834         die __"No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by virt-inspector.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n";
 835     }
 836
 837     return \%oses;
 838 }
 839
 840 sub _get_os_version
 841 {
 842     local $_;
 843     my $g = shift;
 844     my $r = shift;
 845
 846     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 847     $r->{product_name} = $r->{root}->{product_name}
 848         if exists $r->{root}->{product_name};
 849     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 850     $r->{major_version} = $r->{root}->{os_major_version}
 851         if exists $r->{root}->{os_major_version};
 852     $r->{minor_version} = $r->{root}->{os_minor_version}
 853         if exists $r->{root}->{os_minor_version};
 854     $r->{package_format} = $r->{root}->{package_format}
 855         if exists $r->{root}->{package_format};
 856     $r->{package_management} = $r->{root}->{package_management}
 857         if exists $r->{root}->{package_management};
 858     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
 859 }
 860
 861 sub _assign_mount_points
 862 {
 863     local $_;
 864     my $g = shift;
 865     my $fses = shift;
 866     my $r = shift;
 867
 868     $r->{mounts} = { "/" => $r->{root_device} };
 869     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 870
 871     # Use /etc/fstab if we have it to mount the rest.
 872     if (exists $r->{root}->{fstab}) {
 873         my @fstab = @{$r->{root}->{fstab}};
 874         foreach (@fstab) {
 875             my ($spec, $file) = @$_;
 876
 877             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
 878             if ($dev) {
 879                 $r->{mounts}->{$file} = $dev;
 880                 $r->{filesystems}->{$dev} = $fs;
 881                 if (exists $fs->{used}) {
 882                     $fs->{used}++
 883                 } else {
 884                     $fs->{used} = 1
 885                 }
 886                 $fs->{spec} = $spec;
 887             }
 888         }
 889     }
 890 }
 891
 892 # Find filesystem by device name, LABEL=.. or UUID=..
 893 sub _find_filesystem
 894 {
 895     my $g = shift;
 896     my $fses = shift;
 897     local $_ = shift;
 898
 899     if (/^LABEL=(.*)/) {
 900         my $label = $1;
 901         foreach (sort keys %$fses) {
 902             if (exists $fses->{$_}->{label} &&
 903                 $fses->{$_}->{label} eq $label) {
 904                 return ($_, $fses->{$_});
 905             }
 906         }
 907         warn __x("unknown filesystem label {label}\n", label => $label);
 908         return ();
 909     } elsif (/^UUID=(.*)/) {
 910         my $uuid = $1;
 911         foreach (sort keys %$fses) {
 912             if (exists $fses->{$_}->{uuid} &&
 913                 $fses->{$_}->{uuid} eq $uuid) {
 914                 return ($_, $fses->{$_});
 915             }
 916         }
 917         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
 918         return ();
 919     } else {
 920         return ($_, $fses->{$_}) if exists $fses->{$_};
 921
 922         # The following is to handle the case where an fstab entry specifies a
 923         # specific device rather than its label or uuid, and the libguestfs
 924         # appliance has named the device differently due to the use of a
 925         # different driver.
 926         # This will work as long as the underlying drivers recognise devices in
 927         # the same order.
 928         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
 929             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 930         }
 931         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
 932             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 933         }
 934         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
 935             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
 936         }
 937
 938         return () if m{/dev/cdrom};
 939
 940         warn __x("unknown filesystem {fs}\n", fs => $_);
 941         return ();
 942     }
 943 }
 944
 945 =head2 mount_operating_system
 946
 947 This function is deprecated.  It will not be updated in future
 948 versions of libguestfs.  New code should not use this function.  Use
 949 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 950
 951 =cut
 952
 953 sub mount_operating_system
 954 {
 955     local $_;
 956     my $g = shift;
 957     my $os = shift;
 958     my $ro = shift;             # Read-only?
 959
 960     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
 961
 962     my $mounts = $os->{mounts};
 963
 964     # Have to mount / first.  Luckily '/' is early in the ASCII
 965     # character set, so this should be OK.
 966     foreach (sort keys %$mounts) {
 967         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
 968             if($ro) {
 969                 $g->mount_ro ($mounts->{$_}, $_)
 970             } else {
 971                 $g->mount_options ("", $mounts->{$_}, $_)
 972             }
 973         }
 974     }
 975 }
 976
 977 =head2 inspect_in_detail
 978
 979 This function is deprecated.  It will not be updated in future
 980 versions of libguestfs.  New code should not use this function.  Use
 981 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 982
 983 =cut
 984
 985 sub inspect_in_detail
 986 {
 987     local $_;
 988     my $g = shift;
 989     my $os = shift;
 990
 991     _check_for_applications ($g, $os);
 992     _check_for_kernels ($g, $os);
 993     if ($os->{os} eq "linux") {
 994         _find_modprobe_aliases ($g, $os);
 995     }
 996 }
 997
 998 sub _check_for_applications
 999 {
1000     local $_;
1001     my $g = shift;
1002     my $os = shift;
1003
1004     my @apps;
1005
1006     my $osn = $os->{os};
1007     if ($osn eq "linux") {
1008         my $package_format = $os->{package_format};
1009         if (defined $package_format && $package_format eq "rpm") {
1010             my @lines = ();
1011             eval {
1012                 @lines = $g->command_lines
1013                     (["rpm",
1014                       "-q", "-a", "--qf",
1015                       "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1016             };
1017
1018             warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@);
1019
1020             @lines = sort @lines;
1021             foreach (@lines) {
1022                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1023                     my $epoch = $2;
1024                     undef $epoch if $epoch eq "(none)";
1025                     my $app = {
1026                         name => $1,
1027                         epoch => $epoch,
1028                         version => $3,
1029                         release => $4,
1030                         arch => $5
1031                     };
1032                     push @apps, $app
1033                 }
1034             }
1035         } elsif (defined $package_format && $package_format eq "deb") {
1036             my @lines = ();
1037             eval {
1038                 @lines = $g->command_lines
1039                     (["dpkg-query",
1040                       "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1041                       "-W"]);
1042             };
1043
1044             warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@);
1045
1046             @lines = sort @lines;
1047             foreach (@lines) {
1048                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1049                     if ( $6 eq "installed" ) {
1050                         my $app = {
1051                             name => $1,
1052                             version => $2,
1053                             arch => $3
1054                         };
1055                         push @apps, $app
1056                     }
1057                 }
1058             }
1059         }
1060     } elsif ($osn eq "windows") {
1061         # XXX
1062         # I worked out a general plan for this, but haven't
1063         # implemented it yet.  We can iterate over /Program Files
1064         # looking for *.EXE files, which we download, then use
1065         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1066         # section, which has a lot of useful information.
1067     }
1068
1069     $os->{apps} = \@apps;
1070 }
1071
1072 # Find the path which needs to be prepended to paths in grub.conf to make them
1073 # absolute
1074 sub _find_grub_prefix
1075 {
1076     my ($g, $os) = @_;
1077
1078     my $fses = $os->{filesystems};
1079     die("filesystems undefined") unless(defined($fses));
1080
1081     # Look for the filesystem which contains grub
1082     my $grubdev;
1083     foreach my $dev (keys(%$fses)) {
1084         my $fsinfo = $fses->{$dev};
1085         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1086             $grubdev = $dev;
1087             last;
1088         }
1089     }
1090
1091     my $mounts = $os->{mounts};
1092     die("mounts undefined") unless(defined($mounts));
1093
1094     # Find where the filesystem is mounted
1095     if(defined($grubdev)) {
1096         foreach my $mount (keys(%$mounts)) {
1097             if($mounts->{$mount} eq $grubdev) {
1098                 return "" if($mount eq '/');
1099                 return $mount;
1100             }
1101         }
1102
1103         die("$grubdev defined in filesystems, but not in mounts");
1104     }
1105
1106     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1107     # what filesystem it's on. We use menu.lst rather than grub.conf because
1108     # debian only uses menu.lst, and anaconda creates a symlink for it.
1109     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1110
1111     # Look for the most specific mount point in mounts
1112     foreach my $path qw(/boot/grub /boot /) {
1113         if(exists($mounts->{$path})) {
1114             return "" if($path eq '/');
1115             return $path;
1116         }
1117     }
1118
1119     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1120 }
1121
1122 sub _check_for_kernels
1123 {
1124     my ($g, $os) = @_;
1125
1126     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1127         # Iterate over entries in grub.conf, populating $os->{boot}
1128         # For every kernel we find, inspect it and add to $os->{kernels}
1129
1130         my $grub = _find_grub_prefix($g, $os);
1131         my $grub_conf = "/etc/grub.conf";
1132
1133         # Debian and other's have no /etc/grub.conf:
1134         if ( ! -f "$grub_conf" ) {
1135             $grub_conf = "$grub/grub/menu.lst";
1136         }
1137
1138         my @boot_configs;
1139
1140         # We want
1141         #  $os->{boot}
1142         #       ->{configs}
1143         #         ->[0]
1144         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1145         #           ->{kernel}  = \kernel
1146         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1147         #           ->{initrd}  = \initrd
1148         #       ->{default} = \config
1149         #       ->{grub_fs} = "/boot"
1150         # Initialise augeas
1151         $g->aug_init("/", 16);
1152
1153         my @configs = ();
1154         # Get all configurations from grub
1155         foreach my $bootable
1156             ($g->aug_match("/files/$grub_conf/title"))
1157         {
1158             my %config = ();
1159             $config{title} = $g->aug_get($bootable);
1160
1161             my $grub_kernel;
1162             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1163             if($@) {
1164                 warn __x("Grub entry {title} has no kernel",
1165                          title => $config{title});
1166             }
1167
1168             # Check we've got a kernel entry
1169             if(defined($grub_kernel)) {
1170                 my $path = "$grub$grub_kernel";
1171
1172                 # Reconstruct the kernel command line
1173                 my @args = ();
1174                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1175                     $arg =~ m{/kernel/([^/]*)$}
1176                         or die("Unexpected return from aug_match: $arg");
1177
1178                     my $name = $1;
1179                     my $value;
1180                     eval { $value = $g->aug_get($arg); };
1181
1182                     if(defined($value)) {
1183                         push(@args, "$name=$value");
1184                     } else {
1185                         push(@args, $name);
1186                     }
1187                 }
1188                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1189
1190                 my $kernel;
1191                 if ($g->exists($path)) {
1192                     $kernel =
1193                         inspect_linux_kernel($g, $path, $os->{package_format});
1194                 } else {
1195                     warn __x("grub refers to {path}, which doesn't exist\n",
1196                              path => $path);
1197                 }
1198
1199                 # Check the kernel was recognised
1200                 if(defined($kernel)) {
1201                     # Put this kernel on the top level kernel list
1202                     $os->{kernels} ||= [];
1203                     push(@{$os->{kernels}}, $kernel);
1204
1205                     $config{kernel} = $kernel;
1206
1207                     # Look for an initrd entry
1208                     my $initrd;
1209                     eval {
1210                         $initrd = $g->aug_get("$bootable/initrd");
1211                     };
1212
1213                     unless($@) {
1214                         $config{initrd} =
1215                             _inspect_initrd($g, $os, "$grub$initrd",
1216                                             $kernel->{version});
1217                     } else {
1218                         warn __x("Grub entry {title} does not specify an ".
1219                                  "initrd", title => $config{title});
1220                     }
1221                 }
1222             }
1223
1224             push(@configs, \%config);
1225         }
1226
1227
1228         # Create the top level boot entry
1229         my %boot;
1230         $boot{configs} = \@configs;
1231         $boot{grub_fs} = $grub;
1232
1233         # Add the default configuration
1234         eval {
1235             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1236         };
1237
1238         $os->{boot} = \%boot;
1239     }
1240
1241     elsif ($os->{os} eq "windows") {
1242         # XXX
1243     }
1244 }
1245
1246 =head2 inspect_linux_kernel
1247
1248 This function is deprecated.  It will not be updated in future
1249 versions of libguestfs.  New code should not use this function.  Use
1250 the core API functions instead, see L<guestfs(3)/INSPECTION>.
1251
1252 =cut
1253
1254 sub inspect_linux_kernel
1255 {
1256     my ($g, $path, $package_format) = @_;
1257
1258     my %kernel = ();
1259
1260     $kernel{path} = $path;
1261
1262     # If this is a packaged kernel, try to work out the name of the package
1263     # which installed it. This lets us know what to install to replace it with,
1264     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1265     if($package_format eq "rpm") {
1266         my $package;
1267         eval { $package = $g->command(['rpm', '-qf', '--qf',
1268                                        '%{NAME}', $path]); };
1269         $kernel{package} = $package if defined($package);;
1270     }
1271
1272     # Try to get the kernel version by running file against it
1273     my $version;
1274     my $filedesc = $g->file($path);
1275     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1276         $version = $1;
1277     }
1278
1279     # Sometimes file can't work out the kernel version, for example because it's
1280     # a Xen PV kernel. In this case try to guess the version from the filename
1281     else {
1282         if($path =~ m{/boot/vmlinuz-(.*)}) {
1283             $version = $1;
1284
1285             # Check /lib/modules/$version exists
1286             if(!$g->is_dir("/lib/modules/$version")) {
1287                 warn __x("Didn't find modules directory {modules} for kernel ".
1288                          "{path}", modules => "/lib/modules/$version",
1289                          path => $path);
1290
1291                 # Give up
1292                 return undef;
1293             }
1294         } else {
1295             warn __x("Couldn't guess kernel version number from path for ".
1296                      "kernel {path}", path => $path);
1297
1298             # Give up
1299             return undef;
1300         }
1301     }
1302
1303     $kernel{version} = $version;
1304
1305     # List modules.
1306     my @modules;
1307     my $any_module;
1308     my $prefix = "/lib/modules/$version";
1309     foreach my $module ($g->find ($prefix)) {
1310         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1311             $any_module = "$prefix$module" unless defined $any_module;
1312             push @modules, $1;
1313         }
1314     }
1315
1316     $kernel{modules} = \@modules;
1317
1318     # Determine kernel architecture by looking at the arch
1319     # of any kernel module.
1320     $kernel{arch} = file_architecture ($g, $any_module);
1321
1322     return \%kernel;
1323 }
1324
1325 # Find all modprobe aliases. Specifically, this looks in the following
1326 # locations:
1327 #  * /etc/conf.modules
1328 #  * /etc/modules.conf
1329 #  * /etc/modprobe.conf
1330 #  * /etc/modprobe.d/*
1331
1332 sub _find_modprobe_aliases
1333 {
1334     local $_;
1335     my $g = shift;
1336     my $os = shift;
1337
1338     # Initialise augeas
1339     $g->aug_init("/", 16);
1340
1341     my %modprobe_aliases;
1342
1343     for my $pattern qw(/files/etc/conf.modules/alias
1344                        /files/etc/modules.conf/alias
1345                        /files/etc/modprobe.conf/alias
1346                        /files/etc/modprobe.d/*/alias) {
1347         for my $path ( $g->aug_match($pattern) ) {
1348             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1349                 or die __x("{path} doesn't match augeas pattern",
1350                            path => $path);
1351             my $file = $1;
1352
1353             my $alias;
1354             $alias = $g->aug_get($path);
1355
1356             my $modulename;
1357             $modulename = $g->aug_get($path.'/modulename');
1358
1359             my %aliasinfo;
1360             $aliasinfo{modulename} = $modulename;
1361             $aliasinfo{augeas} = $path;
1362             $aliasinfo{file} = $file;
1363
1364             $modprobe_aliases{$alias} = \%aliasinfo;
1365         }
1366     }
1367
1368     $os->{modprobe_aliases} = \%modprobe_aliases;
1369 }
1370
1371 # Get a listing of device drivers from an initrd
1372 sub _inspect_initrd
1373 {
1374     my ($g, $os, $path, $version) = @_;
1375
1376     my @modules;
1377
1378     # Disregard old-style compressed ext2 files and only work with real
1379     # compressed cpio files, since cpio takes ages to (fail to) process anything
1380     # else.
1381     if ($g->exists($path) && $g->file($path) =~ /cpio/) {
1382         eval {
1383             @modules = $g->initrd_list ($path);
1384         };
1385         unless ($@) {
1386             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1387         } else {
1388             warn __x("{filename}: could not read initrd format",
1389                      filename => "$path");
1390         }
1391     }
1392
1393     # Add to the top level initrd_modules entry
1394     $os->{initrd_modules} ||= {};
1395     $os->{initrd_modules}->{$version} = \@modules;
1396
1397     return \@modules;
1398 }
1399
1400 1;
1401
1402 =head1 COPYRIGHT
1403
1404 Copyright (C) 2009-2010 Red Hat Inc.
1405
1406 =head1 LICENSE
1407
1408 Please see the file COPYING.LIB for the full license.
1409
1410 =head1 SEE ALSO
1411
1412 L<virt-inspector(1)>,
1413 L<Sys::Guestfs(3)>,
1414 L<guestfs(3)>,
1415 L<http://libguestfs.org/>,
1416 L<Sys::Virt(3)>,
1417 L<http://libvirt.org/>,
1418 L<guestfish(1)>.
1419
1420 =cut