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