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