inspector/virt-inspector.pl

   1 #!/usr/bin/perl -w
   2 # virt-inspector
   3 # Copyright (C) 2009 Red Hat Inc.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19 use warnings;
  20 use strict;
  21
  22 use Sys::Guestfs;
  23 use Pod::Usage;
  24 use Getopt::Long;
  25 use Data::Dumper;
  26
  27 # Optional:
  28 eval "use Sys::Virt;";
  29
  30 =encoding utf8
  31
  32 =head1 NAME
  33
  34 virt-inspector - Display OS version, kernel, drivers, mount points, applications, etc. in a virtual machine
  35
  36 =head1 SYNOPSIS
  37
  38  virt-inspector [--connect URI] domname
  39
  40  virt-inspector guest.img [guest.img ...]
  41
  42 =head1 DESCRIPTION
  43
  44 B<virt-inspector> examines a virtual machine and tries to determine
  45 the version of the OS, the kernel version, what drivers are installed,
  46 whether the virtual machine is fully virtualized (FV) or
  47 para-virtualized (PV), what applications are installed and more.
  48
  49 Virt-inspector can produce output in several formats, including a
  50 readable text report, and XML for feeding into other programs.
  51
  52 Virt-inspector should only be run on I<inactive> virtual machines.
  53 The program tries to determine that the machine is inactive and will
  54 refuse to run if it thinks you are trying to inspect a running domain.
  55
  56 In the normal usage, use C<virt-inspector domname> where C<domname> is
  57 the libvirt domain (see: C<virsh list --all>).
  58
  59 You can also run virt-inspector directly on disk images from a single
  60 virtual machine.  Use C<virt-inspector guest.img>.  In rare cases a
  61 domain has several block devices, in which case you should list them
  62 one after another, with the first corresponding to the guest's
  63 C</dev/sda>, the second to the guest's C</dev/sdb> and so on.
  64
  65 Virt-inspector can only inspect and report upon I<one domain at a
  66 time>.  To inspect several virtual machines, you have to run
  67 virt-inspector several times (for example, from a shell script
  68 for-loop).
  69
  70 Because virt-inspector needs direct access to guest images, it won't
  71 normally work over remote libvirt connections.
  72
  73 =head1 OPTIONS
  74
  75 =over 4
  76
  77 =cut
  78
  79 my $help;
  80
  81 =item B<--help>
  82
  83 Display brief help.
  84
  85 =cut
  86
  87 my $uri;
  88
  89 =item B<--connect URI> | B<-c URI>
  90
  91 If using libvirt, connect to the given I<URI>.  If omitted,
  92 then we connect to the default libvirt hypervisor.
  93
  94 Libvirt is only used if you specify a C<domname> on the
  95 command line.  If you specify guest block devices directly,
  96 then libvirt is not used at all.
  97
  98 =cut
  99
 100 my $force;
 101
 102 =item B<--force>
 103
 104 Force reading a particular guest even if it appears to be active.  In
 105 earlier versions of virt-inspector, this could be dangerous (for
 106 example, corrupting the guest's disk image).  However in more recent
 107 versions, it should not cause corruption, but might cause
 108 virt-inspector to crash or produce incorrect results.
 109
 110 =cut
 111
 112 my $output = "text";
 113
 114 =back
 115
 116 The following options select the output format.  Use only one of them.
 117 The default is a readable text report.
 118
 119 =over 4
 120
 121 =item B<--text> (default)
 122
 123 Plain text report.
 124
 125 =item B<--none>
 126
 127 Produce no output at all.
 128
 129 =item B<--xml>
 130
 131 If you select I<--xml> then you get XML output which can be fed
 132 to other programs.
 133
 134 =item B<--perl>
 135
 136 If you select I<--perl> then you get Perl structures output which
 137 can be used directly in another Perl program.
 138
 139 =item B<--fish>
 140
 141 =item B<--ro-fish>
 142
 143 If you select I<--fish> then we print a L<guestfish(1)> command
 144 line which will automatically mount up the filesystems on the
 145 correct mount points.  Try this for example:
 146
 147  eval `virt-inspector --fish guest.img`
 148
 149 I<--ro-fish> is the same, but the I<--ro> option is passed to
 150 guestfish so that the filesystems are mounted read-only.
 151
 152 =item B<--query>
 153
 154 In "query mode" we answer common questions about the guest, such
 155 as whether it is fullvirt or needs a Xen hypervisor to run.
 156
 157 See section I<QUERY MODE> below.
 158
 159 =back
 160
 161 =cut
 162
 163 GetOptions ("help|?" => \$help,
 164             "connect|c=s" => \$uri,
 165             "force" => \$force,
 166             "text" => sub { $output = "text" },
 167             "none" => sub { $output = "none" },
 168             "xml" => sub { $output = "xml" },
 169             "perl" => sub { $output = "perl" },
 170             "fish" => sub { $output = "fish" },
 171             "guestfish" => sub { $output = "fish" },
 172             "ro-fish" => sub { $output = "ro-fish" },
 173             "ro-guestfish" => sub { $output = "ro-fish" },
 174             "query" => sub { $output = "query" },
 175     ) or pod2usage (2);
 176 pod2usage (1) if $help;
 177 pod2usage ("$0: no image or VM names given") if @ARGV == 0;
 178
 179 # Domain name or guest image(s)?
 180
 181 my @images;
 182 if (-e $ARGV[0]) {
 183     @images = @ARGV;
 184
 185     foreach (@images) {
 186         if (! -r $_) {
 187             die "guest image $_ does not exist or is not readable\n"
 188         }
 189     }
 190 } else {
 191     die "no libvirt support (install Sys::Virt)"
 192         unless exists $INC{"Sys/Virt.pm"};
 193
 194     pod2usage ("$0: too many domains listed on command line") if @ARGV > 1;
 195
 196     my $vmm;
 197     if (defined $uri) {
 198         $vmm = Sys::Virt->new (uri => $uri, readonly => 1);
 199     } else {
 200         $vmm = Sys::Virt->new (readonly => 1);
 201     }
 202     die "cannot connect to libvirt $uri\n" unless $vmm;
 203
 204     my @doms = $vmm->list_defined_domains ();
 205     my $dom;
 206     foreach (@doms) {
 207         if ($_->get_name () eq $ARGV[0]) {
 208             $dom = $_;
 209             last;
 210         }
 211     }
 212     die "$ARGV[0] is not the name of an inactive libvirt domain\n"
 213         unless $dom;
 214
 215     # Get the names of the image(s).
 216     my $xml = $dom->get_xml_description ();
 217
 218     my $p = new XML::XPath::XMLParser (xml => $xml);
 219     my $disks = $p->find ("//devices/disk");
 220     print "disks:\n";
 221     foreach ($disks->get_nodelist) {
 222         print XML::XPath::XMLParser::as_string($_);
 223     }
 224
 225     die "XXX"
 226 }
 227
 228 # We've now got the list of @images, so feed them to libguestfs.
 229 my $g = Sys::Guestfs->new ();
 230 $g->add_drive_ro ($_) foreach @images;
 231 $g->launch ();
 232 $g->wait_ready ();
 233
 234 # We want to get the list of LVs and partitions (ie. anything that
 235 # could contain a filesystem).  Discard any partitions which are PVs.
 236 my @partitions = $g->list_partitions ();
 237 my @pvs = $g->pvs ();
 238 sub is_pv {
 239     my $t = shift;
 240     foreach (@pvs) {
 241         return 1 if $_ eq $t;
 242     }
 243     0;
 244 }
 245 @partitions = grep { ! is_pv ($_) } @partitions;
 246
 247 my @lvs = $g->lvs ();
 248
 249 =head1 OUTPUT FORMAT
 250
 251  Operating system(s)
 252  -------------------
 253  Linux (distro + version)
 254  Windows (version)
 255     |
 256     |
 257     +--- Filesystems ---------- Installed apps --- Kernel & drivers
 258          -----------            --------------     ----------------
 259          mount point => device  List of apps       Extra information
 260          mount point => device  and versions       about kernel(s)
 261               ...                                  and drivers
 262          swap => swap device
 263          (plus lots of extra information
 264          about each filesystem)
 265
 266 The output of virt-inspector is a complex two-level data structure.
 267
 268 At the top level is a list of the operating systems installed on the
 269 guest.  (For the vast majority of guests, only a single OS is
 270 installed.)  The data returned for the OS includes the name (Linux,
 271 Windows), the distribution and version.
 272
 273 The diagram above shows what we return for each OS.
 274
 275 With the I<--xml> option the output is mapped into an XML document.
 276 Unfortunately there is no clear schema for this document
 277 (contributions welcome) but you can get an idea of the format by
 278 looking at other documents and as a last resort the source for this
 279 program.
 280
 281 With the I<--fish> or I<--ro-fish> option the mount points are mapped to
 282 L<guestfish(1)> command line parameters, so that you can go in
 283 afterwards and inspect the guest with everything mounted in the
 284 right place.  For example:
 285
 286  eval `virt-inspector --ro-fish guest.img`
 287  ==> guestfish --ro -a guest.img -m /dev/VG/LV:/ -m /dev/sda1:/boot
 288
 289 =cut
 290
 291 # List of possible filesystems.
 292 my @devices = sort (@lvs, @partitions);
 293
 294 # Now query each one to build up a picture of what's in it.
 295 my %fses = map { $_ => check_fs ($_) } @devices;
 296
 297 # Now the complex checking code itself.
 298 # check_fs takes a device name (LV or partition name) and returns
 299 # a hashref containing everything we can find out about the device.
 300 sub check_fs {
 301     local $_;
 302     my $dev = shift;            # LV or partition name.
 303
 304     my %r;                      # Result hash.
 305
 306     # First try 'file(1)' on it.
 307     my $file = $g->file ($dev);
 308     if ($file =~ /ext2 filesystem data/) {
 309         $r{fstype} = "ext2";
 310         $r{fsos} = "linux";
 311     } elsif ($file =~ /ext3 filesystem data/) {
 312         $r{fstype} = "ext3";
 313         $r{fsos} = "linux";
 314     } elsif ($file =~ /ext4 filesystem data/) {
 315         $r{fstype} = "ext4";
 316         $r{fsos} = "linux";
 317     } elsif ($file =~ m{Linux/i386 swap file}) {
 318         $r{fstype} = "swap";
 319         $r{fsos} = "linux";
 320         $r{is_swap} = 1;
 321     }
 322
 323     # If it's ext2/3/4, then we want the UUID and label.
 324     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 325         $r{uuid} = $g->get_e2uuid ($dev);
 326         $r{label} = $g->get_e2label ($dev);
 327     }
 328
 329     # Try mounting it, fnarrr.
 330     if (!$r{is_swap}) {
 331         $r{is_mountable} = 1;
 332         eval { $g->mount_ro ($dev, "/") };
 333         if ($@) {
 334             # It's not mountable, probably empty or some format
 335             # we don't understand.
 336             $r{is_mountable} = 0;
 337             goto OUT;
 338         }
 339
 340         # Grub /boot?
 341         if ($g->is_file ("/grub/menu.lst") ||
 342             $g->is_file ("/grub/grub.conf")) {
 343             $r{content} = "linux-grub";
 344             check_grub (\%r);
 345             goto OUT;
 346         }
 347
 348         # Linux root?
 349         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 350             $g->is_file ("/etc/fstab")) {
 351             $r{content} = "linux-root";
 352             $r{is_root} = 1;
 353             check_linux_root (\%r);
 354             goto OUT;
 355         }
 356
 357         # Linux /usr/local.
 358         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 359             $g->is_dir ("/share") && !$g->exists ("/local") &&
 360             !$g->is_file ("/etc/fstab")) {
 361             $r{content} = "linux-usrlocal";
 362             goto OUT;
 363         }
 364
 365         # Linux /usr.
 366         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 367             $g->is_dir ("/share") && $g->exists ("/local") &&
 368             !$g->is_file ("/etc/fstab")) {
 369             $r{content} = "linux-usr";
 370             goto OUT;
 371         }
 372
 373         # Windows root?
 374         if ($g->is_file ("/AUTOEXEC.BAT") ||
 375             $g->is_file ("/autoexec.bat") ||
 376             $g->is_dir ("/Program Files") ||
 377             $g->is_dir ("/WINDOWS") ||
 378             $g->is_file ("/ntldr")) {
 379             $r{fstype} = "ntfs"; # XXX this is a guess
 380             $r{fsos} = "windows";
 381             $r{content} = "windows-root";
 382             $r{is_root} = 1;
 383             check_windows_root (\%r);
 384             goto OUT;
 385         }
 386     }
 387
 388   OUT:
 389     $g->umount_all ();
 390     return \%r;
 391 }
 392
 393 sub check_linux_root
 394 {
 395     local $_;
 396     my $r = shift;
 397
 398     # Look into /etc to see if we recognise the operating system.
 399     if ($g->is_file ("/etc/redhat-release")) {
 400         $_ = $g->cat ("/etc/redhat-release");
 401         if (/Fedora release (\d+\.\d+)/) {
 402             $r->{osdistro} = "fedora";
 403             $r->{osversion} = "$1"
 404         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) {
 405             $r->{osdistro} = "redhat";
 406             $r->{osversion} = "$2.$3";
 407         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) {
 408             $r->{osdistro} = "redhat";
 409             $r->{osversion} = "$2";
 410         } else {
 411             $r->{osdistro} = "redhat";
 412         }
 413     } elsif ($g->is_file ("/etc/debian_version")) {
 414         $_ = $g->cat ("/etc/debian_version");
 415         if (/(\d+\.\d+)/) {
 416             $r->{osdistro} = "debian";
 417             $r->{osversion} = "$1";
 418         } else {
 419             $r->{osdistro} = "debian";
 420         }
 421     }
 422
 423     # Parse the contents of /etc/fstab.  This is pretty vital so
 424     # we can determine where filesystems are supposed to be mounted.
 425     eval "\$_ = \$g->cat ('/etc/fstab');";
 426     if (!$@ && $_) {
 427         my @lines = split /\n/;
 428         my @fstab;
 429         foreach (@lines) {
 430             my @fields = split /[ \t]+/;
 431             if (@fields >= 2) {
 432                 my $spec = $fields[0]; # first column (dev/label/uuid)
 433                 my $file = $fields[1]; # second column (mountpoint)
 434                 if ($spec =~ m{^/} ||
 435                     $spec =~ m{^LABEL=} ||
 436                     $spec =~ m{^UUID=} ||
 437                     $file eq "swap") {
 438                     push @fstab, [$spec, $file]
 439                 }
 440             }
 441         }
 442         $r->{fstab} = \@fstab if @fstab;
 443     }
 444 }
 445
 446 sub check_windows_root
 447 {
 448     local $_;
 449     my $r = shift;
 450
 451     # Windows version?
 452 }
 453
 454 sub check_grub
 455 {
 456     local $_;
 457     my $r = shift;
 458
 459     # Grub version, if we care.
 460 }
 461
 462 #print Dumper (\%fses);
 463
 464 #----------------------------------------------------------------------
 465 # Now find out how many operating systems we've got.  Usually just one.
 466
 467 my %oses = ();
 468
 469 foreach (sort keys %fses) {
 470     if ($fses{$_}->{is_root}) {
 471         my %r = (
 472             root => $fses{$_},
 473             root_device => $_
 474         );
 475         get_os_version (\%r);
 476         assign_mount_points (\%r);
 477         $oses{$_} = \%r;
 478     }
 479 }
 480
 481 sub get_os_version
 482 {
 483     local $_;
 484     my $r = shift;
 485
 486     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 487     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 488     $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
 489 }
 490
 491 sub assign_mount_points
 492 {
 493     local $_;
 494     my $r = shift;
 495
 496     $r->{mounts} = { "/" => $r->{root_device} };
 497     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 498
 499     # Use /etc/fstab if we have it to mount the rest.
 500     if (exists $r->{root}->{fstab}) {
 501         my @fstab = @{$r->{root}->{fstab}};
 502         foreach (@fstab) {
 503             my ($spec, $file) = @$_;
 504
 505             my ($dev, $fs) = find_filesystem ($spec);
 506             if ($dev) {
 507                 $r->{mounts}->{$file} = $dev;
 508                 $r->{filesystems}->{$dev} = $fs;
 509                 if (exists $fs->{used}) {
 510                     $fs->{used}++
 511                 } else {
 512                     $fs->{used} = 1
 513                 }
 514             }
 515         }
 516     }
 517 }
 518
 519 # Find filesystem by device name, LABEL=.. or UUID=..
 520 sub find_filesystem
 521 {
 522     local $_ = shift;
 523
 524     if (/^LABEL=(.*)/) {
 525         my $label = $1;
 526         foreach (sort keys %fses) {
 527             if (exists $fses{$_}->{label} &&
 528                 $fses{$_}->{label} eq $label) {
 529                 return ($_, $fses{$_});
 530             }
 531         }
 532         warn "unknown filesystem label $label\n";
 533         return ();
 534     } elsif (/^UUID=(.*)/) {
 535         my $uuid = $1;
 536         foreach (sort keys %fses) {
 537             if (exists $fses{$_}->{uuid} &&
 538                 $fses{$_}->{uuid} eq $uuid) {
 539                 return ($_, $fses{$_});
 540             }
 541         }
 542         warn "unknown filesystem UUID $uuid\n";
 543         return ();
 544     } else {
 545         return ($_, $fses{$_}) if exists $fses{$_};
 546
 547         if (m{^/dev/hd(.*)} && exists $fses{"/dev/sd$1"}) {
 548             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 549         }
 550         if (m{^/dev/xvd(.*)} && exists $fses{"/dev/sd$1"}) {
 551             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 552         }
 553
 554         return () if m{/dev/cdrom};
 555
 556         warn "unknown filesystem $_\n";
 557         return ();
 558     }
 559 }
 560
 561 #print Dumper(\%oses);
 562
 563 #----------------------------------------------------------------------
 564 # Mount up the disks so we can check for applications
 565 # and kernels.  Skip this if the output is "*fish" because
 566 # we don't need to know.
 567
 568 if ($output !~ /.*fish$/) {
 569     my $root_dev;
 570     foreach $root_dev (sort keys %oses) {
 571         my $mounts = $oses{$root_dev}->{mounts};
 572         # Have to mount / first.  Luckily '/' is early in the ASCII
 573         # character set, so this should be OK.
 574         foreach (sort keys %$mounts) {
 575             $g->mount_ro ($mounts->{$_}, $_)
 576                 if $_ ne "swap" && ($_ eq '/' || $g->is_dir ($_));
 577         }
 578
 579         check_for_applications ($root_dev);
 580         check_for_kernels ($root_dev);
 581
 582         $g->umount_all ();
 583     }
 584 }
 585
 586 sub check_for_applications
 587 {
 588     local $_;
 589     my $root_dev = shift;
 590
 591     my @apps;
 592
 593     my $os = $oses{$root_dev}->{os};
 594     if ($os eq "linux") {
 595         my $distro = $oses{$root_dev}->{distro};
 596         if ($distro eq "redhat") {
 597             my @lines = $g->command_lines
 598                 (["rpm", "-q", "-a", "--qf",
 599                   "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
 600             foreach (@lines) {
 601                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
 602                     my $epoch = $2;
 603                     $epoch = "" if $epoch eq "(none)";
 604                     my $app = {
 605                         name => $1,
 606                         epoch => $epoch,
 607                         version => $3,
 608                         release => $4,
 609                         arch => $5
 610                     };
 611                     push @apps, $app
 612                 }
 613             }
 614         }
 615     } elsif ($os eq "windows") {
 616         # XXX
 617         # I worked out a general plan for this, but haven't
 618         # implemented it yet.  We can iterate over /Program Files
 619         # looking for *.EXE files, which we download, then use
 620         # i686-pc-mingw32-windres on, to find the VERSIONINFO
 621         # section, which has a lot of useful information.
 622     }
 623
 624     $oses{$root_dev}->{apps} = \@apps;
 625 }
 626
 627 sub check_for_kernels
 628 {
 629     local $_;
 630     my $root_dev = shift;
 631
 632     my @kernels;
 633
 634     my $os = $oses{$root_dev}->{os};
 635     if ($os eq "linux") {
 636         # Installed kernels will have a corresponding /lib/modules/<version>
 637         # directory, which is the easiest way to find out what kernels
 638         # are installed, and what modules are available.
 639         foreach ($g->ls ("/lib/modules")) {
 640             if ($g->is_dir ("/lib/modules/$_")) {
 641                 my %kernel;
 642                 $kernel{version} = $_;
 643
 644                 # List modules.
 645                 my @modules;
 646                 foreach ($g->find ("/lib/modules/$_")) {
 647                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
 648                         push @modules, $1;
 649                     }
 650                 }
 651
 652                 $kernel{modules} = \@modules;
 653
 654                 push @kernels, \%kernel;
 655             }
 656         }
 657
 658     } elsif ($os eq "windows") {
 659         # XXX
 660     }
 661
 662     $oses{$root_dev}->{kernels} = \@kernels;
 663 }
 664
 665 #----------------------------------------------------------------------
 666 # Output.
 667
 668 if ($output eq "fish" || $output eq "ro-fish") {
 669     my @osdevs = keys %oses;
 670     # This only works if there is a single OS.
 671     die "--fish output is only possible with a single OS\n" if @osdevs != 1;
 672
 673     my $root_dev = $osdevs[0];
 674
 675     print "guestfish";
 676     if ($output eq "ro-fish") {
 677         print " --ro";
 678     }
 679
 680     print " -a $_" foreach @images;
 681
 682     my $mounts = $oses{$root_dev}->{mounts};
 683     # Have to mount / first.  Luckily '/' is early in the ASCII
 684     # character set, so this should be OK.
 685     foreach (sort keys %$mounts) {
 686         print " -m $mounts->{$_}:$_" if $_ ne "swap";
 687     }
 688     print "\n"
 689 }
 690
 691 # Perl output.
 692 elsif ($output eq "perl") {
 693     print Dumper(\%oses);
 694 }
 695
 696 # Plain text output (the default).
 697 elsif ($output eq "text") {
 698     output_text ();
 699 }
 700
 701 # XML output.
 702 elsif ($output eq "xml") {
 703     output_xml ();
 704 }
 705
 706 # Query mode.
 707 elsif ($output eq "query") {
 708     output_query ();
 709 }
 710
 711 sub output_text
 712 {
 713     output_text_os ($oses{$_}) foreach sort keys %oses;
 714 }
 715
 716 sub output_text_os
 717 {
 718     my $os = shift;
 719
 720     print $os->{os}, " " if exists $os->{os};
 721     print $os->{distro}, " " if exists $os->{distro};
 722     print $os->{version}, " " if exists $os->{version};
 723     print "on ", $os->{root_device}, ":\n";
 724
 725     print "  Mountpoints:\n";
 726     my $mounts = $os->{mounts};
 727     foreach (sort keys %$mounts) {
 728         printf "    %-30s %s\n", $mounts->{$_}, $_
 729     }
 730
 731     print "  Filesystems:\n";
 732     my $filesystems = $os->{filesystems};
 733     foreach (sort keys %$filesystems) {
 734         print "    $_:\n";
 735         print "      label: $filesystems->{$_}{label}\n"
 736             if exists $filesystems->{$_}{label};
 737         print "      UUID: $filesystems->{$_}{uuid}\n"
 738             if exists $filesystems->{$_}{uuid};
 739         print "      type: $filesystems->{$_}{fstype}\n"
 740             if exists $filesystems->{$_}{fstype};
 741         print "      content: $filesystems->{$_}{content}\n"
 742             if exists $filesystems->{$_}{content};
 743     }
 744
 745     print "  Applications:\n";
 746     my @apps =  @{$os->{apps}};
 747     foreach (@apps) {
 748         print "    $_->{name} $_->{version}\n"
 749     }
 750
 751     print "  Kernels:\n";
 752     my @kernels = @{$os->{kernels}};
 753     foreach (@kernels) {
 754         print "    $_->{version}\n";
 755         my @modules = @{$_->{modules}};
 756         foreach (@modules) {
 757             print "      $_\n";
 758         }
 759     }
 760 }
 761
 762 sub output_xml
 763 {
 764     print "<operatingsystems>\n";
 765     output_xml_os ($oses{$_}) foreach sort keys %oses;
 766     print "</operatingsystems>\n";
 767 }
 768
 769 sub output_xml_os
 770 {
 771     my $os = shift;
 772
 773     print "<operatingsystem>\n";
 774
 775     print "<os>", $os->{os}, "</os>\n" if exists $os->{os};
 776     print "<distro>", $os->{distro}, "</distro>\n" if exists $os->{distro};
 777     print "<version>", $os->{version}, "</version>\n" if exists $os->{version};
 778     print "<root>", $os->{root_device}, "</root>\n";
 779
 780     print "<mountpoints>\n";
 781     my $mounts = $os->{mounts};
 782     foreach (sort keys %$mounts) {
 783         printf "<mountpoint dev='%s'>%s</mountpoint>\n",
 784           $mounts->{$_}, $_
 785     }
 786     print "</mountpoints>\n";
 787
 788     print "<filesystems>\n";
 789     my $filesystems = $os->{filesystems};
 790     foreach (sort keys %$filesystems) {
 791         print "<filesystem dev='$_'>\n";
 792         print "<label>$filesystems->{$_}{label}</label>\n"
 793             if exists $filesystems->{$_}{label};
 794         print "<uuid>$filesystems->{$_}{uuid}</uuid>\n"
 795             if exists $filesystems->{$_}{uuid};
 796         print "<type>$filesystems->{$_}{fstype}</type>\n"
 797             if exists $filesystems->{$_}{fstype};
 798         print "<content>$filesystems->{$_}{content}</content>\n"
 799             if exists $filesystems->{$_}{content};
 800         print "</filesystem>\n";
 801     }
 802     print "</filesystems>\n";
 803
 804     print "<applications>\n";
 805     my @apps =  @{$os->{apps}};
 806     foreach (@apps) {
 807         print "<application>\n";
 808         print "<name>$_->{name}</name><version>$_->{version}</version>\n";
 809         print "</application>\n";
 810     }
 811     print "</applications>\n";
 812
 813     print "<kernels>\n";
 814     my @kernels = @{$os->{kernels}};
 815     foreach (@kernels) {
 816         print "<kernel>\n";
 817         print "<version>$_->{version}</version>\n";
 818         print "<modules>\n";
 819         my @modules = @{$_->{modules}};
 820         foreach (@modules) {
 821             print "<module>$_</module>\n";
 822         }
 823         print "</modules>\n";
 824         print "</kernel>\n";
 825     }
 826     print "</kernels>\n";
 827
 828     print "</operatingsystem>\n";
 829 }
 830
 831 =head1 QUERY MODE
 832
 833 When you use C<virt-inspector --query>, the output is a series of
 834 lines of the form:
 835
 836  windows=no
 837  linux=yes
 838  fullvirt=yes
 839  xen_pv_drivers=no
 840
 841 (each answer is usually C<yes> or C<no>, or the line is completely
 842 missing if we could not determine the answer at all).
 843
 844 If the guest is multiboot, you can get apparently conflicting answers
 845 (eg. C<windows=yes> and C<linux=yes>, or a guest which is both
 846 fullvirt and has a Xen PV kernel).  This is normal, and just means
 847 that the guest can do both things, although it might require operator
 848 intervention such as selecting a boot option when the guest is
 849 booting.
 850
 851 This section describes the full range of answers possible.
 852
 853 =over 4
 854
 855 =cut
 856
 857 sub output_query
 858 {
 859     output_query_windows ();
 860     output_query_linux ();
 861     output_query_rhel ();
 862     output_query_fedora ();
 863     output_query_debian ();
 864     output_query_fullvirt ();
 865     output_query_xen_domU_kernel ();
 866     output_query_xen_pv_drivers ();
 867     output_query_virtio_drivers ();
 868 }
 869
 870 =item windows=(yes|no)
 871
 872 Answer C<yes> if Microsoft Windows is installed in the guest.
 873
 874 =cut
 875
 876 sub output_query_windows
 877 {
 878     my $windows = "no";
 879     foreach my $os (keys %oses) {
 880         $windows="yes" if $oses{$os}->{os} eq "windows";
 881     }
 882     print "windows=$windows\n";
 883 }
 884
 885 =item linux=(yes|no)
 886
 887 Answer C<yes> if a Linux kernel is installed in the guest.
 888
 889 =cut
 890
 891 sub output_query_linux
 892 {
 893     my $linux = "no";
 894     foreach my $os (keys %oses) {
 895         $linux="yes" if $oses{$os}->{os} eq "linux";
 896     }
 897     print "linux=$linux\n";
 898 }
 899
 900 =item rhel=(yes|no)
 901
 902 Answer C<yes> if the guest contains Red Hat Enterprise Linux.
 903
 904 =cut
 905
 906 sub output_query_rhel
 907 {
 908     my $rhel = "no";
 909     foreach my $os (keys %oses) {
 910         $rhel="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "redhat";
 911     }
 912     print "rhel=$rhel\n";
 913 }
 914
 915 =item fedora=(yes|no)
 916
 917 Answer C<yes> if the guest contains the Fedora Linux distribution.
 918
 919 =cut
 920
 921 sub output_query_fedora
 922 {
 923     my $fedora = "no";
 924     foreach my $os (keys %oses) {
 925         $fedora="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "fedora";
 926     }
 927     print "fedora=$fedora\n";
 928 }
 929
 930 =item debian=(yes|no)
 931
 932 Answer C<yes> if the guest contains the Debian Linux distribution.
 933
 934 =cut
 935
 936 sub output_query_debian
 937 {
 938     my $debian = "no";
 939     foreach my $os (keys %oses) {
 940         $debian="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "debian";
 941     }
 942     print "debian=$debian\n";
 943 }
 944
 945 =item fullvirt=(yes|no)
 946
 947 Answer C<yes> if there is at least one operating system kernel
 948 installed in the guest which runs fully virtualized.  Such a guest
 949 would require a hypervisor which supports full system virtualization.
 950
 951 =cut
 952
 953 sub output_query_fullvirt
 954 {
 955     # The assumption is full-virt, unless all installed kernels
 956     # are identified as paravirt.
 957     # XXX Fails on Windows guests.
 958     foreach my $os (keys %oses) {
 959         foreach my $kernel (@{$oses{$os}->{kernels}}) {
 960             my $is_pv = $kernel->{version} =~ m/xen/;
 961             unless ($is_pv) {
 962                 print "fullvirt=yes\n";
 963                 return;
 964             }
 965         }
 966     }
 967     print "fullvirt=no\n";
 968 }
 969
 970 =item xen_domU_kernel=(yes|no)
 971
 972 Answer C<yes> if there is at least one Linux kernel installed in
 973 the guest which is compiled as a Xen DomU (a Xen paravirtualized
 974 guest).
 975
 976 =cut
 977
 978 sub output_query_xen_domU_kernel
 979 {
 980     foreach my $os (keys %oses) {
 981         foreach my $kernel (@{$oses{$os}->{kernels}}) {
 982             my $is_xen = $kernel->{version} =~ m/xen/;
 983             if ($is_xen) {
 984                 print "xen_domU_kernel=yes\n";
 985                 return;
 986             }
 987         }
 988     }
 989     print "xen_domU_kernel=no\n";
 990 }
 991
 992 =item xen_pv_drivers=(yes|no)
 993
 994 Answer C<yes> if the guest has Xen paravirtualized drivers installed
 995 (usually the kernel itself will be fully virtualized, but the PV
 996 drivers have been installed by the administrator for performance
 997 reasons).
 998
 999 =cut
