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