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 This function is deprecated.  It will not be updated in future
 289 versions of libguestfs.  New code should not use this function.  Use
 290 the core API function L<Sys::Guestfs(3)/list_filesystems> instead.
 291
 292 =cut
 293
 294 sub get_partitions
 295 {
 296     local $_;
 297     my $g = shift;
 298
 299     # Look to see if any devices directly contain filesystems (RHBZ#590167).
 300     my @devices = $g->list_devices ();
 301     my @fses_on_device = ();
 302     foreach (@devices) {
 303         eval { $g->mount_ro ($_, "/"); };
 304         push @fses_on_device, $_ unless $@;
 305         $g->umount_all ();
 306     }
 307
 308     my @partitions = $g->list_partitions ();
 309     my @pvs = $g->pvs ();
 310     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
 311
 312     my @lvs;
 313     @lvs = $g->lvs () if feature_available ($g, "lvm2");
 314
 315     return sort (@fses_on_device, @lvs, @partitions);
 316 }
 317
 318 sub _is_pv {
 319     local $_;
 320     my $t = shift;
 321
 322     foreach (@_) {
 323         return 1 if $_ eq $t;
 324     }
 325     0;
 326 }
 327
 328 =head2 resolve_windows_path
 329
 330  $path = resolve_windows_path ($g, $path);
 331
 332  $path = resolve_windows_path ($g, "/windows/system");
 333    ==> "/WINDOWS/System"
 334        or undef if no path exists
 335
 336 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
 337 guests), lets you look up a case insensitive C<$path> in the
 338 filesystem and returns the true, case sensitive path as required by
 339 the underlying kernel or NTFS-3g driver.
 340
 341 If C<$path> does not exist then this function returns C<undef>.
 342
 343 The C<$path> parameter must begin with C</> character and be separated
 344 by C</> characters.  Do not use C<\>, drive names, etc.
 345
 346 =cut
 347
 348 sub resolve_windows_path
 349 {
 350     my $g = shift;
 351     my $path = shift;
 352
 353     my $r;
 354     eval { $r = $g->case_sensitive_path ($path); };
 355     return $r;
 356 }
 357
 358 =head2 file_architecture
 359
 360 Deprecated function.  Replace any calls to this function with:
 361
 362  $g->file_architecture ($path);
 363
 364 =cut
 365
 366 sub file_architecture
 367 {
 368     my $g = shift;
 369     my $path = shift;
 370
 371     return $g->file_architecture ($path);
 372 }
 373
 374 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
 375
 376 =head2 inspect_all_partitions
 377
 378 This function is deprecated.  It will not be updated in future
 379 versions of libguestfs.  New code should not use this function.  Use
 380 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 381
 382 =cut
 383
 384 # Turn /dev/vd* and /dev/hd* into canonical device names
 385 # (see BLOCK DEVICE NAMING in guestfs(3)).
 386
 387 sub _canonical_dev ($)
 388 {
 389     my ($dev) = @_;
 390     return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
 391     return $dev;
 392 }
 393
 394 sub inspect_all_partitions
 395 {
 396     local $_;
 397     my $g = shift;
 398     my $parts = shift;
 399     my @parts = @$parts;
 400     return map { _canonical_dev ($_) => inspect_partition ($g, $_) } @parts;
 401 }
 402
 403 =head2 inspect_partition
 404
 405 This function is deprecated.  It will not be updated in future
 406 versions of libguestfs.  New code should not use this function.  Use
 407 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 408
 409 =cut
 410
 411 sub inspect_partition
 412 {
 413     local $_;
 414     my $g = shift;
 415     my $dev = shift;            # LV or partition name.
 416
 417     my %r;                      # Result hash.
 418
 419     # First try 'file(1)' on it.
 420     my $file = $g->file ($dev);
 421     if ($file =~ /ext2 filesystem data/) {
 422         $r{fstype} = "ext2";
 423         $r{fsos} = "linux";
 424     } elsif ($file =~ /ext3 filesystem data/) {
 425         $r{fstype} = "ext3";
 426         $r{fsos} = "linux";
 427     } elsif ($file =~ /ext4 filesystem data/) {
 428         $r{fstype} = "ext4";
 429         $r{fsos} = "linux";
 430     } elsif ($file =~ m{Linux/i386 swap file}) {
 431         $r{fstype} = "swap";
 432         $r{fsos} = "linux";
 433         $r{is_swap} = 1;
 434     }
 435
 436     # If it's ext2/3/4, then we want the UUID and label.
 437     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 438         $r{uuid} = $g->get_e2uuid ($dev);
 439         $r{label} = $g->get_e2label ($dev);
 440     }
 441
 442     # Try mounting it, fnarrr.
 443     if (!$r{is_swap}) {
 444         $r{is_mountable} = 1;
 445         eval { $g->mount_ro ($dev, "/") };
 446         if ($@) {
 447             # It's not mountable, probably empty or some format
 448             # we don't understand.
 449             $r{is_mountable} = 0;
 450             goto OUT;
 451         }
 452
 453         # Grub /boot?
 454         if ($g->is_file ("/grub/menu.lst") ||
 455             $g->is_file ("/grub/grub.conf")) {
 456             $r{content} = "linux-grub";
 457             _check_grub ($g, \%r);
 458             goto OUT;
 459         }
 460
 461         # Linux root?
 462         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 463             $g->is_file ("/etc/fstab")) {
 464             $r{content} = "linux-root";
 465             $r{is_root} = 1;
 466             _check_linux_root ($g, \%r);
 467             goto OUT;
 468         }
 469
 470         # Linux /usr/local.
 471         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 472             $g->is_dir ("/share") && !$g->exists ("/local") &&
 473             !$g->is_file ("/etc/fstab")) {
 474             $r{content} = "linux-usrlocal";
 475             goto OUT;
 476         }
 477
 478         # Linux /usr.
 479         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 480             $g->is_dir ("/share") && $g->exists ("/local") &&
 481             !$g->is_file ("/etc/fstab")) {
 482             $r{content} = "linux-usr";
 483             goto OUT;
 484         }
 485
 486         # Windows root?
 487         if ($g->is_file ("/AUTOEXEC.BAT") ||
 488             $g->is_file ("/autoexec.bat") ||
 489             $g->is_dir ("/Program Files") ||
 490             $g->is_dir ("/WINDOWS") ||
 491             $g->is_file ("/boot.ini") ||
 492             $g->is_file ("/ntldr")) {
 493             $r{fstype} = "ntfs"; # XXX this is a guess
 494             $r{fsos} = "windows";
 495             $r{content} = "windows-root";
 496             $r{is_root} = 1;
 497             _check_windows_root ($g, \%r);
 498             goto OUT;
 499         }
 500     }
 501
 502   OUT:
 503     $g->umount_all ();
 504     return \%r;
 505 }
 506
 507 sub _check_linux_root
 508 {
 509     local $_;
 510     my $g = shift;
 511     my $r = shift;
 512
 513     # Look into /etc to see if we recognise the operating system.
 514     # N.B. don't use $g->is_file here, because it might be a symlink
 515     if ($g->exists ("/etc/redhat-release")) {
 516         $r->{package_format} = "rpm";
 517
 518         $_ = $g->cat ("/etc/redhat-release");
 519         if (/Fedora release (\d+)(?:\.(\d+))?/) {
 520             chomp; $r->{product_name} = $_;
 521             $r->{osdistro} = "fedora";
 522             $r->{os_major_version} = "$1";
 523             $r->{os_minor_version} = "$2" if(defined($2));
 524             $r->{package_management} = "yum";
 525         }
 526
 527         elsif (/(Red Hat|CentOS|Scientific Linux)/) {
 528             chomp; $r->{product_name} = $_;
 529
 530             my $distro = $1;
 531
 532             if($distro eq "Red Hat") {
 533                 $r->{osdistro} = "rhel";
 534             }
 535
 536             elsif($distro eq "CentOS") {
 537                 $r->{osdistro} = "centos";
 538                 $r->{package_management} = "yum";
 539             }
 540
 541             elsif($distro eq "Scientific Linux") {
 542                 $r->{osdistro} = "scientific";
 543                 $r->{package_management} = "yum";
 544             }
 545
 546             # Shouldn't be possible
 547             else { die };
 548
 549             if (/$distro.*release (\d+).*Update (\d+)/) {
 550                 $r->{os_major_version} = "$1";
 551                 $r->{os_minor_version} = "$2";
 552             }
 553
 554             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
 555                 $r->{os_major_version} = "$1";
 556
 557                 if(defined($2)) {
 558                     $r->{os_minor_version} = "$2";
 559                 } else {
 560                     $r->{os_minor_version} = "0";
 561                 }
 562             }
 563
 564             # Package management in RHEL changed in version 5
 565             if ($r->{osdistro} eq "rhel") {
 566                 if ($r->{os_major_version} >= 5) {
 567                     $r->{package_management} = "yum";
 568                 } else {
 569                     $r->{package_management} = "rhn";
 570                 }
 571             }
 572         }
 573
 574         else {
 575             $r->{osdistro} = "redhat-based";
 576         }
 577     } elsif ($g->is_file ("/etc/debian_version")) {
 578         $r->{package_format} = "deb";
 579         $r->{package_management} = "apt";
 580
 581         $_ = $g->cat ("/etc/debian_version");
 582         if (/(\d+)\.(\d+)/) {
 583             chomp; $r->{product_name} = $_;
 584             $r->{osdistro} = "debian";
 585             $r->{os_major_version} = "$1";
 586             $r->{os_minor_version} = "$2";
 587         } else {
 588             $r->{osdistro} = "debian";
 589         }
 590     }
 591
 592     # Parse the contents of /etc/fstab.  This is pretty vital so
 593     # we can determine where filesystems are supposed to be mounted.
 594     eval "\$_ = \$g->cat ('/etc/fstab');";
 595     if (!$@ && $_) {
 596         my @lines = split /\n/;
 597         my @fstab;
 598         foreach (@lines) {
 599             my @fields = split /[ \t]+/;
 600             if (@fields >= 2) {
 601                 my $spec = $fields[0]; # first column (dev/label/uuid)
 602                 my $file = $fields[1]; # second column (mountpoint)
 603                 if ($spec =~ m{^/} ||
 604                     $spec =~ m{^LABEL=} ||
 605                     $spec =~ m{^UUID=} ||
 606                     $file eq "swap") {
 607                     push @fstab, [$spec, $file]
 608                 }
 609             }
 610         }
 611         $r->{fstab} = \@fstab if @fstab;
 612     }
 613
 614     # Determine the architecture of this root.
 615     my $arch;
 616     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
 617         if ($g->is_file ($_)) {
 618             $arch = file_architecture ($g, $_);
 619             last;
 620         }
 621     }
 622
 623     $r->{arch} = $arch if defined $arch;
 624 }
 625
 626 # We only support NT.  The control file /boot.ini contains a list of
 627 # Windows installations and their %systemroot%s in a simple text
 628 # format.
 629 #
 630 # XXX We don't handle the case where /boot.ini is on a different
 631 # partition very well (Windows Vista and later).
 632
 633 sub _check_windows_root
 634 {
 635     local $_;
 636     my $g = shift;
 637     my $r = shift;
 638
 639     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
 640     $r->{boot_ini} = $boot_ini;
 641
 642     my $systemroot;
 643     if (defined $r->{boot_ini}) {
 644         $_ = $g->cat ($boot_ini);
 645         my @lines = split /\n/;
 646         my $section;
 647         foreach (@lines) {
 648             if (m/\[.*\]/) {
 649                 $section = $1;
 650             } elsif (m/^default=.*?\\(\w+)$/i) {
 651                 $systemroot = $1;
 652                 last;
 653             } elsif (m/\\(\w+)=/) {
 654                 $systemroot = $1;
 655                 last;
 656             }
 657         }
 658     }
 659
 660     if (!defined $systemroot) {
 661         # Last ditch ... try to guess %systemroot% location.
 662         foreach ("windows", "winnt") {
 663             my $dir = resolve_windows_path ($g, "/$_/system32");
 664             if (defined $dir) {
 665                 $systemroot = $_;
 666                 last;
 667             }
 668         }
 669     }
 670
 671     if (defined $systemroot) {
 672         $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
 673         if (defined $r->{systemroot}) {
 674             _check_windows_arch ($g, $r, $r->{systemroot});
 675             _check_windows_registry ($g, $r, $r->{systemroot});
 676         }
 677     }
 678 }
 679
 680 # Find Windows userspace arch.
 681
 682 sub _check_windows_arch
 683 {
 684     local $_;
 685     my $g = shift;
 686     my $r = shift;
 687     my $systemroot = shift;
 688
 689     my $cmd_exe =
 690         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
 691     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
 692 }
 693
 694 sub _check_windows_registry
 695 {
 696     local $_;
 697     my $g = shift;
 698     my $r = shift;
 699     my $systemroot = shift;
 700
 701     # Download the system registry files.  Only download the
 702     # interesting ones (SOFTWARE and SYSTEM).  We don't bother with
 703     # the user ones.
 704
 705     return unless exists $INC{"Win/Hivex.pm"};
 706
 707     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
 708     return unless defined $configdir;
 709
 710     my $tmpdir = tempdir (CLEANUP => 1);
 711
 712     my $software = resolve_windows_path ($g, "$configdir/software");
 713     my $software_hive;
 714     if (defined $software) {
 715         eval {
 716             $g->download ($software, "$tmpdir/software");
 717             $software_hive = Win::Hivex->open ("$tmpdir/software");
 718         };
 719         warn "$@\n" if $@;
 720         $r->{windows_software_hive} = $software;
 721     }
 722
 723     my $system = resolve_windows_path ($g, "$configdir/system");
 724     my $system_hive;
 725     if (defined $system) {
 726         eval {
 727             $g->download ($system, "$tmpdir/system");
 728             $system_hive = Win::Hivex->open ("$tmpdir/system");
 729         };
 730         warn "$@\n" if $@;
 731         $r->{windows_system_hive} = $system;
 732     }
 733
 734     # Get the ProductName, major and minor version, etc.
 735     if (defined $software_hive) {
 736         my $cv_node;
 737         eval {
 738             $cv_node = $software_hive->root;
 739             $cv_node = $software_hive->node_get_child ($cv_node, $_)
 740                 foreach ("Microsoft", "Windows NT", "CurrentVersion");
 741         };
 742         warn "$@\n" if $@;
 743
 744         if ($cv_node) {
 745             my @values = $software_hive->node_values ($cv_node);
 746
 747             foreach (@values) {
 748                 my $k = $software_hive->value_key ($_);
 749                 if ($k eq "ProductName") {
 750                     $_ = $software_hive->value_string ($_);
 751                     $r->{product_name} = $_ if defined $_;
 752                 } elsif ($k eq "CurrentVersion") {
 753                     $_ = $software_hive->value_string ($_);
 754                     if (defined $_ && m/^(\d+)\.(\d+)/) {
 755                         $r->{os_major_version} = $1;
 756                         $r->{os_minor_version} = $2;
 757                     }
 758                 } elsif ($k eq "CurrentBuild") {
 759                     $_ = $software_hive->value_string ($_);
 760                     $r->{windows_current_build} = $_ if defined $_;
 761                 } elsif ($k eq "SoftwareType") {
 762                     $_ = $software_hive->value_string ($_);
 763                     $r->{windows_software_type} = $_ if defined $_;
 764                 } elsif ($k eq "CurrentType") {
 765                     $_ = $software_hive->value_string ($_);
 766                     $r->{windows_current_type} = $_ if defined $_;
 767                 } elsif ($k eq "RegisteredOwner") {
 768                     $_ = $software_hive->value_string ($_);
 769                     $r->{windows_registered_owner} = $_ if defined $_;
 770                 } elsif ($k eq "RegisteredOrganization") {
 771                     $_ = $software_hive->value_string ($_);
 772                     $r->{windows_registered_organization} = $_ if defined $_;
 773                 } elsif ($k eq "InstallationType") {
 774                     $_ = $software_hive->value_string ($_);
 775                     $r->{windows_installation_type} = $_ if defined $_;
 776                 } elsif ($k eq "EditionID") {
 777                     $_ = $software_hive->value_string ($_);
 778                     $r->{windows_edition_id} = $_ if defined $_;
 779                 } elsif ($k eq "ProductID") {
 780                     $_ = $software_hive->value_string ($_);
 781                     $r->{windows_product_id} = $_ if defined $_;
 782                 }
 783             }
 784         }
 785     }
 786 }
 787
 788 sub _check_grub
 789 {
 790     local $_;
 791     my $g = shift;
 792     my $r = shift;
 793
 794     # Grub version, if we care.
 795 }
 796
 797 =head2 inspect_operating_systems
 798
 799 This function is deprecated.  It will not be updated in future
 800 versions of libguestfs.  New code should not use this function.  Use
 801 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 802
 803 =cut
 804
 805 sub inspect_operating_systems
 806 {
 807     local $_;
 808     my $g = shift;
 809     my $fses = shift;
 810
 811     my %oses = ();
 812
 813     foreach (sort keys %$fses) {
 814         if ($fses->{$_}->{is_root}) {
 815             my %r = (
 816                 root => $fses->{$_},
 817                 root_device => $_
 818                 );
 819             _get_os_version ($g, \%r);
 820             _assign_mount_points ($g, $fses, \%r);
 821             $oses{$_} = \%r;
 822         }
 823     }
 824
 825     # If we didn't find any operating systems then it's an error (RHBZ#591142).
 826     if (0 == keys %oses) {
 827         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";
 828     }
 829
 830     return \%oses;
 831 }
 832
 833 sub _get_os_version
 834 {
 835     local $_;
 836     my $g = shift;
 837     my $r = shift;
 838
 839     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 840     $r->{product_name} = $r->{root}->{product_name}
 841         if exists $r->{root}->{product_name};
 842     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 843     $r->{major_version} = $r->{root}->{os_major_version}
 844         if exists $r->{root}->{os_major_version};
 845     $r->{minor_version} = $r->{root}->{os_minor_version}
 846         if exists $r->{root}->{os_minor_version};
 847     $r->{package_format} = $r->{root}->{package_format}
 848         if exists $r->{root}->{package_format};
 849     $r->{package_management} = $r->{root}->{package_management}
 850         if exists $r->{root}->{package_management};
 851     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
 852 }
 853
 854 sub _assign_mount_points
 855 {
 856     local $_;
 857     my $g = shift;
 858     my $fses = shift;
 859     my $r = shift;
 860
 861     $r->{mounts} = { "/" => $r->{root_device} };
 862     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 863
 864     # Use /etc/fstab if we have it to mount the rest.
 865     if (exists $r->{root}->{fstab}) {
 866         my @fstab = @{$r->{root}->{fstab}};
 867         foreach (@fstab) {
 868             my ($spec, $file) = @$_;
 869
 870             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec, $file);
 871             if ($dev) {
 872                 $r->{mounts}->{$file} = $dev;
 873                 $r->{filesystems}->{$dev} = $fs;
 874                 if (exists $fs->{used}) {
 875                     $fs->{used}++
 876                 } else {
 877                     $fs->{used} = 1
 878                 }
 879                 $fs->{spec} = $spec;
 880             }
 881         }
 882     }
 883 }
 884
 885 # Find filesystem by device name, LABEL=.. or UUID=..
 886 sub _find_filesystem
 887 {
 888     my $g = shift;
 889     my $fses = shift;
 890     local $_ = shift;
 891     my $file = shift;
 892
 893     if (/^LABEL=(.*)/) {
 894         my $label = $1;
 895         my $dev;
 896         eval {
 897             $dev = $g->findfs_label ($label);
 898         };
 899         warn "unknown filesystem LABEL=$label in /etc/fstab: $@\n" if $@;
 900         return () if !defined $dev;
 901         $dev = _canonical_dev ($dev);
 902         return ($dev, $fses->{$dev}) if exists $fses->{$dev};
 903         # Otherwise return nothing.  It's just a filesystem that we are
 904         # ignoring, eg. swap.
 905         return ();
 906     } elsif (/^UUID=(.*)/) {
 907         my $uuid = $1;
 908         my $dev;
 909         eval {
 910             $dev = $g->findfs_uuid ($uuid);
 911         };
 912         warn "unknown filesystem UUID=$uuid in /etc/fstab: $@\n" if $@;
 913         return () if !defined $dev;
 914         $dev = _canonical_dev ($dev);
 915         return ($dev, $fses->{$dev}) if exists $fses->{$dev};
 916         # Otherwise return nothing.  It's just a filesystem that we are
 917         # ignoring, eg. swap.
 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/vd(.*)} && exists $fses->{"/dev/sd$1"}) {
 932             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 933         }
 934         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
 935             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
 936         }
 937         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
 938             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
 939         }
 940
 941         return () if $file =~ (/media\/cdrom/);
 942         return () if m{/dev/cdrom};
 943         return () if m{/dev/fd0};
 944
 945         warn __x("unknown filesystem {fs}\n", fs => $_);
 946         return ();
 947     }
 948 }
 949
 950 =head2 mount_operating_system
 951
 952 This function is deprecated.  It will not be updated in future
 953 versions of libguestfs.  New code should not use this function.  Use
 954 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 955
 956 =cut
 957
 958 sub mount_operating_system
 959 {
 960     local $_;
 961     my $g = shift;
 962     my $os = shift;
 963     my $ro = shift;             # Read-only?
 964
 965     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
 966
 967     my $mounts = $os->{mounts};
 968
 969     # Have to mount / first.  Luckily '/' is early in the ASCII
 970     # character set, so this should be OK.
 971     foreach (sort keys %$mounts) {
 972         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
 973             if($ro) {
 974                 $g->mount_ro ($mounts->{$_}, $_)
 975             } else {
 976                 $g->mount_options ("", $mounts->{$_}, $_)
 977             }
 978         }
 979     }
 980 }
 981
 982 =head2 inspect_in_detail
 983
 984 This function is deprecated.  It will not be updated in future
 985 versions of libguestfs.  New code should not use this function.  Use
 986 the core API functions instead, see L<guestfs(3)/INSPECTION>.
 987
 988 =cut
 989
 990 sub inspect_in_detail
 991 {
 992     local $_;
 993     my $g = shift;
 994     my $os = shift;
 995
 996     _check_for_applications ($g, $os);
 997     _check_for_kernels ($g, $os);
 998     if ($os->{os} eq "linux") {
 999         _find_modprobe_aliases ($g, $os);
1000     }
1001 }
1002
1003 sub _check_for_applications
1004 {
1005     local $_;
1006     my $g = shift;
1007     my $os = shift;
1008
1009     my @apps;
1010
1011     my $osn = $os->{os};
1012     if ($osn eq "linux") {
1013         my $package_format = $os->{package_format};
1014         if (defined $package_format && $package_format eq "rpm") {
1015             my @lines = ();
1016             eval {
1017                 @lines = $g->command_lines
1018                     (["rpm",
1019                       "-q", "-a", "--qf",
1020                       "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1021             };
1022
1023             warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@);
1024
1025             @lines = sort @lines;
1026             foreach (@lines) {
1027                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1028                     my $epoch = $2;
1029                     undef $epoch if $epoch eq "(none)";
1030                     my $app = {
1031                         name => $1,
1032                         epoch => $epoch,
1033                         version => $3,
1034                         release => $4,
1035                         arch => $5
1036                     };
1037                     push @apps, $app
1038                 }
1039             }
1040         } elsif (defined $package_format && $package_format eq "deb") {
1041             my @lines = ();
1042             eval {
1043                 @lines = $g->command_lines
1044                     (["dpkg-query",
1045                       "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1046                       "-W"]);
1047             };
1048
1049             warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@);
1050
1051             @lines = sort @lines;
1052             foreach (@lines) {
1053                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1054                     if ( $6 eq "installed" ) {
1055                         my $app = {
1056                             name => $1,
1057                             version => $2,
1058                             arch => $3
1059                         };
1060                         push @apps, $app
1061                     }
1062                 }
1063             }
1064         }
1065     } elsif ($osn eq "windows") {
1066         # XXX
1067         # I worked out a general plan for this, but haven't
1068         # implemented it yet.  We can iterate over /Program Files
1069         # looking for *.EXE files, which we download, then use
1070         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1071         # section, which has a lot of useful information.
1072     }
1073
1074     $os->{apps} = \@apps;
1075 }
1076
1077 # Find the path which needs to be prepended to paths in grub.conf to make them
1078 # absolute
1079 sub _find_grub_prefix
1080 {
1081     my ($g, $os) = @_;
1082
1083     my $fses = $os->{filesystems};
1084     die("filesystems undefined") unless(defined($fses));
1085
1086     # Look for the filesystem which contains grub
1087     my $grubdev;
1088     foreach my $dev (keys(%$fses)) {
1089         my $fsinfo = $fses->{$dev};
1090         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1091             $grubdev = $dev;
1092             last;
1093         }
1094     }
1095
1096     my $mounts = $os->{mounts};
1097     die("mounts undefined") unless(defined($mounts));
1098
1099     # Find where the filesystem is mounted
1100     if(defined($grubdev)) {
1101         foreach my $mount (keys(%$mounts)) {
1102             if($mounts->{$mount} eq $grubdev) {
1103                 return "" if($mount eq '/');
1104                 return $mount;
1105             }
1106         }
1107
1108         die("$grubdev defined in filesystems, but not in mounts");
1109     }
1110
1111     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1112     # what filesystem it's on. We use menu.lst rather than grub.conf because
1113     # debian only uses menu.lst, and anaconda creates a symlink for it.
1114     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1115
1116     # Look for the most specific mount point in mounts
1117     foreach my $path (qw(/boot/grub /boot /)) {
1118         if(exists($mounts->{$path})) {
1119             return "" if($path eq '/');
1120             return $path;
1121         }
1122     }
1123
1124     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1125 }
1126
1127 sub _check_for_kernels
1128 {
1129     my ($g, $os) = @_;
1130
1131     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1132         # Iterate over entries in grub.conf, populating $os->{boot}
1133         # For every kernel we find, inspect it and add to $os->{kernels}
1134
1135         my $grub = _find_grub_prefix($g, $os);
1136         my $grub_conf = "/etc/grub.conf";
1137
1138         # Debian and other's have no /etc/grub.conf:
1139         if ( ! -f "$grub_conf" ) {
1140             $grub_conf = "$grub/grub/menu.lst";
1141         }
1142
1143         my @boot_configs;
1144
1145         # We want
1146         #  $os->{boot}
1147         #       ->{configs}
1148         #         ->[0]
1149         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1150         #           ->{kernel}  = \kernel
1151         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1152         #           ->{initrd}  = \initrd
1153         #       ->{default} = \config
1154         #       ->{grub_fs} = "/boot"
1155         # Initialise augeas
1156         $g->aug_init("/", 16);
1157
1158         my @configs = ();
1159         # Get all configurations from grub
1160         foreach my $bootable
1161             ($g->aug_match("/files/$grub_conf/title"))
1162         {
1163             my %config = ();
1164             $config{title} = $g->aug_get($bootable);
1165
1166             my $grub_kernel;
1167             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1168             if($@) {
1169                 warn __x("Grub entry {title} has no kernel",
1170                          title => $config{title});
1171             }
1172
1173             # Check we've got a kernel entry
1174             if(defined($grub_kernel)) {
1175                 my $path = "$grub$grub_kernel";
1176
1177                 # Reconstruct the kernel command line
1178                 my @args = ();
1179                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1180                     $arg =~ m{/kernel/([^/]*)$}
1181                         or die("Unexpected return from aug_match: $arg");
1182
1183                     my $name = $1;
1184                     my $value;
1185                     eval { $value = $g->aug_get($arg); };
1186
1187                     if(defined($value)) {
1188                         push(@args, "$name=$value");
1189                     } else {
1190                         push(@args, $name);
1191                     }
1192                 }
1193                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1194
1195                 my $kernel;
1196                 if ($g->exists($path)) {
1197                     $kernel =
1198                         inspect_linux_kernel($g, $path, $os->{package_format});
1199                 } else {
1200                     warn __x("grub refers to {path}, which doesn't exist\n",
1201                              path => $path);
1202                 }
1203
1204                 # Check the kernel was recognised
1205                 if(defined($kernel)) {
1206                     # Put this kernel on the top level kernel list
1207                     $os->{kernels} ||= [];
1208                     push(@{$os->{kernels}}, $kernel);
1209
1210                     $config{kernel} = $kernel;
1211
1212                     # Look for an initrd entry
1213                     my $initrd;
1214                     eval {
1215                         $initrd = $g->aug_get("$bootable/initrd");
1216                     };
1217
1218                     unless($@) {
1219                         $config{initrd} =
1220                             _inspect_initrd($g, $os, "$grub$initrd",
1221                                             $kernel->{version});
1222                     } else {
1223                         warn __x("Grub entry {title} does not specify an ".
1224                                  "initrd", title => $config{title});
1225                     }
1226                 }
1227             }
1228
1229             push(@configs, \%config);
1230         }
1231
1232
1233         # Create the top level boot entry
1234         my %boot;
1235         $boot{configs} = \@configs;
1236         $boot{grub_fs} = $grub;
1237
1238         # Add the default configuration
1239         eval {
1240             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1241         };
1242
1243         $os->{boot} = \%boot;
1244     }
1245
1246     elsif ($os->{os} eq "windows") {
1247         # XXX
1248     }
1249 }
1250
1251 =head2 inspect_linux_kernel
1252
1253 This function is deprecated.  It will not be updated in future
1254 versions of libguestfs.  New code should not use this function.  Use
1255 the core API functions instead, see L<guestfs(3)/INSPECTION>.
1256
1257 =cut
1258
1259 sub inspect_linux_kernel
1260 {
1261     my ($g, $path, $package_format) = @_;
1262
1263     my %kernel = ();
1264
1265     $kernel{path} = $path;
1266
1267     # If this is a packaged kernel, try to work out the name of the package
1268     # which installed it. This lets us know what to install to replace it with,
1269     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1270     if($package_format eq "rpm") {
1271         my $package;
1272         eval { $package = $g->command(['rpm', '-qf', '--qf',
1273                                        '%{NAME}', $path]); };
1274         $kernel{package} = $package if defined($package);;
1275     }
1276
1277     # Try to get the kernel version by running file against it
1278     my $version;
1279     my $filedesc = $g->file($path);
1280     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1281         $version = $1;
1282     }
1283
1284     # Sometimes file can't work out the kernel version, for example because it's
1285     # a Xen PV kernel. In this case try to guess the version from the filename
1286     else {
1287         if($path =~ m{/boot/vmlinuz-(.*)}) {
1288             $version = $1;
1289
1290             # Check /lib/modules/$version exists
1291             if(!$g->is_dir("/lib/modules/$version")) {
1292                 warn __x("Didn't find modules directory {modules} for kernel ".
1293                          "{path}", modules => "/lib/modules/$version",
1294                          path => $path);
1295
1296                 # Give up
1297                 return undef;
1298             }
1299         } else {
1300             warn __x("Couldn't guess kernel version number from path for ".
1301                      "kernel {path}", path => $path);
1302
1303             # Give up
1304             return undef;
1305         }
1306     }
1307
1308     $kernel{version} = $version;
1309
1310     # List modules.
1311     my @modules;
1312     my $any_module;
1313     my $prefix = "/lib/modules/$version";
1314     foreach my $module ($g->find ($prefix)) {
1315         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1316             $any_module = "$prefix$module" unless defined $any_module;
1317             push @modules, $1;
1318         }
1319     }
1320
1321     $kernel{modules} = \@modules;
1322
1323     # Determine kernel architecture by looking at the arch
1324     # of any kernel module.
1325     $kernel{arch} = file_architecture ($g, $any_module);
1326
1327     return \%kernel;
1328 }
1329
1330 # Find all modprobe aliases. Specifically, this looks in the following
1331 # locations:
1332 #  * /etc/conf.modules
1333 #  * /etc/modules.conf
1334 #  * /etc/modprobe.conf
1335 #  * /etc/modprobe.d/*
1336
1337 sub _find_modprobe_aliases
1338 {
1339     local $_;
1340     my $g = shift;
1341     my $os = shift;
1342
1343     # Initialise augeas
1344     $g->aug_init("/", 16);
1345
1346     my %modprobe_aliases;
1347
1348     for my $pattern (qw(/files/etc/conf.modules/alias
1349                         /files/etc/modules.conf/alias
1350                         /files/etc/modprobe.conf/alias
1351                         /files/etc/modprobe.d/*/alias)) {
1352         for my $path ( $g->aug_match($pattern) ) {
1353             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1354                 or die __x("{path} doesn't match augeas pattern",
1355                            path => $path);
1356             my $file = $1;
1357
1358             my $alias;
1359             $alias = $g->aug_get($path);
1360
1361             my $modulename;
1362             $modulename = $g->aug_get($path.'/modulename');
1363
1364             my %aliasinfo;
1365             $aliasinfo{modulename} = $modulename;
1366             $aliasinfo{augeas} = $path;
1367             $aliasinfo{file} = $file;
1368
1369             $modprobe_aliases{$alias} = \%aliasinfo;
1370         }
1371     }
1372
1373     $os->{modprobe_aliases} = \%modprobe_aliases;
1374 }
1375
1376 # Get a listing of device drivers from an initrd
1377 sub _inspect_initrd
1378 {
1379     my ($g, $os, $path, $version) = @_;
1380
1381     my @modules;
1382
1383     # Disregard old-style compressed ext2 files and only work with real
1384     # compressed cpio files, since cpio takes ages to (fail to) process anything
1385     # else.
1386     if ($g->exists($path) && $g->file($path) =~ /cpio/) {
1387         eval {
1388             @modules = $g->initrd_list ($path);
1389         };
1390         unless ($@) {
1391             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1392         } else {
1393             warn __x("{filename}: could not read initrd format",
1394                      filename => "$path");
1395         }
1396     }
1397
1398     # Add to the top level initrd_modules entry
1399     $os->{initrd_modules} ||= {};
1400     $os->{initrd_modules}->{$version} = \@modules;
1401
1402     return \@modules;
1403 }
1404
1405 1;
1406
1407 =head1 COPYRIGHT
1408
1409 Copyright (C) 2009-2010 Red Hat Inc.
1410
1411 =head1 LICENSE
1412
1413 Please see the file COPYING.LIB for the full license.
1414
1415 =head1 SEE ALSO
1416
1417 L<virt-inspector(1)>,
1418 L<Sys::Guestfs(3)>,
1419 L<guestfs(3)>,
1420 L<http://libguestfs.org/>,
1421 L<Sys::Virt(3)>,
1422 L<http://libvirt.org/>,
1423 L<guestfish(1)>.
1424
1425 =cut