+#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 $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);
+ }
+
+ $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;
+
+ # Initialise augeas
+ my $success = 0;
+ $success = $g->aug_init("/", 16);
+
+ # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens
+ my @results;
+ @results = $g->aug_match("/augeas/load/Modprobe/incl");
+
+ # Calculate the next index of /augeas/load/Modprobe/incl
+ my $i = 1;
+ foreach ( @results ) {
+ next unless m{/augeas/load/Modprobe/incl\[(\d*)]};
+ $i = $1 + 1 if ($1 == $i);
+ }
+
+ $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
+ "/etc/modules.conf");
+ $i++;
+ $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
+ "/etc/conf.modules");
+
+ # Make augeas reload
+ $success = $g->aug_load();
+
+ my %modprobe_aliases;
+
+ for my $pattern qw(/files/etc/conf.modules/alias
+ /files/etc/modules.conf/alias
+ /files/etc/modprobe.conf/alias
+ /files/etc/modprobe.d/*/alias) {
+ @results = $g->aug_match($pattern);
+
+ for my $path ( @results ) {
+ $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
+ or die("$path doesn't match augeas pattern");
+ my $file = $1;
+
+ my $alias;
+ $alias = $g->aug_get($path);
+
+ my $modulename;
+ $modulename = $g->aug_get($path.'/modulename');
+
+ my %aliasinfo;
+ $aliasinfo{modulename} = $modulename;
+ $aliasinfo{augeas} = $path;
+ $aliasinfo{file} = $file;
+
+ $modprobe_aliases{$alias} = \%aliasinfo;
+ }
+ }
+
+ $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 %initrd_modules;
+
+ foreach my $initrd ($g->ls ("/boot")) {
+ if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
+ my $version = $1;
+ my @modules;
+
+ eval {
+ @modules = $g->initrd_list ("/boot/$initrd");
+ };
+ unless ($@) {
+ @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, } @modules;
+ $initrd_modules{$version} = \@modules
+ } else {
+ warn "/boot/$initrd: could not read initrd format"
+ }
+ }
+ }
+
+ $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];
+
+ if ($output eq "ro-fish") {
+ print "--ro ";
+ }
+
+ print "-a $_ " foreach @ARGV;
+
+ 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);
+}
+
+# YAML output
+elsif ($output eq "yaml") {
+ die "virt-inspector: no YAML support\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 ();
+}
+
+# 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{$_}->{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;
+ }
+ }
+ }
+
+ 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";
+ }
+ }
+
+ 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";
+ }
+ }
+}
+
+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");
+
+ $xml->end();
+}
+
+sub output_xml_os
+{
+ my ($os, $xml) = @_;
+
+ $xml->startTag("operatingsystem");
+
+ foreach ( [ "name" => "os" ],
+ [ "distro" => "distro" ],
+ [ "version" => "version" ],
+ [ "root" => "root_device" ] ) {
+ $xml->dataElement($_->[0], $os->{$_->[1]}) if exists $os->{$_->[1]};
+ }
+
+ $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]};
+ }
+
+ $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");
+ }
+ }
+
+ 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("version", $_->{version});
+ $xml->endTag("application");
+ }
+ $xml->endTag("applications");
+
+ $xml->startTag("kernels");
+ my @kernels = @{$os->{kernels}};
+ foreach (@kernels) {
+ $xml->startTag("kernel", "version" => $_->{version});
+ $xml->startTag("modules");
+ my @modules = @{$_->{modules}};
+ foreach (@modules) {
+ $xml->dataElement("module", $_);
+ }
+ $xml->endTag("modules");
+ $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");
+ }
+
+ $xml->endTag("operatingsystem");
+}
+
+=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)