X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=inspector%2Fvirt-inspector.pl;h=dae17a8d1e16624e0c55f78209a081d8f4a9566f;hp=e51bfdd4ca7ebf44c3b1a26770c7a94a1e5c9606;hb=3f2ba6fdfbb82234e8a546dc54d568f49cd2e56b;hpb=0b3b482542319bf329974397c99b8c0663b9e536 diff --git a/inspector/virt-inspector.pl b/inspector/virt-inspector.pl index e51bfdd..dae17a8 100755 --- a/inspector/virt-inspector.pl +++ b/inspector/virt-inspector.pl @@ -20,12 +20,16 @@ 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 Pod::Usage; use Getopt::Long; use Data::Dumper; +use XML::Writer; # Optional: -eval "use Sys::Virt;"; +eval "use YAML::Any;"; =encoding utf8 @@ -84,6 +88,14 @@ Display brief help. =cut +my $version; + +=item B<--version> + +Display version number and exit. + +=cut + my $uri; =item B<--connect URI> | B<-c URI> @@ -97,141 +109,112 @@ then libvirt is not used at all. =cut -my $force; - -=item B<--force> +my $output = "text"; -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. +=back -=cut +The following options select the output format. Use only one of them. +The default is a readable text report. -my $output = "text"; +=over 4 =item B<--text> (default) -=item B<--xml> +Plain text report. -=item B<--perl> +=item B<--none> -=item B<--fish> +Produce no output at all. -=item B<--ro-fish> - -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<--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: - eval `virt-inspector --fish guest.img` + 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> + +If this item is passed, I the guest is Windows, I the +external program C is available (see SEE ALSO section), then we +attempt to parse the Windows registry. This allows much more +information to be gathered for Windows guests. + +This is quite an expensive and slow operation, so we don't do it by +default. + =back =cut GetOptions ("help|?" => \$help, + "version" => \$version, "connect|c=s" => \$uri, - "force" => \$force, + "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" }) - or pod2usage (2); + "ro-guestfish" => sub { $output = "ro-fish" }, + "query" => sub { $output = "query" }, + "windows-registry" => \$windows_registry, + ) or pod2usage (2); pod2usage (1) if $help; +if ($version) { + my $g = Sys::Guestfs->new (); + my %h = $g->version (); + print "$h{major}.$h{minor}.$h{release}$h{extra}\n"; + exit +} pod2usage ("$0: no image or VM names given") if @ARGV == 0; -# Domain name or guest image(s)? - -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"); - } - } +my $rw = 0; +$rw = 1 if $output eq "fish"; +my $g; +if ($uri) { + $g = open_guest (\@ARGV, rw => $rw, address => $uri); } else { - die "no libvirt support (install Sys::Virt)" - unless exists $INC{"Sys/Virt.pm"}; - - pod2usage ("$0: too many domains listed on command line") if @ARGV > 1; - - my $vmm; - if (defined $uri) { - $vmm = Sys::Virt->new (uri => $uri, readonly => 1); - } else { - $vmm = Sys::Virt->new (readonly => 1); - } - die "cannot connect to libvirt $uri\n" unless $vmm; - - my @doms = $vmm->list_defined_domains (); - my $dom; - foreach (@doms) { - if ($_->get_name () eq $ARGV[0]) { - $dom = $_; - last; - } - } - die "$ARGV[0] is not the name of an inactive libvirt domain\n" - unless $dom; - - # Get the names of the image(s). - my $xml = $dom->get_xml_description (); - - my $p = new XML::XPath::XMLParser (xml => $xml); - my $disks = $p->find ("//devices/disk"); - print "disks:\n"; - foreach ($disks->get_nodelist) { - print XML::XPath::XMLParser::as_string($_); - } - - die "XXX" + $g = open_guest (\@ARGV, rw => $rw); } -# We've now got the list of @images, so feed them to libguestfs. -my $g = Sys::Guestfs->new (); -$g->add_drive_ro ($_) foreach @images; $g->launch (); $g->wait_ready (); -# We want to get the list of LVs and partitions (ie. anything that -# could contain a filesystem). Discard any partitions which are PVs. -my @partitions = $g->list_partitions (); -my @pvs = $g->pvs (); -sub is_pv { - my $t = shift; - foreach (@pvs) { - return 1 if $_ eq $t; - } - 0; -} -@partitions = grep { ! is_pv ($_) } @partitions; - -my @lvs = $g->lvs (); - =head1 OUTPUT FORMAT Operating system(s) @@ -269,414 +252,77 @@ L command line parameters, so that you can go in afterwards and inspect the guest with everything mounted in the right place. For example: - eval `virt-inspector --ro-fish guest.img` + 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 @devices = sort (@lvs, @partitions); +my @partitions = get_partitions ($g); # Now query each one to build up a picture of what's in it. -my %fses = map { $_ => check_fs ($_) } @devices; - -# Now the complex checking code itself. -# check_fs takes a device name (LV or partition name) and returns -# a hashref containing everything we can find out about the device. -sub check_fs { - local $_; - my $dev = shift; # LV or partition name. - - my %r; # Result hash. - - # First try 'file(1)' on it. - my $file = $g->file ($dev); - if ($file =~ /ext2 filesystem data/) { - $r{fstype} = "ext2"; - $r{fsos} = "linux"; - } elsif ($file =~ /ext3 filesystem data/) { - $r{fstype} = "ext3"; - $r{fsos} = "linux"; - } elsif ($file =~ /ext4 filesystem data/) { - $r{fstype} = "ext4"; - $r{fsos} = "linux"; - } elsif ($file =~ m{Linux/i386 swap file}) { - $r{fstype} = "swap"; - $r{fsos} = "linux"; - $r{is_swap} = 1; - } - - # If it's ext2/3/4, then we want the UUID and label. - if (exists $r{fstype} && $r{fstype} =~ /^ext/) { - $r{uuid} = $g->get_e2uuid ($dev); - $r{label} = $g->get_e2label ($dev); - } - - # Try mounting it, fnarrr. - if (!$r{is_swap}) { - $r{is_mountable} = 1; - eval { $g->mount_ro ($dev, "/") }; - if ($@) { - # It's not mountable, probably empty or some format - # we don't understand. - $r{is_mountable} = 0; - goto OUT; - } - - # Grub /boot? - if ($g->is_file ("/grub/menu.lst") || - $g->is_file ("/grub/grub.conf")) { - $r{content} = "linux-grub"; - check_grub (\%r); - goto OUT; - } - - # Linux root? - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_file ("/etc/fstab")) { - $r{content} = "linux-root"; - $r{is_root} = 1; - check_linux_root (\%r); - goto OUT; - } - - # Linux /usr/local. - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_dir ("/share") && !$g->exists ("/local") && - !$g->is_file ("/etc/fstab")) { - $r{content} = "linux-usrlocal"; - goto OUT; - } - - # Linux /usr. - if ($g->is_dir ("/etc") && $g->is_dir ("/bin") && - $g->is_dir ("/share") && $g->exists ("/local") && - !$g->is_file ("/etc/fstab")) { - $r{content} = "linux-usr"; - goto OUT; - } - - # Windows root? - if ($g->is_file ("/AUTOEXEC.BAT") || - $g->is_file ("/autoexec.bat") || - $g->is_dir ("/Program Files") || - $g->is_dir ("/WINDOWS") || - $g->is_file ("/ntldr")) { - $r{fstype} = "ntfs"; # XXX this is a guess - $r{fsos} = "windows"; - $r{content} = "windows-root"; - $r{is_root} = 1; - check_windows_root (\%r); - goto OUT; - } - } - - OUT: - $g->umount_all (); - return \%r; -} - -sub check_linux_root -{ - local $_; - my $r = shift; - - # Look into /etc to see if we recognise the operating system. - if ($g->is_file ("/etc/redhat-release")) { - $_ = $g->cat ("/etc/redhat-release"); - if (/Fedora release (\d+\.\d+)/) { - $r->{osdistro} = "fedora"; - $r->{osversion} = "$1" - } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+).*Update (\d+)/) { - $r->{osdistro} = "redhat"; - $r->{osversion} = "$2.$3"; - } elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux).*release (\d+(?:\.(\d+))?)/) { - $r->{osdistro} = "redhat"; - $r->{osversion} = "$2"; - } else { - $r->{osdistro} = "redhat"; - } - } elsif ($g->is_file ("/etc/debian_version")) { - $_ = $g->cat ("/etc/debian_version"); - if (/(\d+\.\d+)/) { - $r->{osdistro} = "debian"; - $r->{osversion} = "$1"; - } else { - $r->{osdistro} = "debian"; - } - } - - # Parse the contents of /etc/fstab. This is pretty vital so - # we can determine where filesystems are supposed to be mounted. - eval "\$_ = \$g->cat ('/etc/fstab');"; - if (!$@ && $_) { - my @lines = split /\n/; - my @fstab; - foreach (@lines) { - my @fields = split /[ \t]+/; - if (@fields >= 2) { - my $spec = $fields[0]; # first column (dev/label/uuid) - my $file = $fields[1]; # second column (mountpoint) - if ($spec =~ m{^/} || - $spec =~ m{^LABEL=} || - $spec =~ m{^UUID=} || - $file eq "swap") { - push @fstab, [$spec, $file] - } - } - } - $r->{fstab} = \@fstab if @fstab; - } -} +my %fses = + inspect_all_partitions ($g, \@partitions, + use_windows_registry => $windows_registry); -sub check_windows_root -{ - local $_; - my $r = shift; +#print "fses -----------\n"; +#print Dumper(\%fses); - # Windows version? -} +my $oses = inspect_operating_systems ($g, \%fses); -sub check_grub -{ - local $_; - my $r = shift; +#print "oses -----------\n"; +#print Dumper($oses); - # Grub version, if we care. -} - -#print Dumper (\%fses); - -#---------------------------------------------------------------------- -# Now find out how many operating systems we've got. Usually just one. - -my %oses = (); - -foreach (sort keys %fses) { - if ($fses{$_}->{is_root}) { - my %r = ( - root => $fses{$_}, - root_device => $_ - ); - get_os_version (\%r); - assign_mount_points (\%r); - $oses{$_} = \%r; - } -} - -sub get_os_version -{ - local $_; - my $r = shift; - - $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos}; - $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro}; - $r->{version} = $r->{root}->{osversion} if exists $r->{root}->{osversion}; -} - -sub assign_mount_points -{ - local $_; - my $r = shift; - - $r->{mounts} = { "/" => $r->{root_device} }; - $r->{filesystems} = { $r->{root_device} => $r->{root} }; - - # Use /etc/fstab if we have it to mount the rest. - if (exists $r->{root}->{fstab}) { - my @fstab = @{$r->{root}->{fstab}}; - foreach (@fstab) { - my ($spec, $file) = @$_; - - my ($dev, $fs) = find_filesystem ($spec); - if ($dev) { - $r->{mounts}->{$file} = $dev; - $r->{filesystems}->{$dev} = $fs; - if (exists $fs->{used}) { - $fs->{used}++ - } else { - $fs->{used} = 1 - } - } - } - } -} - -# Find filesystem by device name, LABEL=.. or UUID=.. -sub find_filesystem -{ - local $_ = shift; - - if (/^LABEL=(.*)/) { - my $label = $1; - foreach (sort keys %fses) { - if (exists $fses{$_}->{label} && - $fses{$_}->{label} eq $label) { - return ($_, $fses{$_}); - } - } - warn "unknown filesystem label $label\n"; - return (); - } elsif (/^UUID=(.*)/) { - my $uuid = $1; - foreach (sort keys %fses) { - if (exists $fses{$_}->{uuid} && - $fses{$_}->{uuid} eq $uuid) { - return ($_, $fses{$_}); - } - } - warn "unknown filesystem UUID $uuid\n"; - 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); - -#---------------------------------------------------------------------- # 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); - + foreach $root_dev (sort keys %$oses) { + my $os = $oses->{$root_dev}; + mount_operating_system ($g, $os); + inspect_in_detail ($g, $os); $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 ($distro eq "redhat") { - 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/ - # 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; -} - #---------------------------------------------------------------------- # Output. if ($output eq "fish" || $output eq "ro-fish") { - my @osdevs = keys %oses; + 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 "--ro "; } - print " -a $_" foreach @images; + print "-a $_ " foreach @ARGV; - my $mounts = $oses{$root_dev}->{mounts}; + 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 "-m $mounts->{$_}:$_ " if $_ ne "swap"; } print "\n" } # Perl output. elsif ($output eq "perl") { - print Dumper(\%oses); + 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). @@ -689,9 +335,14 @@ 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; + output_text_os ($oses->{$_}) foreach sort keys %$oses; } sub output_text_os @@ -723,6 +374,30 @@ sub output_text_os 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) { @@ -738,88 +413,364 @@ sub output_text_os 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 { - print "\n"; - output_xml_os ($oses{$_}) foreach sort keys %oses; - print "\n"; + 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 = shift; + my ($os, $xml) = @_; - print "\n"; + $xml->startTag("operatingsystem"); - print "", $os->{os}, "\n" if exists $os->{os}; - print "", $os->{distro}, "\n" if exists $os->{distro}; - print "", $os->{version}, "\n" if exists $os->{version}; - print "", $os->{root_device}, "\n"; + foreach ( [ "name" => "os" ], + [ "distro" => "distro" ], + [ "version" => "version" ], + [ "root" => "root_device" ] ) { + $xml->dataElement($_->[0], $os->{$_->[1]}) if exists $os->{$_->[1]}; + } - print "\n"; + $xml->startTag("mountpoints"); my $mounts = $os->{mounts}; foreach (sort keys %$mounts) { - printf "%s\n", - $mounts->{$_}, $_ + $xml->dataElement("mountpoint", $_, "dev" => $mounts->{$_}); } - print "\n"; + $xml->endTag("mountpoints"); - print "\n"; + $xml->startTag("filesystems"); my $filesystems = $os->{filesystems}; foreach (sort keys %$filesystems) { - print "\n"; - print "\n" - if exists $filesystems->{$_}{label}; - print "$filesystems->{$_}{uuid}\n" - if exists $filesystems->{$_}{uuid}; - print "$filesystems->{$_}{fstype}\n" - if exists $filesystems->{$_}{fstype}; - print "$filesystems->{$_}{content}\n" - if exists $filesystems->{$_}{content}; - print "\n"; + $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"); + } } - print "\n"; - print "\n"; + $xml->startTag("applications"); my @apps = @{$os->{apps}}; foreach (@apps) { - print "\n"; - print "$_->{name}$_->{version}\n"; - print "\n"; + $xml->startTag("application"); + $xml->dataElement("name", $_->{name}); + $xml->dataElement("version", $_->{version}); + $xml->endTag("application"); } - print "\n"; + $xml->endTag("applications"); - print "\n"; + $xml->startTag("kernels"); my @kernels = @{$os->{kernels}}; foreach (@kernels) { - print "\n"; - print "$_->{version}\n"; - print "\n"; + $xml->startTag("kernel", "version" => $_->{version}); + $xml->startTag("modules"); my @modules = @{$_->{modules}}; foreach (@modules) { - print "$_\n"; + $xml->dataElement("module", $_); } - print "\n"; - print "\n"; + $xml->endTag("modules"); + $xml->endTag("kernel"); } - print "\n"; + $xml->endTag("kernels"); - print "\n"; + 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, 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 (); +} + +=item windows=(yes|no) + +Answer C 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 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 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 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 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 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 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 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 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, L, L, -L +L, +L, +L. + +For Windows registry parsing we require the C program +from L. =head1 AUTHOR Richard W.M. Jones L +Matthew Booth L + =head1 COPYRIGHT Copyright (C) 2009 Red Hat Inc.