X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=inspector%2Fvirt-inspector.pl;h=9148a486d7e1f4928a23fbf9777d6b2d9bc4b4eb;hp=1d8a84b424eb73ceafee041f0e1d76d371506aa7;hb=000f54aac80191b42e0c307440d09fafd4d5fac2;hpb=27161658c897544a58c7d4f87c08f2ee8ce08d43 diff --git a/inspector/virt-inspector.pl b/inspector/virt-inspector.pl index 1d8a84b..9148a48 100755 --- a/inspector/virt-inspector.pl +++ b/inspector/virt-inspector.pl @@ -20,13 +20,17 @@ 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 File::Temp qw/tempdir/; +use XML::Writer; +use Locale::TextDomain 'libguestfs'; # Optional: -eval "use Sys::Virt;"; +eval "use YAML::Any;"; =encoding utf8 @@ -85,6 +89,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> @@ -98,18 +110,6 @@ then libvirt is not used at all. =cut -my $force; - -=item B<--force> - -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 @@ -132,6 +132,11 @@ Produce no output at all. 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 @@ -145,7 +150,7 @@ 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. @@ -176,11 +181,12 @@ default. =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" }, @@ -190,78 +196,31 @@ GetOptions ("help|?" => \$help, "windows-registry" => \$windows_registry, ) or pod2usage (2); pod2usage (1) if $help; -pod2usage ("$0: no image or VM names given") if @ARGV == 0; - -# Domain name or guest image(s)? +if ($version) { + my $g = Sys::Guestfs->new (); + my %h = $g->version (); + print "$h{major}.$h{minor}.$h{release}$h{extra}\n"; + exit +} +pod2usage (__"virt-inspector: no image or VM names given") if @ARGV == 0; +my $rw = 0; +$rw = 1 if $output eq "fish"; +my $g; my @images; -if (-e $ARGV[0]) { - @images = @ARGV; - - foreach (@images) { - if (! -r $_) { - die "guest image $_ does not exist or is not readable\n" - } - } +if ($uri) { + my ($conn, $dom); + ($g, $conn, $dom, @images) = + 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" + my ($conn, $dom); + ($g, $conn, $dom, @images) = + 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) @@ -299,631 +258,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; - } +my %fses = + inspect_all_partitions ($g, \@partitions, + use_windows_registry => $windows_registry); - # 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; - } +#print "fses -----------\n"; +#print Dumper(\%fses); - # 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 ("/boot.ini") || - $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; - } - } +my $oses = inspect_operating_systems ($g, \%fses); - OUT: - $g->umount_all (); - return \%r; -} +#print "oses -----------\n"; +#print Dumper($oses); -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; - } -} - -# We only support NT. The control file /boot.ini contains a list of -# Windows installations and their %systemroot%s in a simple text -# format. -# -# XXX We could parse this better. This won't work if /boot.ini is on -# a different drive from the %systemroot%, and in other unusual cases. - -sub check_windows_root -{ - local $_; - my $r = shift; - - my $boot_ini = resolve_windows_path ("/", "boot.ini"); - $r->{boot_ini} = $boot_ini; - - if (defined $r->{boot_ini}) { - $_ = $g->cat ($boot_ini); - my @lines = split /\n/; - my $section; - my $systemroot; - foreach (@lines) { - if (m/\[.*\]/) { - $section = $1; - } elsif (m/^default=.*?\\(\w+)$/i) { - $systemroot = $1; - last; - } elsif (m/\\(\w+)=/) { - $systemroot = $1; - last; - } - } - - if (defined $systemroot) { - $r->{systemroot} = resolve_windows_path ("/", $systemroot); - if (defined $r->{systemroot} && $windows_registry) { - check_windows_registry ($r, $r->{systemroot}); - } - } - } -} - -sub check_windows_registry -{ - local $_; - my $r = shift; - my $systemroot = shift; - - # Download the system registry files. Only download the - # interesting ones, and we don't bother with user profiles at all. - my $system32 = resolve_windows_path ($systemroot, "system32"); - if (defined $system32) { - my $config = resolve_windows_path ($system32, "config"); - if (defined $config) { - my $software = resolve_windows_path ($config, "software"); - if (defined $software) { - load_windows_registry ($r, $software, - "HKEY_LOCAL_MACHINE\\SOFTWARE"); - } - my $system = resolve_windows_path ($config, "system"); - if (defined $system) { - load_windows_registry ($r, $system, - "HKEY_LOCAL_MACHINE\\System"); - } - } - } -} - -sub load_windows_registry -{ - local $_; - my $r = shift; - my $regfile = shift; - my $prefix = shift; - - my $dir = tempdir (CLEANUP => 1); - - $g->download ($regfile, "$dir/reg"); - - # 'reged' command is particularly noisy. Redirect stdout and - # stderr to /dev/null temporarily. - open SAVEOUT, ">&STDOUT"; - open SAVEERR, ">&STDERR"; - open STDOUT, ">/dev/null"; - open STDERR, ">/dev/null"; - - my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out"); - my $res = system (@cmd); - - close STDOUT; - close STDERR; - open STDOUT, ">&SAVEOUT"; - open STDERR, ">&SAVEERR"; - close SAVEOUT; - close SAVEERR; - - unless ($res == 0) { - warn "reged command failed: $?"; - return; - } - - # Some versions of reged segfault on inputs. If that happens we - # may get no / partial output file. Anyway, if it exists, load - # it. - my $content; - unless (open F, "$dir/out") { - warn "no output from reged command: $!"; - return; - } - { local $/ = undef; $content = ; } - close F; - - my @registry = (); - @registry = @{$r->{registry}} if exists $r->{registry}; - push @registry, $content; - $r->{registry} = \@registry; -} - -# Because of case sensitivity, the actual path might have a different -# name, and ntfs-3g is always case sensitive. Find out what the real -# path is. Returns the correct full path, or undef. -sub resolve_windows_path -{ - local $_; - my $parent = shift; # Must exist, with correct case. - my $dir = shift; - - foreach ($g->ls ($parent)) { - if (lc ($_) eq lc ($dir)) { - if ($parent eq "/") { - return "/$_" - } else { - return "$parent/$_" - } - } - } - - undef; -} - -sub check_grub -{ - local $_; - my $r = shift; - - # 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$/) { - # 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); - } - + 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 (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/ - # 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 =

