X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=inspector%2Fvirt-inspector;h=24501fb32647b5d17c6e68dccf2fa0eee0bc24cf;hp=36fbfa90847ce69fca415db4552268a3eaa4ec89;hb=f30210cba89763a32cfbcbfd68ccfcec8d5300e4;hpb=ca7e941329b31d1bffc8cae9dca6d28b06ecc300;ds=sidebyside diff --git a/inspector/virt-inspector b/inspector/virt-inspector index 36fbfa9..24501fb 100755 --- a/inspector/virt-inspector +++ b/inspector/virt-inspector @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # virt-inspector -# Copyright (C) 2009 Red Hat Inc. +# Copyright (C) 2010 Red Hat Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -20,24 +20,19 @@ use warnings; use strict; use Sys::Guestfs; -use Sys::Guestfs::Lib qw(open_guest get_partitions resolve_windows_path - inspect_all_partitions inspect_partition - inspect_operating_systems mount_operating_system inspect_in_detail); +use Sys::Guestfs::Lib qw(open_guest); use Pod::Usage; use Getopt::Long; -use Data::Dumper; +use File::Temp qw/tempfile/; +use File::Basename; use XML::Writer; -use String::ShellQuote qw(shell_quote); use Locale::TextDomain 'libguestfs'; -# Optional: -eval "use YAML::Any;"; - =encoding utf8 =head1 NAME -virt-inspector - Display OS version, kernel, drivers, mount points, applications, etc. in a virtual machine +virt-inspector - Display operating system version and other information about a virtual machine =head1 SYNOPSIS @@ -47,13 +42,11 @@ virt-inspector - Display OS version, kernel, drivers, mount points, applications =head1 DESCRIPTION -B examines a virtual machine and tries to determine -the version of the OS, the kernel version, what drivers are installed, -whether the virtual machine is fully virtualized (FV) or -para-virtualized (PV), what applications are installed and more. +B examines a virtual machine or disk image and tries +to determine the version of the operating system and other information +about the virtual machine. -Virt-inspector can produce output in several formats, including a -readable text report, and XML for feeding into other programs. +Virt-inspector produces XML output for feeding into other programs. In the normal usage, use C where C is the libvirt domain (see: C). @@ -122,72 +115,6 @@ parameter is ignored. If working with untrusted raw-format guest disk images, you should ensure the format is always specified. -=cut - -my $output = "text"; - -=back - -The following options select the output format. Use only one of them. -The default is a readable text report. - -=over 4 - -=item B<--text> (default) - -Plain text report. - -=item B<--none> - -Produce no output at all. - -=item B<--xml> - -If you select I<--xml> then you get XML output which can be fed -to other programs. - -=item B<--yaml> - -If you select I<--yaml> then you get YAML output which can be fed -to other programs. - -=item B<--perl> - -If you select I<--perl> then you get Perl structures output which -can be used directly in another Perl program. - -=item B<--fish> - -=item B<--ro-fish> - -If you select I<--fish> then we print a L command -line which will automatically mount up the filesystems on the -correct mount points. Try this for example: - - guestfish $(virt-inspector --fish guest.img) - -I<--ro-fish> is the same, but the I<--ro> option is passed to -guestfish so that the filesystems are mounted read-only. - -=item B<--query> - -In "query mode" we answer common questions about the guest, such -as whether it is fullvirt or needs a Xen hypervisor to run. - -See section I below. - -=cut - -my $windows_registry; - -=item B<--windows-registry> - -This flag is ignored for compatibility with earlier releases of the -software. - -In this version, if L is available, then we attempt to -parse information out of the Registry for any Windows guest. - =back =cut @@ -196,17 +123,6 @@ GetOptions ("help|?" => \$help, "version" => \$version, "connect|c=s" => \$uri, "format=s" => \$format, - "text" => sub { $output = "text" }, - "none" => sub { $output = "none" }, - "xml" => sub { $output = "xml" }, - "yaml" => sub { $output = "yaml" }, - "perl" => sub { $output = "perl" }, - "fish" => sub { $output = "fish" }, - "guestfish" => sub { $output = "fish" }, - "ro-fish" => sub { $output = "ro-fish" }, - "ro-guestfish" => sub { $output = "ro-fish" }, - "query" => sub { $output = "query" }, - "windows-registry" => \$windows_registry, ) or pod2usage (2); pod2usage (1) if $help; if ($version) { @@ -217,663 +133,220 @@ if ($version) { } pod2usage (__"virt-inspector: no image or VM names given") if @ARGV == 0; -my $rw = 0; - -# XXX This is a bug: Originally we intended to open the guest with -# rw=>1 in order to tell Sys::Guestfs::Lib that we should disallow -# active domains. However this also has the effect of opening the -# disk image in write mode, and in any case we don't use this option -# in guestfish any more since we moved all the inspection code into -# the core library. We should drop the fish output modes completely. -$rw = 1 if $output eq "fish"; - -my $g; -my @images; -if ($uri) { - my ($conn, $dom); - ($g, $conn, $dom, @images) = - open_guest (\@ARGV, rw => $rw, address => $uri, format => $format); -} else { - my ($conn, $dom); - ($g, $conn, $dom, @images) = - open_guest (\@ARGV, rw => $rw, format => $format); -} +my @args = (\@ARGV); +push @args, address => $uri if defined $uri; +push @args, format => $format if defined $format; +my $g = open_guest (@args); $g->launch (); -=head1 OUTPUT FORMAT - - Operating system(s) - ------------------- - Linux (distro + version) - Windows (version) - | - | - +--- Filesystems ---------- Installed apps --- Kernel & drivers - ----------- -------------- ---------------- - mount point => device List of apps Extra information - mount point => device and versions about kernel(s) - ... and drivers - swap => swap device - (plus lots of extra information - about each filesystem) - -The output of virt-inspector is a complex two-level data structure. - -At the top level is a list of the operating systems installed on the -guest. (For the vast majority of guests, only a single OS is -installed.) The data returned for the OS includes the name (Linux, -Windows), the distribution and version. - -The diagram above shows what we return for each OS. - -With the I<--xml> option the output is mapped into an XML document. -There is a RELAX-NG schema for this XML in the file -I which normally ships with virt-inspector, or can -be found in the source. - -With the I<--fish> or I<--ro-fish> option the mount points are mapped to -L command line parameters, so that you can go in -afterwards and inspect the guest with everything mounted in the -right place. For example: - - guestfish $(virt-inspector --ro-fish guest.img) - ==> guestfish --ro -a guest.img -m /dev/VG/LV:/ -m /dev/sda1:/boot - -=cut - -# List of possible filesystems. -my @partitions = get_partitions ($g); - -# Now query each one to build up a picture of what's in it. -my %fses = - inspect_all_partitions ($g, \@partitions); - -#print "fses -----------\n"; -#print Dumper(\%fses); - -my $oses = inspect_operating_systems ($g, \%fses); - -#print "oses -----------\n"; -#print Dumper($oses); - -# Mount up the disks so we can check for applications -# and kernels. Skip this if the output is "*fish" because -# we don't need to know. - -if ($output !~ /.*fish$/) { - my $root_dev; - foreach $root_dev (sort keys %$oses) { - my $os = $oses->{$root_dev}; - mount_operating_system ($g, $os); - inspect_in_detail ($g, $os); - $g->umount_all (); - } -} - -#---------------------------------------------------------------------- -# Output. - -if ($output eq "fish" || $output eq "ro-fish") { - my @osdevs = keys %$oses; - # This only works if there is a single OS. - die __"--fish output is only possible with a single OS\n" if @osdevs != 1; - - my $root_dev = $osdevs[0]; - - if ($output eq "ro-fish") { - print "--ro "; - } - - foreach (@images) { - unless (defined $_->[1]) { - printf "-a %s ", shell_quote ($_->[0]); - } else { - printf "--format %s -a %s ", - shell_quote ($_->[1]), shell_quote ($_->[0]); - } - } - - my $mounts = $oses->{$root_dev}->{mounts}; - # Have to mount / first. Luckily '/' is early in the ASCII - # character set, so this should be OK. - foreach (sort keys %$mounts) { - if ($_ ne "swap" && $_ ne "none") { - printf "-m %s ", shell_quote ("$mounts->{$_}:$_"); - } - } - print "\n" -} - -# Perl output. -elsif ($output eq "perl") { - print Dumper(%$oses); -} - -# YAML output -elsif ($output eq "yaml") { - die __"virt-inspector: no YAML support, try installing perl-YAML or libyaml-perl\n" - unless exists $INC{"YAML/Any.pm"}; - - print Dump(%$oses); -} - -# Plain text output (the default). -elsif ($output eq "text") { - output_text (); -} - -# XML output. -elsif ($output eq "xml") { - output_xml (); +my @roots = $g->inspect_os (); +if (@roots == 0) { + die __x("{prog}: No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by libguestfs.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n", + prog => basename ($0)); } -# Query mode. -elsif ($output eq "query") { - output_query (); -} - -sub output_text -{ - output_text_os ($oses->{$_}) foreach sort keys %$oses; -} - -sub output_text_os -{ - my $os = shift; - - print $os->{os}, " " if exists $os->{os}; - print $os->{distro}, " " if exists $os->{distro}; - print $os->{arch}, " " if exists $os->{arch}; - print $os->{major_version} if exists $os->{major_version}; - print ".", $os->{minor_version} if exists $os->{minor_version}; - print " (", $os->{product_name}, ")" if exists $os->{product_name}; - print " "; - print "on ", $os->{root_device}, ":\n"; - - print __" Mountpoints:\n"; - my $mounts = $os->{mounts}; - foreach (sort keys %$mounts) { - printf " %-30s %s\n", $mounts->{$_}, $_ - } - - print __" Filesystems:\n"; - my $filesystems = $os->{filesystems}; - foreach (sort keys %$filesystems) { - print " $_:\n"; - print " label: $filesystems->{$_}{label}\n" - if exists $filesystems->{$_}{label}; - print " UUID: $filesystems->{$_}{uuid}\n" - if exists $filesystems->{$_}{uuid}; - print " type: $filesystems->{$_}{fstype}\n" - if exists $filesystems->{$_}{fstype}; - print " content: $filesystems->{$_}{content}\n" - if exists $filesystems->{$_}{content}; - } - - if (exists $os->{modprobe_aliases}) { - my %aliases = %{$os->{modprobe_aliases}}; - my @keys = sort keys %aliases; - if (@keys) { - print __" Modprobe aliases:\n"; - foreach (@keys) { - printf " %-30s %s\n", $_, $aliases{$_}->{modulename} - } - } - } - - if (exists $os->{initrd_modules}) { - my %modvers = %{$os->{initrd_modules}}; - my @keys = sort keys %modvers; - if (@keys) { - print __" Initrd modules:\n"; - foreach (@keys) { - my @modules = @{$modvers{$_}}; - print " $_:\n"; - print " $_\n" foreach @modules; - } - } - } +# Start the XML output. +my $xml = new XML::Writer (DATA_MODE => 1, DATA_INDENT => 2); - print __" Applications:\n"; - my @apps = @{$os->{apps}}; - foreach (@apps) { - print " $_->{name} $_->{version}\n" - } +$xml->startTag ("operatingsystems"); - if ($os->{kernels}) { - print __" Kernels:\n"; - my @kernels = @{$os->{kernels}}; - foreach (@kernels) { - print " $_->{version} ($_->{arch})\n"; - my @modules = @{$_->{modules}}; - foreach (@modules) { - print " $_\n"; - } - } +my $root; +foreach $root (@roots) { + my %fses = $g->inspect_get_mountpoints ($root); + my @fses = sort { length $a <=> length $b } keys %fses; + foreach (@fses) { + $g->mount_ro ($fses{$_}, $_); } - if (exists $os->{root}->{registry}) { - print __" Windows Registry entries:\n"; - # These are just lumps of text - dump them out. - foreach (@{$os->{root}->{registry}}) { - print "$_\n"; - } - } -} + $xml->startTag ("operatingsystem"); -sub output_xml -{ - my $xml = new XML::Writer(DATA_MODE => 1, DATA_INDENT => 2); - - $xml->startTag("operatingsystems"); - output_xml_os ($oses->{$_}, $xml) foreach sort keys %$oses; - $xml->endTag("operatingsystems"); + # Basic OS fields. + $xml->dataElement (root => $root); - $xml->end(); -} + my ($s, $distro, $major_version); + $s = $g->inspect_get_type ($root); + $xml->dataElement (name => $s) if $s ne "unknown"; + $s = $g->inspect_get_arch ($root); + $xml->dataElement (arch => $s) if $s ne "unknown"; + $distro = $g->inspect_get_distro ($root); + $xml->dataElement (distro => $distro) if $distro ne "unknown"; + $s = $g->inspect_get_product_name ($root); + $xml->dataElement (product_name => $s) if $s ne "unknown"; + $major_version = $g->inspect_get_major_version ($root); + $xml->dataElement (major_version => $major_version); + $s = $g->inspect_get_minor_version ($root); + $xml->dataElement (minor_version => $s); -sub output_xml_os -{ - my ($os, $xml) = @_; - - $xml->startTag("operatingsystem"); - - foreach ( [ "name" => "os" ], - [ "distro" => "distro" ], - [ "product_name" => "product_name" ], - [ "arch" => "arch" ], - [ "major_version" => "major_version" ], - [ "minor_version" => "minor_version" ], - [ "package_format" => "package_format" ], - [ "package_management" => "package_management" ], - [ "root" => "root_device" ] ) { - $xml->dataElement($_->[0], $os->{$_->[1]}) if exists $os->{$_->[1]}; - } + eval { + $s = $g->inspect_get_windows_systemroot ($root); + $xml->dataElement (windows_systemroot => $s); + }; - $xml->startTag("mountpoints"); - my $mounts = $os->{mounts}; - foreach (sort keys %$mounts) { - $xml->dataElement("mountpoint", $_, "dev" => $mounts->{$_}); - } - $xml->endTag("mountpoints"); - - $xml->startTag("filesystems"); - my $filesystems = $os->{filesystems}; - foreach (sort keys %$filesystems) { - $xml->startTag("filesystem", "dev" => $_); - - foreach my $field ( [ "label" => "label" ], - [ "uuid" => "uuid" ], - [ "type" => "fstype" ], - [ "content" => "content" ], - [ "spec" => "spec" ] ) { - $xml->dataElement($field->[0], $filesystems->{$_}{$field->[1]}) - if exists $filesystems->{$_}{$field->[1]}; - } + # Mountpoints. + output_mountpoints ($root, \@fses, \%fses); - $xml->endTag("filesystem"); - } - $xml->endTag("filesystems"); - - if (exists $os->{modprobe_aliases}) { - my %aliases = %{$os->{modprobe_aliases}}; - my @keys = sort keys %aliases; - if (@keys) { - $xml->startTag("modprobealiases"); - foreach (@keys) { - $xml->startTag("alias", "device" => $_); - - foreach my $field ( [ "modulename" => "modulename" ], - [ "augeas" => "augeas" ], - [ "file" => "file" ] ) { - $xml->dataElement($field->[0], $aliases{$_}->{$field->[1]}); - } - - $xml->endTag("alias"); - } - $xml->endTag("modprobealiases"); - } - } + # Filesystems. + output_filesystems ($root); - if (exists $os->{initrd_modules}) { - my %modvers = %{$os->{initrd_modules}}; - my @keys = sort keys %modvers; - if (@keys) { - $xml->startTag("initrds"); - foreach (@keys) { - my @modules = @{$modvers{$_}}; - $xml->startTag("initrd", "version" => $_); - $xml->dataElement("module", $_) foreach @modules; - $xml->endTag("initrd"); - } - $xml->endTag("initrds"); - } - } - - $xml->startTag("applications"); - my @apps = @{$os->{apps}}; - foreach (@apps) { - $xml->startTag("application"); - $xml->dataElement("name", $_->{name}); - $xml->dataElement("epoch", $_->{epoch}) if defined $_->{epoch}; - $xml->dataElement("version", $_->{version}); - $xml->dataElement("release", $_->{release}); - $xml->dataElement("arch", $_->{arch}); - $xml->endTag("application"); - } - $xml->endTag("applications"); - - if(defined($os->{boot}) && defined($os->{boot}->{configs})) { - my $default = $os->{boot}->{default}; - my $configs = $os->{boot}->{configs}; - - $xml->startTag("boot"); - for(my $i = 0; $i < scalar(@$configs); $i++) { - my $config = $configs->[$i]; - - my @attrs = (); - push(@attrs, ("default" => 1)) if($default == $i); - $xml->startTag("config", @attrs); - $xml->dataElement("title", $config->{title}); - $xml->dataElement("kernel", $config->{kernel}->{version}) - if(defined($config->{kernel})); - $xml->dataElement("cmdline", $config->{cmdline}) - if(defined($config->{cmdline})); - $xml->endTag("config"); - } - $xml->endTag("boot"); - } - - if ($os->{kernels}) { - $xml->startTag("kernels"); - my @kernels = @{$os->{kernels}}; - foreach (@kernels) { - $xml->startTag("kernel", - "version" => $_->{version}, - "arch" => $_->{arch}); - $xml->startTag("modules"); - my @modules = @{$_->{modules}}; - foreach (@modules) { - $xml->dataElement("module", $_); - } - $xml->endTag("modules"); - $xml->dataElement("path", $_->{path}) if(defined($_->{path})); - $xml->dataElement("package", $_->{package}) if(defined($_->{package})); - $xml->endTag("kernel"); - } - $xml->endTag("kernels"); - } - - if (exists $os->{root}->{registry}) { - $xml->startTag("windowsregistryentries"); - # These are just lumps of text - dump them out. - foreach (@{$os->{root}->{registry}}) { - $xml->dataElement("windowsregistryentry", $_); - } - $xml->endTag("windowsregistryentries"); - } + # Package format / management and applications. + output_applications ($root, $distro, $major_version); $xml->endTag("operatingsystem"); -} - -=head1 QUERY MODE - -When you use C, the output is a series of -lines of the form: - - windows=no - linux=yes - fullvirt=yes - xen_pv_drivers=no -(each answer is usually C or C, or the line is completely -missing if we could not determine the answer at all). - -If the guest is multiboot, you can get apparently conflicting answers -(eg. C and C, or a guest which is both -fullvirt and has a Xen PV kernel). This is normal, and just means -that the guest can do both things, although it might require operator -intervention such as selecting a boot option when the guest is -booting. - -This section describes the full range of answers possible. - -=over 4 - -=cut - -sub output_query -{ - output_query_windows (); - output_query_linux (); - output_query_rhel (); - output_query_fedora (); - output_query_debian (); - output_query_fullvirt (); - output_query_xen_domU_kernel (); - output_query_xen_pv_drivers (); - output_query_virtio_drivers (); - output_query_kernel_arch (); - output_query_userspace_arch (); + $g->umount_all (); } -=item windows=(yes|no) - -Answer C if Microsoft Windows is installed in the guest. - -=cut +# End the XML output. +$xml->endTag ("operatingsystems"); +$xml->end (); -sub output_query_windows +sub output_mountpoints { - my $windows = "no"; - foreach my $os (keys %$oses) { - $windows="yes" if $oses->{$os}->{os} eq "windows"; - } - print "windows=$windows\n"; -} + local $_; + my $root = shift; + my $fskeys = shift; + my $fshash = shift; -=item linux=(yes|no) - -Answer C if a Linux kernel is installed in the guest. - -=cut - -sub output_query_linux -{ - my $linux = "no"; - foreach my $os (keys %$oses) { - $linux="yes" if $oses->{$os}->{os} eq "linux"; + $xml->startTag ("mountpoints"); + foreach (@$fskeys) { + $xml->dataElement ("mountpoint", $_, dev => $fshash->{$_}); } - print "linux=$linux\n"; + $xml->endTag ("mountpoints"); } -=item rhel=(yes|no) - -Answer C if the guest contains Red Hat Enterprise Linux. - -=cut - -sub output_query_rhel +sub output_filesystems { - my $rhel = "no"; - foreach my $os (keys %$oses) { - $rhel="yes" if ($oses->{$os}->{os} eq "linux" && - $oses->{$os}->{distro} eq "rhel"); - } - print "rhel=$rhel\n"; -} - -=item fedora=(yes|no) - -Answer C if the guest contains the Fedora Linux distribution. + local $_; + my $root = shift; -=cut + $xml->startTag ("filesystems"); -sub output_query_fedora -{ - my $fedora = "no"; - foreach my $os (keys %$oses) { - $fedora="yes" if $oses->{$os}->{os} eq "linux" && $oses->{$os}->{distro} eq "fedora"; - } - print "fedora=$fedora\n"; -} + my @fses = $g->inspect_get_filesystems ($root); + foreach (@fses) { + $xml->startTag ("filesystem", dev => $_); -=item debian=(yes|no) + eval { + my $type = $g->vfs_type ($_); + $xml->dataElement (type => $type) + if defined $type && $type ne ""; + }; -Answer C if the guest contains the Debian Linux distribution. + eval { + my $label = $g->vfs_label ($_); + $xml->dataElement (label => $label) + if defined $label && $label ne ""; + }; -=cut + eval { + my $uuid = $g->vfs_uuid ($_); + $xml->dataElement (uuid => $uuid) + if defined $uuid && $uuid ne ""; + }; -sub output_query_debian -{ - my $debian = "no"; - foreach my $os (keys %$oses) { - $debian="yes" if $oses->{$os}->{os} eq "linux" && $oses->{$os}->{distro} eq "debian"; + $xml->endTag ("filesystem"); } - print "debian=$debian\n"; -} -=item fullvirt=(yes|no) - -Answer C if there is at least one operating system kernel -installed in the guest which runs fully virtualized. Such a guest -would require a hypervisor which supports full system virtualization. - -=cut - -sub output_query_fullvirt -{ - # The assumption is full-virt, unless all installed kernels - # are identified as paravirt. - # XXX Fails on Windows guests. - foreach my $os (keys %$oses) { - foreach my $kernel (@{$oses->{$os}->{kernels}}) { - my $is_pv = $kernel->{version} =~ m/xen/; - unless ($is_pv) { - print "fullvirt=yes\n"; - return; - } - } - } - print "fullvirt=no\n"; + $xml->endTag ("filesystems"); } -=item xen_domU_kernel=(yes|no) - -Answer C if there is at least one Linux kernel installed in -the guest which is compiled as a Xen DomU (a Xen paravirtualized -guest). - -=cut - -sub output_query_xen_domU_kernel +sub output_applications { - foreach my $os (keys %$oses) { - foreach my $kernel (@{$oses->{$os}->{kernels}}) { - my $is_xen = $kernel->{version} =~ m/xen/; - if ($is_xen) { - print "xen_domU_kernel=yes\n"; - return; - } + local $_; + my $root = shift; + my $distro = shift; + my $major_version = shift; + + # Based on the distro, take a guess at the package format + # and package management. + my ($package_format, $package_management); + if (defined $distro) { + if ($distro eq "debian") { + $package_format = "dpkg"; + $package_management = "apt"; } - } - print "xen_domU_kernel=no\n"; -} - -=item xen_pv_drivers=(yes|no) - -Answer C if the guest has Xen paravirtualized drivers installed -(usually the kernel itself will be fully virtualized, but the PV -drivers have been installed by the administrator for performance -reasons). - -=cut - -sub output_query_xen_pv_drivers -{ - foreach my $os (keys %$oses) { - foreach my $kernel (@{$oses->{$os}->{kernels}}) { - foreach my $module (@{$kernel->{modules}}) { - if ($module =~ m/xen-/) { - print "xen_pv_drivers=yes\n"; - return; - } + elsif ($distro eq "fedora") { + $package_format = "rpm"; + $package_management = "yum"; + } + elsif ($distro =~ /redhat/ || $distro =~ /rhel/) { + if ($major_version >= 5) { + $package_format = "rpm"; + $package_management = "yum"; + } else { + $package_format = "rpm"; + $package_management = "up2date"; } } + # else unknown. } - print "xen_pv_drivers=no\n"; -} -=item virtio_drivers=(yes|no) - -Answer C if the guest has virtio paravirtualized drivers -installed. Virtio drivers are commonly used to improve the -performance of KVM. - -=cut + $xml->dataElement (package_format => $package_format) + if defined $package_format; + $xml->dataElement (package_management => $package_management) + if defined $package_management; -sub output_query_virtio_drivers -{ - foreach my $os (keys %$oses) { - foreach my $kernel (@{$oses->{$os}->{kernels}}) { - foreach my $module (@{$kernel->{modules}}) { - if ($module =~ m/virtio_/) { - print "virtio_drivers=yes\n"; - return; - } - } + # Do we know how to get a list of applications? + if (defined $package_format) { + if ($package_format eq "rpm") { + output_applications_rpm ($root); } + # else no we don't. } - print "virtio_drivers=no\n"; } -=item userspace_arch=(x86_64|...) - -Print the architecture of userspace. - -NB. For multi-boot VMs this can print several lines. - -=cut - -sub output_query_userspace_arch +sub output_applications_rpm { - my %arches; - - foreach my $os (keys %$oses) { - $arches{$oses->{$os}->{arch}} = 1 if exists $oses->{$os}->{arch}; - } - - foreach (sort keys %arches) { - print "userspace_arch=$_\n"; - } -} - -=item kernel_arch=(x86_64|...) - -Print the architecture of the kernel. - -NB. For multi-boot VMs this can print several lines. - -=cut + local $_; + my $root = shift; + + # Previous virt-inspector ran the 'rpm' program from the guest. + # This is insecure, and unnecessary because we can get the same + # information directly from the RPM database. + + my @applications; + + eval { + my ($fh, $filename) = tempfile (UNLINK => 1); + my $fddev = "/dev/fd/" . fileno ($fh); + $g->download ("/var/lib/rpm/Name", $fddev); + close $fh or die "close: $!"; + + # Read the database with the Berkeley DB dump tool. + my $cmd = "db_dump -p '$filename'"; + open PIPE, "$cmd |" or die "close: $!"; + while () { + chomp; + last if /^HEADER=END$/; + } + while () { + chomp; + last if /^DATA=END$/; -sub output_query_kernel_arch -{ - my %arches; + # First character on each data line is a space. + if (length $_ > 0 && substr ($_, 0, 1) eq ' ') { + $_ = substr ($_, 1); + } + # Name should never contain non-printable chars. + die "name contains non-printable chars" if /\\/; + push @applications, $_; - foreach my $os (keys %$oses) { - foreach my $kernel (@{$oses->{$os}->{kernels}}) { - $arches{$kernel->{arch}} = 1 if exists $kernel->{arch}; + $_ = ; # discard value } - } - - foreach (sort keys %arches) { - print "kernel_arch=$_\n"; + close PIPE or die "close: $!"; + }; + if (!$@ && @applications > 0) { + @applications = sort @applications; + $xml->startTag ("applications"); + foreach (@applications) { + $xml->startTag ("application"); + $xml->dataElement (name => $_); + $xml->endTag ("application"); + } + $xml->endTag ("applications"); } } -=back - =head1 SHELL QUOTING Libvirt guest names can contain arbitrary characters, some of which @@ -892,13 +365,21 @@ L. =head1 AUTHORS +=over 4 + +=item * + Richard W.M. Jones L +=item * + Matthew Booth L +=back + =head1 COPYRIGHT -Copyright (C) 2009 Red Hat Inc. +Copyright (C) 2010 Red Hat Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by