X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=inspector%2Fvirt-inspector.pl;h=247a8b6a6f7a8586d3352d55930f471f6d4f84cd;hp=c8c045e12f02728fcab59259e3cb4f4597f697fb;hb=42b90f2d0d5b16da948f77e99e84c9192e742a4e;hpb=6f2929c4635c3f2af4a9211981d9edd1f58cce69;ds=sidebyside

diff --git a/inspector/virt-inspector.pl b/inspector/virt-inspector.pl
index c8c045e..247a8b6 100755
--- a/inspector/virt-inspector.pl
+++ b/inspector/virt-inspector.pl
@@ -23,6 +23,7 @@ use Sys::Guestfs;
 use Pod::Usage;
 use Getopt::Long;
 use Data::Dumper;
+use File::Temp qw/tempdir/;
 
 # Optional:
 eval "use Sys::Virt;";
@@ -101,32 +102,45 @@ my $force;
 
 =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";
 
-=item B<--text> (default)
+=back
 
-=item B<--xml>
+The following options select the output format.  Use only one of them.
+The default is a readable text report.
 
-=item B<--perl>
+=over 4
 
-=item B<--fish>
+=item B<--text> (default)
 
-=item B<--ro-fish>
+Plain text report.
+
+=item B<--none>
+
+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:
@@ -136,6 +150,13 @@ 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
@@ -143,13 +164,16 @@ guestfish so that the filesystems are mounted read-only.
 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;
 
@@ -159,19 +183,10 @@ my @images;
 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)"
@@ -213,7 +228,7 @@ if (-e $ARGV[0]) {
 
 # 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 ();
 
@@ -434,8 +449,7 @@ sub check_windows_root
     local $_;
     my $r = shift;
 
-    # XXX Windows version.
-    # List of applications.
+    # Windows version?
 }
 
 sub check_grub
@@ -443,7 +457,7 @@ sub check_grub
     local $_;
     my $r = shift;
 
-    # XXX Kernel versions, grub version.
+    # Grub version, if we care.
 }
 
 #print Dumper (\%fses);
@@ -553,6 +567,9 @@ sub find_filesystem
 # 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};
@@ -565,13 +582,11 @@ if ($output !~ /.*fish$/) {
 
 	check_for_applications ($root_dev);
 	check_for_kernels ($root_dev);
-
-	# umount_all in libguestfs is buggy - it doesn't unmount
-	# filesystems in the correct order.  So let's unmount them
-	# in reverse first before calling umount_all as a last resort.
-	foreach (sort { $b cmp $a } keys %$mounts) {
-	    eval "\$g->umount ('$_')";
+	if ($oses{$root_dev}->{os} eq "linux") {
+	    check_for_modprobe_aliases ($root_dev);
+	    check_for_initrd ($root_dev, $dir);
 	}
+
 	$g->umount_all ();
     }
 }
@@ -581,7 +596,41 @@ sub check_for_applications
     local $_;
     my $root_dev = shift;
 
-    # XXX rpm -qa, look in Program Files, or whatever
+    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
@@ -589,7 +638,114 @@ sub check_for_kernels
     local $_;
     my $root_dev = shift;
 
-    # XXX
+    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;
 }
 
 #----------------------------------------------------------------------
@@ -625,26 +781,400 @@ elsif ($output eq "perl") {
 
 # Plain text output (the default).
 elsif ($output eq "text") {
-    # XXX text output.
+    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";
+	}
+    }
 }
 
-# XML output.
-elsif ($output eq "xml") {
-    # XXX XML output.
+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
 
 L<guestfs(3)>,