; } - 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 (

) { - 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; + 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; + 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 @images; - 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" && $_ ne "none"; } 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). @@ -943,7 +348,7 @@ elsif ($output eq "query") { sub output_text { - output_text_os ($oses{$_}) foreach sort keys %oses; + output_text_os ($oses->{$_}) foreach sort keys %$oses; } sub output_text_os @@ -952,16 +357,18 @@ sub output_text_os print $os->{os}, " " if exists $os->{os}; print $os->{distro}, " " if exists $os->{distro}; - print $os->{version}, " " if exists $os->{version}; + print $os->{major_version} if exists $os->{major_version}; + print ".", $os->{minor_version} if exists $os->{minor_version}; + print " "; print "on ", $os->{root_device}, ":\n"; - print " Mountpoints:\n"; + print __" Mountpoints:\n"; my $mounts = $os->{mounts}; foreach (sort keys %$mounts) { printf " %-30s %s\n", $mounts->{$_}, $_ } - print " Filesystems:\n"; + print __" Filesystems:\n"; my $filesystems = $os->{filesystems}; foreach (sort keys %$filesystems) { print " $_:\n"; @@ -979,9 +386,9 @@ sub output_text_os my %aliases = %{$os->{modprobe_aliases}}; my @keys = sort keys %aliases; if (@keys) { - print " Modprobe aliases:\n"; + print __" Modprobe aliases:\n"; foreach (@keys) { - printf " %-30s %s\n", $_, $aliases{$_} + printf " %-30s %s\n", $_, $aliases{$_}->{modulename} } } } @@ -990,7 +397,7 @@ sub output_text_os my %modvers = %{$os->{initrd_modules}}; my @keys = sort keys %modvers; if (@keys) { - print " Initrd modules:\n"; + print __" Initrd modules:\n"; foreach (@keys) { my @modules = @{$modvers{$_}}; print " $_:\n"; @@ -999,13 +406,13 @@ sub output_text_os } } - print " Applications:\n"; + print __" Applications:\n"; my @apps = @{$os->{apps}}; foreach (@apps) { print " $_->{name} $_->{version}\n" } - print " Kernels:\n"; + print __" Kernels:\n"; my @kernels = @{$os->{kernels}}; foreach (@kernels) { print " $_->{version}\n"; @@ -1016,7 +423,7 @@ sub output_text_os } if (exists $os->{root}->{registry}) { - print " Windows Registry entries:\n"; + print __" Windows Registry entries:\n"; # These are just lumps of text - dump them out. foreach (@{$os->{root}->{registry}}) { print "$_\n"; @@ -1026,55 +433,73 @@ sub output_text_os 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" ], + [ "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]}; + } - 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"); } - print "\n"; + $xml->endTag("filesystems"); if (exists $os->{modprobe_aliases}) { my %aliases = %{$os->{modprobe_aliases}}; my @keys = sort keys %aliases; if (@keys) { - print "\n"; + $xml->startTag("modprobealiases"); foreach (@keys) { - printf "%s\n", $_, $aliases{$_} + $xml->startTag("alias", "device" => $_); + + foreach my $field ( [ "modulename" => "modulename" ], + [ "augeas" => "augeas" ], + [ "file" => "file" ] ) { + $xml->dataElement($field->[0], $aliases{$_}->{$field->[1]}); + } + + $xml->endTag("alias"); } - print "\n"; + $xml->endTag("modprobealiases"); } } @@ -1082,63 +507,51 @@ sub output_xml_os my %modvers = %{$os->{initrd_modules}}; my @keys = sort keys %modvers; if (@keys) { - print "\n"; + $xml->startTag("initrds"); foreach (@keys) { my @modules = @{$modvers{$_}}; - print "\n"; - print "$_\n" foreach @modules; - print "\n"; + $xml->startTag("initrd", "version" => $_); + $xml->dataElement("module", $_) foreach @modules; + $xml->endTag("initrd"); } - print "\n"; + $xml->endTag("initrds"); } } - 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"); if (exists $os->{root}->{registry}) { - print "\n"; + $xml->startTag("windowsregistryentries"); # These are just lumps of text - dump them out. foreach (@{$os->{root}->{registry}}) { - print "\n"; - print escape_xml($_), "\n"; - print "\n"; + $xml->dataElement("windowsregistryentry", $_); } - print "\n"; + $xml->endTag("windowsregistryentries"); } - print "\n"; -} - -sub escape_xml -{ - local $_ = shift; - - s/&/&/g; - s//>/g; - return $_; + $xml->endTag("operatingsystem"); } =head1 QUERY MODE @@ -1189,8 +602,8 @@ Answer C if Microsoft Windows is installed in the guest. sub output_query_windows { my $windows = "no"; - foreach my $os (keys %oses) { - $windows="yes" if $oses{$os}->{os} eq "windows"; + foreach my $os (keys %$oses) { + $windows="yes" if $oses->{$os}->{os} eq "windows"; } print "windows=$windows\n"; } @@ -1204,8 +617,8 @@ Answer C if a Linux kernel is installed in the guest. sub output_query_linux { my $linux = "no"; - foreach my $os (keys %oses) { - $linux="yes" if $oses{$os}->{os} eq "linux"; + foreach my $os (keys %$oses) { + $linux="yes" if $oses->{$os}->{os} eq "linux"; } print "linux=$linux\n"; } @@ -1219,8 +632,9 @@ Answer C if the guest contains Red Hat Enterprise Linux. 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"; + foreach my $os (keys %$oses) { + $rhel="yes" if ($oses->{$os}->{os} eq "linux" && + $oses->{$os}->{distro} eq "rhel"); } print "rhel=$rhel\n"; } @@ -1234,8 +648,8 @@ Answer C if the guest contains the Fedora Linux distribution. 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"; + foreach my $os (keys %$oses) { + $fedora="yes" if $oses->{$os}->{os} eq "linux" && $oses->{$os}->{distro} eq "fedora"; } print "fedora=$fedora\n"; } @@ -1249,8 +663,8 @@ Answer C if the guest contains the Debian Linux distribution. 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"; + foreach my $os (keys %$oses) { + $debian="yes" if $oses->{$os}->{os} eq "linux" && $oses->{$os}->{distro} eq "debian"; } print "debian=$debian\n"; } @@ -1268,8 +682,8 @@ 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}}) { + 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"; @@ -1290,8 +704,8 @@ guest). sub output_query_xen_domU_kernel { - foreach my $os (keys %oses) { - foreach my $kernel (@{$oses{$os}->{kernels}}) { + 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"; @@ -1313,8 +727,8 @@ reasons). sub output_query_xen_pv_drivers { - foreach my $os (keys %oses) { - foreach my $kernel (@{$oses{$os}->{kernels}}) { + 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"; @@ -1336,8 +750,8 @@ performance of KVM. sub output_query_virtio_drivers { - foreach my $os (keys %oses) { - foreach my $kernel (@{$oses{$os}->{kernels}}) { + 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"; @@ -1356,6 +770,7 @@ sub output_query_virtio_drivers L, L, L, +L, L, L. @@ -1366,6 +781,8 @@ from L. Richard W.M. Jones L +Matthew Booth L + =head1 COPYRIGHT Copyright (C) 2009 Red Hat Inc.