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