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