=item B<--xml>
+=item B<--perl>
+
=item B<--fish>
=item B<--ro-fish>
If you select I<--xml> then you get XML output which can be fed
to other programs.
+If you select I<--perl> then you get Perl structures output which
+can be used directly in another Perl program.
+
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:
"connect|c=s" => \$uri,
"force" => \$force,
"xml" => sub { $output = "xml" },
+ "perl" => sub { $output = "perl" },
"fish" => sub { $output = "fish" },
"guestfish" => sub { $output = "fish" },
"ro-fish" => sub { $output = "ro-fish" },
# 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$/) {
+ 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);
+ $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/<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,) {
+ 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;
+ # 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 ();
+}
+
+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};
+ }
+
+ 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";
+
+ 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 SEE ALSO
git.annexia.org / libguestfs.git / blobdiff