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
  27 # Optional:
  28 eval "use Sys::Virt;";
  29
  30 =encoding utf8
  31
  32 =head1 NAME
  33
  34 virt-inspector - Display OS version, kernel, drivers, mount points, applications, etc. in a virtual machine
  35
  36 =head1 SYNOPSIS
  37
  38  virt-inspector [--connect URI] domname
  39
  40  virt-inspector guest.img [guest.img ...]
  41
  42 =head1 DESCRIPTION
  43
  44 B<virt-inspector> examines a virtual machine and tries to determine
  45 the version of the OS, the kernel version, what drivers are installed,
  46 whether the virtual machine is fully virtualized (FV) or
  47 para-virtualized (PV), what applications are installed and more.
  48
  49 Virt-inspector can produce output in several formats, including a
  50 readable text report, and XML for feeding into other programs.
  51
  52 Virt-inspector should only be run on I<inactive> virtual machines.
  53 The program tries to determine that the machine is inactive and will
  54 refuse to run if it thinks you are trying to inspect a running domain.
  55
  56 In the normal usage, use C<virt-inspector domname> where C<domname> is
  57 the libvirt domain (see: C<virsh list --all>).
  58
  59 You can also run virt-inspector directly on disk images from a single
  60 virtual machine.  Use C<virt-inspector guest.img>.  In rare cases a
  61 domain has several block devices, in which case you should list them
  62 one after another, with the first corresponding to the guest's
  63 C</dev/sda>, the second to the guest's C</dev/sdb> and so on.
  64
  65 Virt-inspector can only inspect and report upon I<one domain at a
  66 time>.  To inspect several virtual machines, you have to run
  67 virt-inspector several times (for example, from a shell script
  68 for-loop).
  69
  70 Because virt-inspector needs direct access to guest images, it won't
  71 normally work over remote libvirt connections.
  72
  73 =head1 OPTIONS
  74
  75 =over 4
  76
  77 =cut
  78
  79 my $help;
  80
  81 =item B<--help>
  82
  83 Display brief help.
  84
  85 =cut
  86
  87 my $uri;
  88
  89 =item B<--connect URI> | B<-c URI>
  90
  91 If using libvirt, connect to the given I<URI>.  If omitted,
  92 then we connect to the default libvirt hypervisor.
  93
  94 Libvirt is only used if you specify a C<domname> on the
  95 command line.  If you specify guest block devices directly,
  96 then libvirt is not used at all.
  97
  98 =cut
  99
 100 my $force;
 101
 102 =item B<--force>
 103
 104 Force reading a particular guest even if it appears to
 105 be active, or if the guest image is writable.  This is
 106 dangerous and can even corrupt the guest image.
 107
 108 =cut
 109
 110 my $output = "text";
 111
 112 =item B<--text> (default)
 113
 114 =item B<--xml>
 115
 116 =item B<--perl>
 117
 118 =item B<--fish>
 119
 120 =item B<--ro-fish>
 121
 122 Select the output format.  The default is a readable text report.
 123
 124 If you select I<--xml> then you get XML output which can be fed
 125 to other programs.
 126
 127 If you select I<--perl> then you get Perl structures output which
 128 can be used directly in another Perl program.
 129
 130 If you select I<--fish> then we print a L<guestfish(1)> command
 131 line which will automatically mount up the filesystems on the
 132 correct mount points.  Try this for example:
 133
 134  eval `virt-inspector --fish guest.img`
 135
 136 I<--ro-fish> is the same, but the I<--ro> option is passed to
 137 guestfish so that the filesystems are mounted read-only.
 138
 139 =back
 140
 141 =cut
 142
 143 GetOptions ("help|?" => \$help,
 144             "connect|c=s" => \$uri,
 145             "force" => \$force,
 146             "xml" => sub { $output = "xml" },
 147             "perl" => sub { $output = "perl" },
 148             "fish" => sub { $output = "fish" },
 149             "guestfish" => sub { $output = "fish" },
 150             "ro-fish" => sub { $output = "ro-fish" },
 151             "ro-guestfish" => sub { $output = "ro-fish" })
 152     or pod2usage (2);
 153 pod2usage (1) if $help;
 154 pod2usage ("$0: no image or VM names given") if @ARGV == 0;
 155
 156 # Domain name or guest image(s)?
 157
 158 my @images;
 159 if (-e $ARGV[0]) {
 160     @images = @ARGV;
 161
 162     # Until we get an 'add_drive_ro' call, we must check that qemu
 163     # will only open this image in readonly mode.
 164     # XXX Remove this hack at some point ...  or at least push it
 165     # into libguestfs.
 166
 167     foreach (@images) {
 168         if (! -r $_) {
 169             die "guest image $_ does not exist or is not readable\n"
 170         } elsif (-w $_ && !$force) {
 171             die ("guest image $_ is writable! REFUSING TO PROCEED.\n".
 172                  "You can use --force to override this BUT that action\n".
 173                  "MAY CORRUPT THE DISK IMAGE.\n");
 174         }
 175     }
 176 } else {
 177     die "no libvirt support (install Sys::Virt)"
 178         unless exists $INC{"Sys/Virt.pm"};
 179
 180     pod2usage ("$0: too many domains listed on command line") if @ARGV > 1;
 181
 182     my $vmm;
 183     if (defined $uri) {
 184         $vmm = Sys::Virt->new (uri => $uri, readonly => 1);
 185     } else {
 186         $vmm = Sys::Virt->new (readonly => 1);
 187     }
 188     die "cannot connect to libvirt $uri\n" unless $vmm;
 189
 190     my @doms = $vmm->list_defined_domains ();
 191     my $dom;
 192     foreach (@doms) {
 193         if ($_->get_name () eq $ARGV[0]) {
 194             $dom = $_;
 195             last;
 196         }
 197     }
 198     die "$ARGV[0] is not the name of an inactive libvirt domain\n"
 199         unless $dom;
 200
 201     # Get the names of the image(s).
 202     my $xml = $dom->get_xml_description ();
 203
 204     my $p = new XML::XPath::XMLParser (xml => $xml);
 205     my $disks = $p->find ("//devices/disk");
 206     print "disks:\n";
 207     foreach ($disks->get_nodelist) {
 208         print XML::XPath::XMLParser::as_string($_);
 209     }
 210
 211     die "XXX"
 212 }
 213
 214 # We've now got the list of @images, so feed them to libguestfs.
 215 my $g = Sys::Guestfs->new ();
 216 $g->add_drive ($_) foreach @images;
 217 $g->launch ();
 218 $g->wait_ready ();
 219
 220 # We want to get the list of LVs and partitions (ie. anything that
 221 # could contain a filesystem).  Discard any partitions which are PVs.
 222 my @partitions = $g->list_partitions ();
 223 my @pvs = $g->pvs ();
 224 sub is_pv {
 225     my $t = shift;
 226     foreach (@pvs) {
 227         return 1 if $_ eq $t;
 228     }
 229     0;
 230 }
 231 @partitions = grep { ! is_pv ($_) } @partitions;
 232
 233 my @lvs = $g->lvs ();
 234
 235 =head1 OUTPUT FORMAT
 236
 237  Operating system(s)
 238  -------------------
 239  Linux (distro + version)
 240  Windows (version)
 241     |
 242     |
 243     +--- Filesystems ---------- Installed apps --- Kernel & drivers
 244          -----------            --------------     ----------------
 245          mount point => device  List of apps       Extra information
 246          mount point => device  and versions       about kernel(s)
 247               ...                                  and drivers
 248          swap => swap device
 249          (plus lots of extra information
 250          about each filesystem)
 251
 252 The output of virt-inspector is a complex two-level data structure.
 253
 254 At the top level is a list of the operating systems installed on the
 255 guest.  (For the vast majority of guests, only a single OS is
 256 installed.)  The data returned for the OS includes the name (Linux,
 257 Windows), the distribution and version.
 258
 259 The diagram above shows what we return for each OS.
 260
 261 With the I<--xml> option the output is mapped into an XML document.
 262 Unfortunately there is no clear schema for this document
 263 (contributions welcome) but you can get an idea of the format by
 264 looking at other documents and as a last resort the source for this
 265 program.
 266
 267 With the I<--fish> or I<--ro-fish> option the mount points are mapped to
 268 L<guestfish(1)> command line parameters, so that you can go in
 269 afterwards and inspect the guest with everything mounted in the
 270 right place.  For example:
 271
 272  eval `virt-inspector --ro-fish guest.img`
 273  ==> guestfish --ro -a guest.img -m /dev/VG/LV:/ -m /dev/sda1:/boot
 274
 275 =cut
 276
 277 # List of possible filesystems.
 278 my @devices = sort (@lvs, @partitions);
 279
 280 # Now query each one to build up a picture of what's in it.
 281 my %fses = map { $_ => check_fs ($_) } @devices;
 282
 283 # Now the complex checking code itself.
 284 # check_fs takes a device name (LV or partition name) and returns
 285 # a hashref containing everything we can find out about the device.
 286 sub check_fs {
 287     local $_;
 288     my $dev = shift;            # LV or partition name.
 289
 290     my %r;                      # Result hash.
 291
 292     # First try 'file(1)' on it.
 293     my $file = $g->file ($dev);
 294     if ($file =~ /ext2 filesystem data/) {
 295         $r{fstype} = "ext2";
 296         $r{fsos} = "linux";
 297     } elsif ($file =~ /ext3 filesystem data/) {
 298         $r{fstype} = "ext3";
 299         $r{fsos} = "linux";
 300     } elsif ($file =~ /ext4 filesystem data/) {
 301         $r{fstype} = "ext4";
 302         $r{fsos} = "linux";
 303     } elsif ($file =~ m{Linux/i386 swap file}) {
 304         $r{fstype} = "swap";
 305         $r{fsos} = "linux";
 306         $r{is_swap} = 1;
 307     }
 308
 309     # If it's ext2/3/4, then we want the UUID and label.
 310     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
 311         $r{uuid} = $g->get_e2uuid ($dev);
 312         $r{label} = $g->get_e2label ($dev);
 313     }
 314
 315     # Try mounting it, fnarrr.
 316     if (!$r{is_swap}) {
 317         $r{is_mountable} = 1;
 318         eval { $g->mount_ro ($dev, "/") };
 319         if ($@) {
 320             # It's not mountable, probably empty or some format
 321             # we don't understand.
 322             $r{is_mountable} = 0;
 323             goto OUT;
 324         }
 325
 326         # Grub /boot?
 327         if ($g->is_file ("/grub/menu.lst") ||
 328             $g->is_file ("/grub/grub.conf")) {
 329             $r{content} = "linux-grub";
 330             check_grub (\%r);
 331             goto OUT;
 332         }
 333
 334         # Linux root?
 335         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 336             $g->is_file ("/etc/fstab")) {
 337             $r{content} = "linux-root";
 338             $r{is_root} = 1;
 339             check_linux_root (\%r);
 340             goto OUT;
 341         }
 342
 343         # Linux /usr/local.
 344         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 345             $g->is_dir ("/share") && !$g->exists ("/local") &&
 346             !$g->is_file ("/etc/fstab")) {
 347             $r{content} = "linux-usrlocal";
 348             goto OUT;
 349         }
 350
 351         # Linux /usr.
 352         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
 353             $g->is_dir ("/share") && $g->exists ("/local") &&
 354             !$g->is_file ("/etc/fstab")) {
 355             $r{content} = "linux-usr";
 356             goto OUT;
 357         }
 358
 359         # Windows root?
 360         if ($g->is_file ("/AUTOEXEC.BAT") ||
 361             $g->is_file ("/autoexec.bat") ||
 362             $g->is_dir ("/Program Files") ||
 363             $g->is_dir ("/WINDOWS") ||
 364             $g->is_file ("/ntldr")) {
 365             $r{fstype} = "ntfs"; # XXX this is a guess
 366             $r{fsos} = "windows";
 367             $r{content} = "windows-root";
 368             $r{is_root} = 1;
 369             check_windows_root (\%r);
 370             goto OUT;
 371         }
 372     }
 373
 374   OUT:
 375     $g->umount_all ();
 376     return \%r;
 377 }
 378
 379 sub check_linux_root
 380 {
 381     local $_;
 382     my $r = shift;
 383
 384     # Look into /etc to see if we recognise the operating system.
 385     if ($g->is_file ("/etc/redhat-release")) {
 386         $_ = $g->cat ("/etc/redhat-release");
 387         if (/Fedora release (\d+\.\d+)/) {
 388             $r->{osdistro} = "fedora";
 389             $r->{osversion} = "$1"
 390         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) {
 391             $r->{osdistro} = "redhat";
 392             $r->{osversion} = "$2.$3";
 393         } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) {
 394             $r->{osdistro} = "redhat";
 395             $r->{osversion} = "$2";
 396         } else {
 397             $r->{osdistro} = "redhat";
 398         }
 399     } elsif ($g->is_file ("/etc/debian_version")) {
 400         $_ = $g->cat ("/etc/debian_version");
 401         if (/(\d+\.\d+)/) {
 402             $r->{osdistro} = "debian";
 403             $r->{osversion} = "$1";
 404         } else {
 405             $r->{osdistro} = "debian";
 406         }
 407     }
 408
 409     # Parse the contents of /etc/fstab.  This is pretty vital so
 410     # we can determine where filesystems are supposed to be mounted.
 411     eval "\$_ = \$g->cat ('/etc/fstab');";
 412     if (!$@ && $_) {
 413         my @lines = split /\n/;
 414         my @fstab;
 415         foreach (@lines) {
 416             my @fields = split /[ \t]+/;
 417             if (@fields >= 2) {
 418                 my $spec = $fields[0]; # first column (dev/label/uuid)
 419                 my $file = $fields[1]; # second column (mountpoint)
 420                 if ($spec =~ m{^/} ||
 421                     $spec =~ m{^LABEL=} ||
 422                     $spec =~ m{^UUID=} ||
 423                     $file eq "swap") {
 424                     push @fstab, [$spec, $file]
 425                 }
 426             }
 427         }
 428         $r->{fstab} = \@fstab if @fstab;
 429     }
 430 }
 431
 432 sub check_windows_root
 433 {
 434     local $_;
 435     my $r = shift;
 436
 437     # XXX Windows version.
 438     # List of applications.
 439 }
 440
 441 sub check_grub
 442 {
 443     local $_;
 444     my $r = shift;
 445
 446     # XXX Kernel versions, grub version.
 447 }
 448
 449 #print Dumper (\%fses);
 450
 451 #----------------------------------------------------------------------
 452 # Now find out how many operating systems we've got.  Usually just one.
 453
 454 my %oses = ();
 455
 456 foreach (sort keys %fses) {
 457     if ($fses{$_}->{is_root}) {
 458         my %r = (
 459             root => $fses{$_},
 460             root_device => $_
 461         );
 462         get_os_version (\%r);
 463         assign_mount_points (\%r);
 464         $oses{$_} = \%r;
 465     }
 466 }
 467
 468 sub get_os_version
 469 {
 470     local $_;
 471     my $r = shift;
 472
 473     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 474     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 475     $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
 476 }
 477
 478 sub assign_mount_points
 479 {
 480     local $_;
 481     my $r = shift;
 482
 483     $r->{mounts} = { "/" => $r->{root_device} };
 484     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 485
 486     # Use /etc/fstab if we have it to mount the rest.
 487     if (exists $r->{root}->{fstab}) {
 488         my @fstab = @{$r->{root}->{fstab}};
 489         foreach (@fstab) {
 490             my ($spec, $file) = @$_;
 491
 492             my ($dev, $fs) = find_filesystem ($spec);
 493             if ($dev) {
 494                 $r->{mounts}->{$file} = $dev;
 495                 $r->{filesystems}->{$dev} = $fs;
 496                 if (exists $fs->{used}) {
 497                     $fs->{used}++
 498                 } else {
 499                     $fs->{used} = 1
 500                 }
 501             }
 502         }
 503     }
 504 }
 505
 506 # Find filesystem by device name, LABEL=.. or UUID=..
 507 sub find_filesystem
 508 {
 509     local $_ = shift;
 510
 511     if (/^LABEL=(.*)/) {
 512         my $label = $1;
 513         foreach (sort keys %fses) {
 514             if (exists $fses{$_}->{label} &&
 515                 $fses{$_}->{label} eq $label) {
 516                 return ($_, $fses{$_});
 517             }
 518         }
 519         warn "unknown filesystem label $label\n";
 520         return ();
 521     } elsif (/^UUID=(.*)/) {
 522         my $uuid = $1;
 523         foreach (sort keys %fses) {
 524             if (exists $fses{$_}->{uuid} &&
 525                 $fses{$_}->{uuid} eq $uuid) {
 526                 return ($_, $fses{$_});
 527             }
 528         }
 529         warn "unknown filesystem UUID $uuid\n";
 530         return ();
 531     } else {
 532         return ($_, $fses{$_}) if exists $fses{$_};
 533
 534         if (m{^/dev/hd(.*)} && exists $fses{"/dev/sd$1"}) {
 535             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 536         }
 537         if (m{^/dev/xvd(.*)} && exists $fses{"/dev/sd$1"}) {
 538             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 539         }
 540
 541         return () if m{/dev/cdrom};
 542
 543         warn "unknown filesystem $_\n";
 544         return ();
 545     }
 546 }
 547
 548 #print Dumper(\%oses);
 549
 550 #----------------------------------------------------------------------
 551 # Mount up the disks so we can check for applications
 552 # and kernels.  Skip this if the output is "*fish" because
 553 # we don't need to know.
 554
 555 if ($output !~ /.*fish$/) {
 556     my $root_dev;
 557     foreach $root_dev (sort keys %oses) {
 558         my $mounts = $oses{$root_dev}->{mounts};
 559         # Have to mount / first.  Luckily '/' is early in the ASCII
 560         # character set, so this should be OK.
 561         foreach (sort keys %$mounts) {
 562             $g->mount_ro ($mounts->{$_}, $_)
 563                 if $_ ne "swap" && ($_ eq '/' || $g->is_dir ($_));
 564         }
 565
 566         check_for_applications ($root_dev);
 567         check_for_kernels ($root_dev);
 568
 569         # umount_all in libguestfs is buggy - it doesn't unmount
 570         # filesystems in the correct order.  So let's unmount them
 571         # in reverse first before calling umount_all as a last resort.
 572         foreach (sort { $b cmp $a } keys %$mounts) {
 573             eval "\$g->umount ('$_')";
 574         }
 575         $g->umount_all ();
 576     }
 577 }
 578
 579 sub check_for_applications
 580 {
 581     local $_;
 582     my $root_dev = shift;
 583
 584     # XXX rpm -qa, look in Program Files, or whatever
 585 }
 586
 587 sub check_for_kernels
 588 {
 589     local $_;
 590     my $root_dev = shift;
 591
 592     # XXX
 593 }
 594
 595 #----------------------------------------------------------------------
 596 # Output.
 597
 598 if ($output eq "fish" || $output eq "ro-fish") {
 599     my @osdevs = keys %oses;
 600     # This only works if there is a single OS.
 601     die "--fish output is only possible with a single OS\n" if @osdevs != 1;
 602
 603     my $root_dev = $osdevs[0];
 604
 605     print "guestfish";
 606     if ($output eq "ro-fish") {
 607         print " --ro";
 608     }
 609
 610     print " -a $_" foreach @images;
 611
 612     my $mounts = $oses{$root_dev}->{mounts};
 613     # Have to mount / first.  Luckily '/' is early in the ASCII
 614     # character set, so this should be OK.
 615     foreach (sort keys %$mounts) {
 616         print " -m $mounts->{$_}:$_" if $_ ne "swap";
 617     }
 618     print "\n"
 619 }
 620
 621 # Perl output.
 622 elsif ($output eq "perl") {
 623     print Dumper(\%oses);
 624 }
 625
 626 # Plain text output (the default).
 627 elsif ($output eq "text") {
 628     # XXX text output.
 629
 630
 631
 632
 633
 634 }
 635
 636 # XML output.
 637 elsif ($output eq "xml") {
 638     # XXX XML output.
 639
 640
 641
 642
 643
 644
 645
 646 }
 647
 648 =head1 SEE ALSO
 649
 650 L<guestfs(3)>,
 651 L<guestfish(1)>,
 652 L<Sys::Guestfs(3)>,
 653 L<Sys::Virt(3)>
 654
 655 =head1 AUTHOR
 656
 657 Richard W.M. Jones L<http://et.redhat.com/~rjones/>
 658
 659 =head1 COPYRIGHT
 660
 661 Copyright (C) 2009 Red Hat Inc.
 662
 663 This program is free software; you can redistribute it and/or modify
 664 it under the terms of the GNU General Public License as published by
 665 the Free Software Foundation; either version 2 of the License, or
 666 (at your option) any later version.
 667
 668 This program is distributed in the hope that it will be useful,
 669 but WITHOUT ANY WARRANTY; without even the implied warranty of
 670 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 671 GNU General Public License for more details.
 672
 673 You should have received a copy of the GNU General Public License
 674 along with this program; if not, write to the Free Software
 675 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.