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