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  guestfish $(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  guestfish $(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     if ($output eq "ro-fish") {
 909         print "--ro ";
 910     }
 911
 912     print "-a $_ " foreach @images;
 913
 914     my $mounts = $oses{$root_dev}->{mounts};
 915     # Have to mount / first.  Luckily '/' is early in the ASCII
 916     # character set, so this should be OK.
 917     foreach (sort keys %$mounts) {
 918         print "-m $mounts->{$_}:$_ " if $_ ne "swap";
 919     }
 920     print "\n"
 921 }
 922
 923 # Perl output.
 924 elsif ($output eq "perl") {
 925     print Dumper(\%oses);
 926 }
 927
 928 # Plain text output (the default).
 929 elsif ($output eq "text") {
 930     output_text ();
 931 }
 932
 933 # XML output.
 934 elsif ($output eq "xml") {
 935     output_xml ();
 936 }
 937
 938 # Query mode.
 939 elsif ($output eq "query") {
 940     output_query ();
 941 }
 942
 943 sub output_text
 944 {
 945     output_text_os ($oses{$_}) foreach sort keys %oses;
 946 }
 947
 948 sub output_text_os
 949 {
 950     my $os = shift;
 951
 952     print $os->{os}, " " if exists $os->{os};
 953     print $os->{distro}, " " if exists $os->{distro};
 954     print $os->{version}, " " if exists $os->{version};
 955     print "on ", $os->{root_device}, ":\n";
 956
 957     print "  Mountpoints:\n";
 958     my $mounts = $os->{mounts};
 959     foreach (sort keys %$mounts) {
 960         printf "    %-30s %s\n", $mounts->{$_}, $_
 961     }
 962
 963     print "  Filesystems:\n";
 964     my $filesystems = $os->{filesystems};
 965     foreach (sort keys %$filesystems) {
 966         print "    $_:\n";
 967         print "      label: $filesystems->{$_}{label}\n"
 968             if exists $filesystems->{$_}{label};
 969         print "      UUID: $filesystems->{$_}{uuid}\n"
 970             if exists $filesystems->{$_}{uuid};
 971         print "      type: $filesystems->{$_}{fstype}\n"
 972             if exists $filesystems->{$_}{fstype};
 973         print "      content: $filesystems->{$_}{content}\n"
 974             if exists $filesystems->{$_}{content};
 975     }
 976
 977     if (exists $os->{modprobe_aliases}) {
 978         my %aliases = %{$os->{modprobe_aliases}};
 979         my @keys = sort keys %aliases;
 980         if (@keys) {
 981             print "  Modprobe aliases:\n";
 982             foreach (@keys) {
 983                 printf "    %-30s %s\n", $_, $aliases{$_}
 984             }
 985         }
 986     }
 987
 988     if (exists $os->{initrd_modules}) {
 989         my %modvers = %{$os->{initrd_modules}};
 990         my @keys = sort keys %modvers;
 991         if (@keys) {
 992             print "  Initrd modules:\n";
 993             foreach (@keys) {
 994                 my @modules = @{$modvers{$_}};
 995                 print "    $_:\n";
 996                 print "      $_\n" foreach @modules;
 997             }
 998         }
 999     }
1000
1001     print "  Applications:\n";
1002     my @apps =  @{$os->{apps}};
1003     foreach (@apps) {
1004         print "    $_->{name} $_->{version}\n"
1005     }
1006
1007     print "  Kernels:\n";
1008     my @kernels = @{$os->{kernels}};
1009     foreach (@kernels) {
1010         print "    $_->{version}\n";
1011         my @modules = @{$_->{modules}};
1012         foreach (@modules) {
1013             print "      $_\n";
1014         }
1015     }
1016
1017     if (exists $os->{root}->{registry}) {
1018         print "  Windows Registry entries:\n";
1019         # These are just lumps of text - dump them out.
1020         foreach (@{$os->{root}->{registry}}) {
1021             print "$_\n";
1022         }
1023     }
1024 }
1025
1026 sub output_xml
1027 {
1028     print "<operatingsystems>\n";
1029     output_xml_os ($oses{$_}) foreach sort keys %oses;
1030     print "</operatingsystems>\n";
1031 }
1032
1033 sub output_xml_os
1034 {
1035     my $os = shift;
1036
1037     print "<operatingsystem>\n";
1038
1039     print "<os>", $os->{os}, "</os>\n" if exists $os->{os};
1040     print "<distro>", $os->{distro}, "</distro>\n" if exists $os->{distro};
1041     print "<version>", $os->{version}, "</version>\n" if exists $os->{version};
1042     print "<root>", $os->{root_device}, "</root>\n";
1043
1044     print "<mountpoints>\n";
1045     my $mounts = $os->{mounts};
1046     foreach (sort keys %$mounts) {
1047         printf "<mountpoint dev='%s'>%s</mountpoint>\n",
1048           $mounts->{$_}, $_
1049     }
1050     print "</mountpoints>\n";
1051
1052     print "<filesystems>\n";
1053     my $filesystems = $os->{filesystems};
1054     foreach (sort keys %$filesystems) {
1055         print "<filesystem dev='$_'>\n";
1056         print "<label>$filesystems->{$_}{label}</label>\n"
1057             if exists $filesystems->{$_}{label};
1058         print "<uuid>$filesystems->{$_}{uuid}</uuid>\n"
1059             if exists $filesystems->{$_}{uuid};
1060         print "<type>$filesystems->{$_}{fstype}</type>\n"
1061             if exists $filesystems->{$_}{fstype};
1062         print "<content>$filesystems->{$_}{content}</content>\n"
1063             if exists $filesystems->{$_}{content};
1064         print "</filesystem>\n";
1065     }
1066     print "</filesystems>\n";
1067
1068     if (exists $os->{modprobe_aliases}) {
1069         my %aliases = %{$os->{modprobe_aliases}};
1070         my @keys = sort keys %aliases;
1071         if (@keys) {
1072             print "<modprobealiases>\n";
1073             foreach (@keys) {
1074                 printf "<alias device=\"%s\">%s</alias>\n", $_, $aliases{$_}
1075             }
1076             print "</modprobealiases>\n";
1077         }
1078     }
1079
1080     if (exists $os->{initrd_modules}) {
1081         my %modvers = %{$os->{initrd_modules}};
1082         my @keys = sort keys %modvers;
1083         if (@keys) {
1084             print "<initrds>\n";
1085             foreach (@keys) {
1086                 my @modules = @{$modvers{$_}};
1087                 print "<initrd version=\"$_\">\n";
1088                 print "<module>$_</module>\n" foreach @modules;
1089                 print "</initrd>\n";
1090             }
1091             print "</initrds>\n";
1092         }
1093     }
1094
1095     print "<applications>\n";
1096     my @apps =  @{$os->{apps}};
1097     foreach (@apps) {
1098         print "<application>\n";
1099         print "<name>$_->{name}</name><version>$_->{version}</version>\n";
1100         print "</application>\n";
1101     }
1102     print "</applications>\n";
1103
1104     print "<kernels>\n";
1105     my @kernels = @{$os->{kernels}};
1106     foreach (@kernels) {
1107         print "<kernel>\n";
1108         print "<version>$_->{version}</version>\n";
1109         print "<modules>\n";
1110         my @modules = @{$_->{modules}};
1111         foreach (@modules) {
1112             print "<module>$_</module>\n";
1113         }
1114         print "</modules>\n";
1115         print "</kernel>\n";
1116     }
1117     print "</kernels>\n";
1118
1119     if (exists $os->{root}->{registry}) {
1120         print "<windowsregistryentries>\n";
1121         # These are just lumps of text - dump them out.
1122         foreach (@{$os->{root}->{registry}}) {
1123             print "<windowsregistryentry>\n";
1124             print escape_xml($_), "\n";
1125             print "</windowsregistryentry>\n";
1126         }
1127         print "</windowsregistryentries>\n";
1128     }
1129
1130     print "</operatingsystem>\n";
1131 }
1132
1133 sub escape_xml
1134 {
1135     local $_ = shift;
1136
1137     s/&/&amp;/g;
1138     s/</&lt;/g;
1139     s/>/&gt;/g;
1140     return $_;
1141 }
1142
1143 =head1 QUERY MODE
1144
1145 When you use C<virt-inspector --query>, the output is a series of
1146 lines of the form:
1147
1148  windows=no
1149  linux=yes
1150  fullvirt=yes
1151  xen_pv_drivers=no
1152
1153 (each answer is usually C<yes> or C<no>, or the line is completely
1154 missing if we could not determine the answer at all).
1155
1156 If the guest is multiboot, you can get apparently conflicting answers
1157 (eg. C<windows=yes> and C<linux=yes>, or a guest which is both
1158 fullvirt and has a Xen PV kernel).  This is normal, and just means
1159 that the guest can do both things, although it might require operator
1160 intervention such as selecting a boot option when the guest is
1161 booting.
1162
1163 This section describes the full range of answers possible.
1164
1165 =over 4
1166
1167 =cut
1168
1169 sub output_query
1170 {
1171     output_query_windows ();
1172     output_query_linux ();
1173     output_query_rhel ();
1174     output_query_fedora ();
1175     output_query_debian ();
1176     output_query_fullvirt ();
1177     output_query_xen_domU_kernel ();
1178     output_query_xen_pv_drivers ();
1179     output_query_virtio_drivers ();
1180 }
1181
1182 =item windows=(yes|no)
1183
1184 Answer C<yes> if Microsoft Windows is installed in the guest.
1185
1186 =cut
1187
1188 sub output_query_windows
1189 {
1190     my $windows = "no";
1191     foreach my $os (keys %oses) {
1192         $windows="yes" if $oses{$os}->{os} eq "windows";
1193     }
1194     print "windows=$windows\n";
1195 }
1196
1197 =item linux=(yes|no)
1198
1199 Answer C<yes> if a Linux kernel is installed in the guest.
1200
1201 =cut
1202
1203 sub output_query_linux
1204 {
1205     my $linux = "no";
1206     foreach my $os (keys %oses) {
1207         $linux="yes" if $oses{$os}->{os} eq "linux";
1208     }
1209     print "linux=$linux\n";
1210 }
1211
1212 =item rhel=(yes|no)
1213
1214 Answer C<yes> if the guest contains Red Hat Enterprise Linux.
1215
1216 =cut
1217
1218 sub output_query_rhel
1219 {
1220     my $rhel = "no";
1221     foreach my $os (keys %oses) {
1222         $rhel="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "redhat";
1223     }
1224     print "rhel=$rhel\n";
1225 }
1226
1227 =item fedora=(yes|no)
1228
1229 Answer C<yes> if the guest contains the Fedora Linux distribution.
1230
1231 =cut
1232
1233 sub output_query_fedora
1234 {
1235     my $fedora = "no";
1236     foreach my $os (keys %oses) {
1237         $fedora="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "fedora";
1238     }
1239     print "fedora=$fedora\n";
1240 }
1241
1242 =item debian=(yes|no)
1243
1244 Answer C<yes> if the guest contains the Debian Linux distribution.
1245
1246 =cut
1247
1248 sub output_query_debian
1249 {
1250     my $debian = "no";
1251     foreach my $os (keys %oses) {
1252         $debian="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "debian";
1253     }
1254     print "debian=$debian\n";
1255 }
1256
1257 =item fullvirt=(yes|no)
1258
1259 Answer C<yes> if there is at least one operating system kernel
1260 installed in the guest which runs fully virtualized.  Such a guest
1261 would require a hypervisor which supports full system virtualization.
1262
1263 =cut
1264
1265 sub output_query_fullvirt
1266 {
1267     # The assumption is full-virt, unless all installed kernels
1268     # are identified as paravirt.
1269     # XXX Fails on Windows guests.
1270     foreach my $os (keys %oses) {
1271         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1272             my $is_pv = $kernel->{version} =~ m/xen/;
1273             unless ($is_pv) {
1274                 print "fullvirt=yes\n";
1275                 return;
1276             }
1277         }
1278     }
1279     print "fullvirt=no\n";
1280 }
1281
1282 =item xen_domU_kernel=(yes|no)
1283
1284 Answer C<yes> if there is at least one Linux kernel installed in
1285 the guest which is compiled as a Xen DomU (a Xen paravirtualized
1286 guest).
1287
1288 =cut
1289
1290 sub output_query_xen_domU_kernel
1291 {
1292     foreach my $os (keys %oses) {
1293         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1294             my $is_xen = $kernel->{version} =~ m/xen/;
1295             if ($is_xen) {
1296                 print "xen_domU_kernel=yes\n";
1297                 return;
1298             }
1299         }
1300     }
1301     print "xen_domU_kernel=no\n";
1302 }
1303
1304 =item xen_pv_drivers=(yes|no)
1305
1306 Answer C<yes> if the guest has Xen paravirtualized drivers installed
1307 (usually the kernel itself will be fully virtualized, but the PV
1308 drivers have been installed by the administrator for performance
1309 reasons).
1310
1311 =cut
1312
1313 sub output_query_xen_pv_drivers
1314 {
1315     foreach my $os (keys %oses) {
1316         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1317             foreach my $module (@{$kernel->{modules}}) {
1318                 if ($module =~ m/xen-/) {
1319                     print "xen_pv_drivers=yes\n";
1320                     return;
1321                 }
1322             }
1323         }
1324     }
1325     print "xen_pv_drivers=no\n";
1326 }
1327
1328 =item virtio_drivers=(yes|no)
1329
1330 Answer C<yes> if the guest has virtio paravirtualized drivers
1331 installed.  Virtio drivers are commonly used to improve the
1332 performance of KVM.
1333
1334 =cut
1335
1336 sub output_query_virtio_drivers
1337 {
1338     foreach my $os (keys %oses) {
1339         foreach my $kernel (@{$oses{$os}->{kernels}}) {
1340             foreach my $module (@{$kernel->{modules}}) {
1341                 if ($module =~ m/virtio_/) {
1342                     print "virtio_drivers=yes\n";
1343                     return;
1344                 }
1345             }
1346         }
1347     }
1348     print "virtio_drivers=no\n";
1349 }
1350
1351 =back
1352
1353 =head1 SEE ALSO
1354
1355 L<guestfs(3)>,
1356 L<guestfish(1)>,
1357 L<Sys::Guestfs(3)>,
1358 L<Sys::Virt(3)>,
1359 L<http://libguestfs.org/>.
1360
1361 For Windows registry parsing we require the C<reged> program
1362 from L<http://home.eunet.no/~pnordahl/ntpasswd/>.
1363
1364 =head1 AUTHOR
1365
1366 Richard W.M. Jones L<http://et.redhat.com/~rjones/>
1367
1368 =head1 COPYRIGHT
1369
1370 Copyright (C) 2009 Red Hat Inc.
1371
1372 This program is free software; you can redistribute it and/or modify
1373 it under the terms of the GNU General Public License as published by
1374 the Free Software Foundation; either version 2 of the License, or
1375 (at your option) any later version.
1376
1377 This program is distributed in the hope that it will be useful,
1378 but WITHOUT ANY WARRANTY; without even the implied warranty of
1379 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1380 GNU General Public License for more details.
1381
1382 You should have received a copy of the GNU General Public License
1383 along with this program; if not, write to the Free Software
1384 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.