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