inspector/virt-inspector.pl

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