use Pod::Usage;
use Getopt::Long;
use Data::Dumper;
+use File::Temp qw/tempdir/;
# Optional:
eval "use Sys::Virt;";
=item B<--force>
-Force reading a particular guest even if it appears to
-be active, or if the guest image is writable. This is
-dangerous and can even corrupt the guest image.
+Force reading a particular guest even if it appears to be active. In
+earlier versions of virt-inspector, this could be dangerous (for
+example, corrupting the guest's disk image). However in more recent
+versions, it should not cause corruption, but might cause
+virt-inspector to crash or produce incorrect results.
=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)
-=item B<--xml>
+Plain text report.
-=item B<--fish>
+=item B<--none>
-=item B<--ro-fish>
+Produce no output at all.
-Select the output format. The default is a readable text report.
+=item B<--xml>
If you select I<--xml> then you get XML 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<guestfish(1)> command
line which will automatically mount up the filesystems on the
correct mount points. Try this for example:
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<QUERY MODE> below.
+
=back
=cut
GetOptions ("help|?" => \$help,
"connect|c=s" => \$uri,
"force" => \$force,
+ "text" => sub { $output = "text" },
+ "none" => sub { $output = "none" },
"xml" => sub { $output = "xml" },
+ "perl" => sub { $output = "perl" },
"fish" => sub { $output = "fish" },
"guestfish" => sub { $output = "fish" },
"ro-fish" => sub { $output = "ro-fish" },
- "ro-guestfish" => sub { $output = "ro-fish" })
- or pod2usage (2);
+ "ro-guestfish" => sub { $output = "ro-fish" },
+ "query" => sub { $output = "query" },
+ ) or pod2usage (2);
pod2usage (1) if $help;
pod2usage ("$0: no image or VM names given") if @ARGV == 0;
if (-e $ARGV[0]) {
@images = @ARGV;
- # Until we get an 'add_drive_ro' call, we must check that qemu
- # will only open this image in readonly mode.
- # XXX Remove this hack at some point ... or at least push it
- # into libguestfs.
-
foreach (@images) {
if (! -r $_) {
die "guest image $_ does not exist or is not readable\n"
- } elsif (-w $_ && !$force) {
- die ("guest image $_ is writable! REFUSING TO PROCEED.\n".
- "You can use --force to override this BUT that action\n".
- "MAY CORRUPT THE DISK IMAGE.\n");
- }
+ }
}
} else {
die "no libvirt support (install Sys::Virt)"
# We've now got the list of @images, so feed them to libguestfs.
my $g = Sys::Guestfs->new ();
-$g->add_drive ($_) foreach @images;
+$g->add_drive_ro ($_) foreach @images;
$g->launch ();
$g->wait_ready ();
local $_;
my $r = shift;
- # XXX Windows version.
- # List of applications.
+ # Windows version?
}
sub check_grub
local $_;
my $r = shift;
- # XXX Kernel versions, grub version.
+ # Grub version, if we care.
}
#print Dumper (\%fses);
+#----------------------------------------------------------------------
# Now find out how many operating systems we've got. Usually just one.
my %oses = ();
return ();
} else {
return ($_, $fses{$_}) if exists $fses{$_};
+
+ if (m{^/dev/hd(.*)} && exists $fses{"/dev/sd$1"}) {
+ return ("/dev/sd$1", $fses{"/dev/sd$1"});
+ }
+ if (m{^/dev/xvd(.*)} && exists $fses{"/dev/sd$1"}) {
+ return ("/dev/sd$1", $fses{"/dev/sd$1"});
+ }
+
+ return () if m{/dev/cdrom};
+
warn "unknown filesystem $_\n";
return ();
}
}
-print Dumper (\%oses);
+#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$/) {
+ # Temporary directory for use by check_for_initrd.
+ my $dir = tempdir (CLEANUP => 1);
+
+ my $root_dev;
+ foreach $root_dev (sort keys %oses) {
+ 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) {
+ $g->mount_ro ($mounts->{$_}, $_)
+ if $_ ne "swap" && ($_ eq '/' || $g->is_dir ($_));
+ }
+
+ check_for_applications ($root_dev);
+ check_for_kernels ($root_dev);
+ if ($oses{$root_dev}->{os} eq "linux") {
+ check_for_modprobe_aliases ($root_dev);
+ check_for_initrd ($root_dev, $dir);
+ }
+
+ $g->umount_all ();
+ }
+}
+
+sub check_for_applications
+{
+ local $_;
+ my $root_dev = shift;
+
+ my @apps;
+
+ my $os = $oses{$root_dev}->{os};
+ if ($os eq "linux") {
+ my $distro = $oses{$root_dev}->{distro};
+ if (defined $distro && ($distro eq "redhat" || $distro eq "fedora")) {
+ my @lines = $g->command_lines
+ (["rpm",
+ "-q", "-a",
+ "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
+ foreach (@lines) {
+ if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
+ my $epoch = $2;
+ $epoch = "" if $epoch eq "(none)";
+ my $app = {
+ name => $1,
+ epoch => $epoch,
+ version => $3,
+ release => $4,
+ arch => $5
+ };
+ push @apps, $app
+ }
+ }
+ }
+ } elsif ($os eq "windows") {
+ # XXX
+ # I worked out a general plan for this, but haven't
+ # implemented it yet. We can iterate over /Program Files
+ # looking for *.EXE files, which we download, then use
+ # i686-pc-mingw32-windres on, to find the VERSIONINFO
+ # section, which has a lot of useful information.
+ }
+
+ $oses{$root_dev}->{apps} = \@apps;
+}
+
+sub check_for_kernels
+{
+ local $_;
+ my $root_dev = shift;
+
+ my @kernels;
+
+ my $os = $oses{$root_dev}->{os};
+ if ($os eq "linux") {
+ # Installed kernels will have a corresponding /lib/modules/<version>
+ # directory, which is the easiest way to find out what kernels
+ # are installed, and what modules are available.
+ foreach ($g->ls ("/lib/modules")) {
+ if ($g->is_dir ("/lib/modules/$_")) {
+ my %kernel;
+ $kernel{version} = $_;
+
+ # List modules.
+ my @modules;
+ foreach ($g->find ("/lib/modules/$_")) {
+ if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
+ push @modules, $1;
+ }
+ }
+
+ $kernel{modules} = \@modules;
+
+ push @kernels, \%kernel;
+ }
+ }
+
+ } elsif ($os eq "windows") {
+ # XXX
+ }
+
+ $oses{$root_dev}->{kernels} = \@kernels;
+}
+
+# Check /etc/modprobe.conf to see if there are any specified
+# drivers associated with network (ethX) or hard drives. Normally
+# one might find something like:
+#
+# alias eth0 xennet
+# alias scsi_hostadapter xenblk
+#
+# XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
+
+sub check_for_modprobe_aliases
+{
+ local $_;
+ my $root_dev = shift;
+
+ my @lines;
+ eval { @lines = $g->read_lines ("/etc/modprobe.conf"); };
+ return if $@ || !@lines;
+
+ my %modprobe_aliases;
+
+ foreach (@lines) {
+ $modprobe_aliases{$1} = $2 if /^\s*alias\s+(\S+)\s+(\S+)/;
+ }
+
+ $oses{$root_dev}->{modprobe_aliases} = \%modprobe_aliases;
+}
+
+# Get a listing of device drivers in any initrd corresponding to a
+# kernel. This is an indication of what can possibly be booted.
+
+sub check_for_initrd
+{
+ local $_;
+ my $root_dev = shift;
+ my $dir = shift;
+
+ my %initrd_modules;
+
+ foreach my $initrd ($g->ls ("/boot")) {
+ if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
+ my $version = $1;
+ my @modules = ();
+ # We have to download these to a temporary file.
+ $g->download ("/boot/$initrd", "$dir/initrd");
+
+ my $cmd = "zcat $dir/initrd | file -";
+ open P, "$cmd |" or die "$cmd: $!";
+ my $lines;
+ { local $/ = undef; $lines = <P>; }
+ close P;
+ if ($lines =~ /ext\d filesystem data/) {
+ # Before initramfs came along, these were compressed
+ # ext2 filesystems. We could run another libguestfs
+ # instance to unpack these, but punt on them for now. (XXX)
+ warn "initrd image is unsupported ext2/3/4 filesystem\n";
+ }
+ elsif ($lines =~ /cpio/) {
+ my $cmd = "zcat $dir/initrd | cpio --quiet -it";
+ open P, "$cmd |" or die "$cmd: $!";
+ while (<P>) {
+ push @modules, $1
+ if m,([^/]+)\.ko$, || m,([^/]+)\.o$,;
+ }
+ close P;
+ unlink "$dir/initrd";
+ $initrd_modules{$version} = \@modules;
+ }
+ else {
+ # What?
+ warn "unrecognized initrd image: $lines\n";
+ }
+ }
+ }
+
+ $oses{$root_dev}->{initrd_modules} = \%initrd_modules;
+}
+
+#----------------------------------------------------------------------
+# 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];
+
+ print "guestfish";
+ if ($output eq "ro-fish") {
+ print " --ro";
+ }
+
+ print " -a $_" foreach @images;
+
+ 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) {
+ print " -m $mounts->{$_}:$_" if $_ ne "swap";
+ }
+ print "\n"
+}
+
+# Perl output.
+elsif ($output eq "perl") {
+ print Dumper(\%oses);
+}
+
+# Plain text output (the default).
+elsif ($output eq "text") {
+ output_text ();
+}
+
+# XML output.
+elsif ($output eq "xml") {
+ output_xml ();
+}
+# 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->{version}, " " if exists $os->{version};
+ 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{$_}
+ }
+ }
+ }
+ 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;
+ }
+ }
+ }
+
+ print " Applications:\n";
+ my @apps = @{$os->{apps}};
+ foreach (@apps) {
+ print " $_->{name} $_->{version}\n"
+ }
+
+ print " Kernels:\n";
+ my @kernels = @{$os->{kernels}};
+ foreach (@kernels) {
+ print " $_->{version}\n";
+ my @modules = @{$_->{modules}};
+ foreach (@modules) {
+ print " $_\n";
+ }
+ }
+}
+
+sub output_xml
+{
+ print "<operatingsystems>\n";
+ output_xml_os ($oses{$_}) foreach sort keys %oses;
+ print "</operatingsystems>\n";
+}
+
+sub output_xml_os
+{
+ my $os = shift;
+
+ print "<operatingsystem>\n";
+
+ print "<os>", $os->{os}, "</os>\n" if exists $os->{os};
+ print "<distro>", $os->{distro}, "</distro>\n" if exists $os->{distro};
+ print "<version>", $os->{version}, "</version>\n" if exists $os->{version};
+ print "<root>", $os->{root_device}, "</root>\n";
+
+ print "<mountpoints>\n";
+ my $mounts = $os->{mounts};
+ foreach (sort keys %$mounts) {
+ printf "<mountpoint dev='%s'>%s</mountpoint>\n",
+ $mounts->{$_}, $_
+ }
+ print "</mountpoints>\n";
+
+ print "<filesystems>\n";
+ my $filesystems = $os->{filesystems};
+ foreach (sort keys %$filesystems) {
+ print "<filesystem dev='$_'>\n";
+ print "<label>$filesystems->{$_}{label}</label>\n"
+ if exists $filesystems->{$_}{label};
+ print "<uuid>$filesystems->{$_}{uuid}</uuid>\n"
+ if exists $filesystems->{$_}{uuid};
+ print "<type>$filesystems->{$_}{fstype}</type>\n"
+ if exists $filesystems->{$_}{fstype};
+ print "<content>$filesystems->{$_}{content}</content>\n"
+ if exists $filesystems->{$_}{content};
+ print "</filesystem>\n";
+ }
+ print "</filesystems>\n";
+
+ if (exists $os->{modprobe_aliases}) {
+ my %aliases = %{$os->{modprobe_aliases}};
+ my @keys = sort keys %aliases;
+ if (@keys) {
+ print "<modprobealiases>\n";
+ foreach (@keys) {
+ printf "<alias device=\"%s\">%s</alias>\n", $_, $aliases{$_}
+ }
+ print "</modprobealiases>\n";
+ }
+ }
+
+ if (exists $os->{initrd_modules}) {
+ my %modvers = %{$os->{initrd_modules}};
+ my @keys = sort keys %modvers;
+ if (@keys) {
+ print "<initrds>\n";
+ foreach (@keys) {
+ my @modules = @{$modvers{$_}};
+ print "<initrd version=\"$_\">\n";
+ print "<module>$_</module>\n" foreach @modules;
+ print "</initrd>\n";
+ }
+ print "</initrds>\n";
+ }
+ }
+
+ print "<applications>\n";
+ my @apps = @{$os->{apps}};
+ foreach (@apps) {
+ print "<application>\n";
+ print "<name>$_->{name}</name><version>$_->{version}</version>\n";
+ print "</application>\n";
+ }
+ print "</applications>\n";
+
+ print "<kernels>\n";
+ my @kernels = @{$os->{kernels}};
+ foreach (@kernels) {
+ print "<kernel>\n";
+ print "<version>$_->{version}</version>\n";
+ print "<modules>\n";
+ my @modules = @{$_->{modules}};
+ foreach (@modules) {
+ print "<module>$_</module>\n";
+ }
+ print "</modules>\n";
+ print "</kernel>\n";
+ }
+ print "</kernels>\n";
+
+ print "</operatingsystem>\n";
+}
+
+=head1 QUERY MODE
+
+When you use C<virt-inspector --query>, 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<yes> or C<no>, 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<windows=yes> and C<linux=yes>, 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 ();
+}
+
+=item windows=(yes|no)
+
+Answer C<yes> if Microsoft Windows is installed in the guest.
+
+=cut
+
+sub output_query_windows
+{
+ my $windows = "no";
+ foreach my $os (keys %oses) {
+ $windows="yes" if $oses{$os}->{os} eq "windows";
+ }
+ print "windows=$windows\n";
+}
+
+=item linux=(yes|no)
+
+Answer C<yes> 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";
+ }
+ print "linux=$linux\n";
+}
+
+=item rhel=(yes|no)
+
+Answer C<yes> if the guest contains Red Hat Enterprise Linux.
+
+=cut
+
+sub output_query_rhel
+{
+ my $rhel = "no";
+ foreach my $os (keys %oses) {
+ $rhel="yes" if $oses{$os}->{os} eq "linux" && $oses{$os}->{distro} eq "redhat";
+ }
+ print "rhel=$rhel\n";
+}
+
+=item fedora=(yes|no)
+
+Answer C<yes> if the guest contains the Fedora Linux distribution.
+
+=cut
+
+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";
+}
+
+=item debian=(yes|no)
+
+Answer C<yes> if the guest contains the Debian Linux distribution.
+
+=cut
+
+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";
+ }
+ print "debian=$debian\n";
+}
+
+=item fullvirt=(yes|no)
+
+Answer C<yes> 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";
+}
+
+=item xen_domU_kernel=(yes|no)
+
+Answer C<yes> 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
+{
+ 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;
+ }
+ }
+ }
+ print "xen_domU_kernel=no\n";
+}
+
+=item xen_pv_drivers=(yes|no)
+
+Answer C<yes> 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;
+ }
+ }
+ }
+ }
+ print "xen_pv_drivers=no\n";
+}
+
+=item virtio_drivers=(yes|no)
+
+Answer C<yes> if the guest has virtio paravirtualized drivers
+installed. Virtio drivers are commonly used to improve the
+performance of KVM.
+
+=cut
+
+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;
+ }
+ }
+ }
+ }
+ print "virtio_drivers=no\n";
+}
+
+=back
=head1 SEE ALSO
git.annexia.org / libguestfs.git / blobdiff