1000
1001 sub output_query_xen_pv_drivers
1002 {
1003     foreach my $os (keys %oses) {
1004         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1005             foreach my $module (@{$kernel->{modules}}) {
1006                 if ($module =~ m/xen-/) {
1007                     print "xen_pv_drivers=yes\n";
1008                     return;
1009                 }
1010             }
1011         }
1012     }
1013     print "xen_pv_drivers=no\n";
1014 }
1015
1016 =item virtio_drivers=(yes|no)
1017
1018 Answer C<yes> if the guest has virtio paravirtualized drivers
1019 installed.  Virtio drivers are commonly used to improve the
1020 performance of KVM.
1021
1022 =cut
1023
1024 sub output_query_virtio_drivers
1025 {
1026     foreach my $os (keys %oses) {
1027         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1028             foreach my $module (@{$kernel->{modules}}) {
1029                 if ($module =~ m/virtio_/) {
1030                     print "virtio_drivers=yes\n";
1031                     return;
1032                 }
1033             }
1034         }
1035     }
1036     print "virtio_drivers=no\n";
1037 }
1038
1039 =back
1040
1041 =head1 SEE ALSO
1042
1043 L<guestfs(3)>,
1044 L<guestfish(1)>,
1045 L<Sys::Guestfs(3)>,
1046 L<Sys::Virt(3)>
1047
1048 =head1 AUTHOR
1049
1050 Richard W.M. Jones L<http://et.redhat.com/~rjones/>
1051
1052 =head1 COPYRIGHT
1053
1054 Copyright (C) 2009 Red Hat Inc.
1055
1056 This program is free software; you can redistribute it and/or modify
1057 it under the terms of the GNU General Public License as published by
1058 the Free Software Foundation; either version 2 of the License, or
1059 (at your option) any later version.
1060
1061 This program is distributed in the hope that it will be useful,
1062 but WITHOUT ANY WARRANTY; without even the implied warranty of
1063 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1064 GNU General Public License for more details.
1065
1066 You should have received a copy of the GNU General Public License
1067 along with this program; if not, write to the Free Software
1068 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.