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_ro ($_) 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     # Windows version?
 438 }
 439
 440 sub check_grub
 441 {
 442     local $_;
 443     my $r = shift;
 444
 445     # Grub version, if we care.
 446 }
 447
 448 #print Dumper (\%fses);
 449
 450 #----------------------------------------------------------------------
 451 # Now find out how many operating systems we've got.  Usually just one.
 452
 453 my %oses = ();
 454
 455 foreach (sort keys %fses) {
 456     if ($fses{$_}->{is_root}) {
 457         my %r = (
 458             root => $fses{$_},
 459             root_device => $_
 460         );
 461         get_os_version (\%r);
 462         assign_mount_points (\%r);
 463         $oses{$_} = \%r;
 464     }
 465 }
 466
 467 sub get_os_version
 468 {
 469     local $_;
 470     my $r = shift;
 471
 472     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
 473     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
 474     $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion};
 475 }
 476
 477 sub assign_mount_points
 478 {
 479     local $_;
 480     my $r = shift;
 481
 482     $r->{mounts} = { "/" => $r->{root_device} };
 483     $r->{filesystems} = { $r->{root_device} => $r->{root} };
 484
 485     # Use /etc/fstab if we have it to mount the rest.
 486     if (exists $r->{root}->{fstab}) {
 487         my @fstab = @{$r->{root}->{fstab}};
 488         foreach (@fstab) {
 489             my ($spec, $file) = @$_;
 490
 491             my ($dev, $fs) = find_filesystem ($spec);
 492             if ($dev) {
 493                 $r->{mounts}->{$file} = $dev;
 494                 $r->{filesystems}->{$dev} = $fs;
 495                 if (exists $fs->{used}) {
 496                     $fs->{used}++
 497                 } else {
 498                     $fs->{used} = 1
 499                 }
 500             }
 501         }
 502     }
 503 }
 504
 505 # Find filesystem by device name, LABEL=.. or UUID=..
 506 sub find_filesystem
 507 {
 508     local $_ = shift;
 509
 510     if (/^LABEL=(.*)/) {
 511         my $label = $1;
 512         foreach (sort keys %fses) {
 513             if (exists $fses{$_}->{label} &&
 514                 $fses{$_}->{label} eq $label) {
 515                 return ($_, $fses{$_});
 516             }
 517         }
 518         warn "unknown filesystem label $label\n";
 519         return ();
 520     } elsif (/^UUID=(.*)/) {
 521         my $uuid = $1;
 522         foreach (sort keys %fses) {
 523             if (exists $fses{$_}->{uuid} &&
 524                 $fses{$_}->{uuid} eq $uuid) {
 525                 return ($_, $fses{$_});
 526             }
 527         }
 528         warn "unknown filesystem UUID $uuid\n";
 529         return ();
 530     } else {
 531         return ($_, $fses{$_}) if exists $fses{$_};
 532
 533         if (m{^/dev/hd(.*)} && exists $fses{"/dev/sd$1"}) {
 534             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 535         }
 536         if (m{^/dev/xvd(.*)} && exists $fses{"/dev/sd$1"}) {
 537             return ("/dev/sd$1", $fses{"/dev/sd$1"});
 538         }
 539
 540         return () if m{/dev/cdrom};
 541
 542         warn "unknown filesystem $_\n";
 543         return ();
 544     }
 545 }
 546
 547 #print Dumper(\%oses);
 548
 549 #----------------------------------------------------------------------
 550 # Mount up the disks so we can check for applications
 551 # and kernels.  Skip this if the output is "*fish" because
 552 # we don't need to know.
 553
 554 if ($output !~ /.*fish$/) {
 555     my $root_dev;
 556     foreach $root_dev (sort keys %oses) {
 557         my $mounts = $oses{$root_dev}->{mounts};
 558         # Have to mount / first.  Luckily '/' is early in the ASCII
 559         # character set, so this should be OK.
 560         foreach (sort keys %$mounts) {
 561             $g->mount_ro ($mounts->{$_}, $_)
 562                 if $_ ne "swap" && ($_ eq '/' || $g->is_dir ($_));
 563         }
 564
 565         check_for_applications ($root_dev);
 566         check_for_kernels ($root_dev);
 567
 568         $g->umount_all ();
 569     }
 570 }
 571
 572 sub check_for_applications
 573 {
 574     local $_;
 575     my $root_dev = shift;
 576
 577     my @apps;
 578
 579     my $os = $oses{$root_dev}->{os};
 580     if ($os eq "linux") {
 581         my $distro = $oses{$root_dev}->{distro};
 582         if ($distro eq "redhat") {
 583             my @lines = $g->command_lines
 584                 (["rpm", "-q", "-a", "--qf",
 585                   "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
 586             foreach (@lines) {
 587                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
 588                     my $epoch = $2;
 589                     $epoch = "" if $epoch eq "(none)";
 590                     my $app = {
 591                         name => $1,
 592                         epoch => $epoch,
 593                         version => $3,
 594                         release => $4,
 595                         arch => $5
 596                     };
 597                     push @apps, $app
 598                 }
 599             }
 600         }
 601     } elsif ($os eq "windows") {
 602         # XXX
 603         # I worked out a general plan for this, but haven't
 604         # implemented it yet.  We can iterate over /Program Files
 605         # looking for *.EXE files, which we download, then use
 606         # i686-pc-mingw32-windres on, to find the VERSIONINFO
 607         # section, which has a lot of useful information.
 608     }
 609
 610     $oses{$root_dev}->{apps} = \@apps;
 611 }
 612
 613 sub check_for_kernels
 614 {
 615     local $_;
 616     my $root_dev = shift;
 617
 618     my @kernels;
 619
 620     my $os = $oses{$root_dev}->{os};
 621     if ($os eq "linux") {
 622         # Installed kernels will have a corresponding /lib/modules/<version>
 623         # directory, which is the easiest way to find out what kernels
 624         # are installed, and what modules are available.
 625         foreach ($g->ls ("/lib/modules")) {
 626             if ($g->is_dir ("/lib/modules/$_")) {
 627                 my %kernel;
 628                 $kernel{version} = $_;
 629
 630                 # List modules.
 631                 my @modules;
 632                 foreach ($g->find ("/lib/modules/$_")) {
 633                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
 634                         push @modules, $1;
 635                     }
 636                 }
 637
 638                 $kernel{modules} = \@modules;
 639
 640                 push @kernels, \%kernel;
 641             }
 642         }
 643
 644     } elsif ($os eq "windows") {
 645         # XXX
 646     }
 647
 648     $oses{$root_dev}->{kernels} = \@kernels;
 649 }
 650
 651 #----------------------------------------------------------------------
 652 # Output.
 653
 654 if ($output eq "fish" || $output eq "ro-fish") {
 655     my @osdevs = keys %oses;
 656     # This only works if there is a single OS.
 657     die "--fish output is only possible with a single OS\n" if @osdevs != 1;
 658
 659     my $root_dev = $osdevs[0];
 660
 661     print "guestfish";
 662     if ($output eq "ro-fish") {
 663         print " --ro";
 664     }
 665
 666     print " -a $_" foreach @images;
 667
 668     my $mounts = $oses{$root_dev}->{mounts};
 669     # Have to mount / first.  Luckily '/' is early in the ASCII
 670     # character set, so this should be OK.
 671     foreach (sort keys %$mounts) {
 672         print " -m $mounts->{$_}:$_" if $_ ne "swap";
 673     }
 674     print "\n"
 675 }
 676
 677 # Perl output.
 678 elsif ($output eq "perl") {
 679     print Dumper(\%oses);
 680 }
 681
 682 # Plain text output (the default).
 683 elsif ($output eq "text") {
 684     output_text ();
 685 }
 686
 687 # XML output.
 688 elsif ($output eq "xml") {
 689     output_xml ();
 690 }
 691
 692 sub output_text
 693 {
 694     output_text_os ($oses{$_}) foreach sort keys %oses;
 695 }
 696
 697 sub output_text_os
 698 {
 699     my $os = shift;
 700
 701     print $os->{os}, " " if exists $os->{os};
 702     print $os->{distro}, " " if exists $os->{distro};
 703     print $os->{version}, " " if exists $os->{version};
 704     print "on ", $os->{root_device}, ":\n";
 705
 706     print "  Mountpoints:\n";
 707     my $mounts = $os->{mounts};
 708     foreach (sort keys %$mounts) {
 709         printf "    %-30s %s\n", $mounts->{$_}, $_
 710     }
 711
 712     print "  Filesystems:\n";
 713     my $filesystems = $os->{filesystems};
 714     foreach (sort keys %$filesystems) {
 715         print "    $_:\n";
 716         print "      label: $filesystems->{$_}{label}\n"
 717             if exists $filesystems->{$_}{label};
 718         print "      UUID: $filesystems->{$_}{uuid}\n"
 719             if exists $filesystems->{$_}{uuid};
 720         print "      type: $filesystems->{$_}{fstype}\n"
 721             if exists $filesystems->{$_}{fstype};
 722         print "      content: $filesystems->{$_}{content}\n"
 723             if exists $filesystems->{$_}{content};
 724     }
 725
 726     print "  Applications:\n";
 727     my @apps =  @{$os->{apps}};
 728     foreach (@apps) {
 729         print "    $_->{name} $_->{version}\n"
 730     }
 731
 732     print "  Kernels:\n";
 733     my @kernels = @{$os->{kernels}};
 734     foreach (@kernels) {
 735         print "    $_->{version}\n";
 736         my @modules = @{$_->{modules}};
 737         foreach (@modules) {
 738             print "      $_\n";
 739         }
 740     }
 741 }
 742
 743 sub output_xml
 744 {
 745     print "<operatingsystems>\n";
 746     output_xml_os ($oses{$_}) foreach sort keys %oses;
 747     print "</operatingsystems>\n";
 748 }
 749
 750 sub output_xml_os
 751 {
 752     my $os = shift;
 753
 754     print "<operatingsystem>\n";
 755
 756     print "<os>", $os->{os}, "</os>\n" if exists $os->{os};
 757     print "<distro>", $os->{distro}, "</distro>\n" if exists $os->{distro};
 758     print "<version>", $os->{version}, "</version>\n" if exists $os->{version};
 759     print "<root>", $os->{root_device}, "</root>\n";
 760
 761     print "<mountpoints>\n";
 762     my $mounts = $os->{mounts};
 763     foreach (sort keys %$mounts) {
 764         printf "<mountpoint dev='%s'>%s</mountpoint>\n",
 765           $mounts->{$_}, $_
 766     }
 767     print "</mountpoints>\n";
 768
 769     print "<filesystems>\n";
 770     my $filesystems = $os->{filesystems};
 771     foreach (sort keys %$filesystems) {
 772         print "<filesystem dev='$_'>\n";
 773         print "<label>$filesystems->{$_}{label}</label>\n"
 774             if exists $filesystems->{$_}{label};
 775         print "<uuid>$filesystems->{$_}{uuid}</uuid>\n"
 776             if exists $filesystems->{$_}{uuid};
 777         print "<type>$filesystems->{$_}{fstype}</type>\n"
 778             if exists $filesystems->{$_}{fstype};
 779         print "<content>$filesystems->{$_}{content}</content>\n"
 780             if exists $filesystems->{$_}{content};
 781         print "</filesystem>\n";
 782     }
 783     print "</filesystems>\n";
 784
 785     print "<applications>\n";
 786     my @apps =  @{$os->{apps}};
 787     foreach (@apps) {
 788         print "<application>\n";
 789         print "<name>$_->{name}</name><version>$_->{version}</version>\n";
 790         print "</application>\n";
 791     }
 792     print "</applications>\n";
 793
 794     print "<kernels>\n";
 795     my @kernels = @{$os->{kernels}};
 796     foreach (@kernels) {
 797         print "<kernel>\n";
 798         print "<version>$_->{version}</version>\n";
 799         print "<modules>\n";
 800         my @modules = @{$_->{modules}};
 801         foreach (@modules) {
 802             print "<module>$_</module>\n";
 803         }
 804         print "</modules>\n";
 805         print "</kernel>\n";
 806     }
 807     print "</kernels>\n";
 808
 809     print "</operatingsystem>\n";
 810 }
 811
 812 =head1 SEE ALSO
 813
 814 L<guestfs(3)>,
 815 L<guestfish(1)>,
 816 L<Sys::Guestfs(3)>,
 817 L<Sys::Virt(3)>
 818
 819 =head1 AUTHOR
 820
 821 Richard W.M. Jones L<http://et.redhat.com/~rjones/>
 822
 823 =head1 COPYRIGHT
 824
 825 Copyright (C) 2009 Red Hat Inc.
 826
 827 This program is free software; you can redistribute it and/or modify
 828 it under the terms of the GNU General Public License as published by
 829 the Free Software Foundation; either version 2 of the License, or
 830 (at your option) any later version.
 831
 832 This program is distributed in the hope that it will be useful,
 833 but WITHOUT ANY WARRANTY; without even the implied warranty of
 834 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 835 GNU General Public License for more details.
 836
 837 You should have received a copy of the GNU General Public License
 838 along with this program; if not, write to the Free Software
 839 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.