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