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