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