use strict;
use Sys::Guestfs;
+use Sys::Guestfs::Lib qw(open_guest);
use Pod::Usage;
use Getopt::Long;
use Data::Dumper;
use XML::Writer;
# Optional:
-eval "use Sys::Virt;";
-eval "use XML::XPath;";
-eval "use XML::XPath::XMLParser;";
eval "use YAML::Any;";
=encoding utf8
pod2usage (1) if $help;
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;
-
- foreach (@images) {
- if (! -r $_) {
- die "guest image $_ does not exist or is not readable\n"
- }
- }
+my $rw = 0;
+$rw = 1 if $output eq "fish";
+my $g;
+if ($uri) {
+ $g = open_guest (\@ARGV, rw => $rw, address => $uri);
} else {
- die "virt-inspector: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)\n"
- unless exists $INC{"Sys/Virt.pm"} &&
- exists $INC{"XML/XPath.pm"} &&
- exists $INC{"XML/XPath/XMLParser.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 $isitinactive = "an inactive libvirt domain";
- if ($output ne "fish") {
- # In the special case where we want read-only access to
- # a domain, allow the user to specify an active domain too.
- push @doms, $vmm->list_domains ();
- $isitinactive = "a libvirt domain";
- }
- my $dom;
- foreach (@doms) {
- if ($_->get_name () eq $ARGV[0]) {
- $dom = $_;
- last;
- }
- }
- die "$ARGV[0] is not the name of $isitinactive\n" unless $dom;
-
- # Get the names of the image(s).
- my $xml = $dom->get_xml_description ();
-
- my $p = XML::XPath->new (xml => $xml);
- my @disks = $p->findnodes ('//devices/disk/source/@dev');
- @images = map { $_->getData } @disks;
+ $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 ();
print "--ro ";
}
- print "-a $_ " foreach @images;
+ print "-a $_ " foreach @ARGV;
my $mounts = $oses{$root_dev}->{mounts};
# Have to mount / first. Luckily '/' is early in the ASCII
L<guestfs(3)>,
L<guestfish(1)>,
L<Sys::Guestfs(3)>,
+L<Sys::Guestfs::Lib(3)>,
L<Sys::Virt(3)>,
L<http://libguestfs.org/>.
--- /dev/null
+# Sys::Guestfs::Lib
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Lesser General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with this library; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+package Sys::Guestfs::Lib;
+
+use strict;
+use warnings;
+
+use Sys::Guestfs;
+
+# Optional:
+eval "use Sys::Virt;";
+eval "use XML::XPath;";
+eval "use XML::XPath::XMLParser;";
+
+=pod
+
+=head1 NAME
+
+Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
+
+=head1 SYNOPSIS
+
+ use Sys::Guestfs::Lib qw(#any symbols you want to use);
+
+ $g = open_guest ($name);
+
+=head1 DESCRIPTION
+
+C<Sys::Guestfs::Lib> is an extra library of useful functions for using
+the libguestfs API from Perl. It also provides tighter integration
+with libvirt.
+
+The basic libguestfs API is not covered by this manpage. Please refer
+instead to L<Sys::Guestfs(3)> and L<guestfs(3)>. The libvirt API is
+also not covered. For that, see L<Sys::Virt(3)>.
+
+=head1 FUNCTIONS
+
+=cut
+
+require Exporter;
+
+use vars qw(@EXPORT_OK @ISA);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(open_guest);
+
+=head2 open_guest
+
+ $g = open_guest ($name);
+
+ $g = open_guest ($name, rw => 1, ...);
+
+ $g = open_guest ($name, address => $uri, ...);
+
+ $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
+
+ ($g, $conn, $dom) = open_guest ($name);
+
+This function opens a libguestfs handle for either the libvirt domain
+called C<$name>, or the disk image called C<$name>. Any disk images
+found through libvirt or specified explicitly are attached to the
+libguestfs handle.
+
+The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
+it throws an exception. To catch errors, wrap the call in an eval
+block.
+
+The first parameter is either a string referring to a libvirt domain
+or a disk image, or (if a guest has several disk images) an arrayref
+C<[$img1, $img2, ...]>.
+
+The handle is I<read-only> by default. Use the optional parameter
+C<rw =E<gt> 1> to open a read-write handle. However if you open a
+read-write handle, this function will refuse to use active libvirt
+domains.
+
+The handle is still in the config state when it is returned, so you
+have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
+
+The optional C<address> parameter can be added to specify the libvirt
+URI. In addition, L<Sys::Virt(3)> lists other parameters which are
+passed through to C<Sys::Virt-E<gt>new> unchanged.
+
+The implicit libvirt handle is closed after this function, I<unless>
+you call the function in C<wantarray> context, in which case the
+function returns a tuple of: the open libguestfs handle, the open
+libvirt handle, and the open libvirt domain handle. (This is useful
+if you want to do other things like pulling the XML description of the
+guest). Note that if this is a straight disk image, then C<$conn> and
+C<$dom> will be C<undef>.
+
+If the C<Sys::Virt> module is not available, then libvirt is bypassed,
+and this function can only open disk images.
+
+=cut
+
+sub open_guest
+{
+ my $first = shift;
+ my %params = @_;
+
+ my $readwrite = $params{rw};
+
+ my @images = ();
+ if (ref ($first) eq "ARRAY") {
+ @images = @$first;
+ } elsif (ref ($first) eq "SCALAR") {
+ @images = ($first);
+ } else {
+ die "open_guest: first parameter must be a string or an arrayref"
+ }
+
+ my ($conn, $dom);
+
+ if (-e $images[0]) {
+ foreach (@images) {
+ die "guest image $_ does not exist or is not readable"
+ unless -r $_;
+ }
+ } else {
+ die "open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
+ unless exists $INC{"Sys/Virt.pm"} &&
+ exists $INC{"XML/XPath.pm"} &&
+ exists $INC{"XML/XPath/XMLParser.pm"};
+
+ die "open_guest: too many domains listed on command line"
+ if @images > 1;
+
+ $conn = Sys::Virt->new (readonly => 1, @_);
+ die "open_guest: cannot connect to libvirt" unless $conn;
+
+ my @doms = $conn->list_defined_domains ();
+ my $isitinactive = "an inactive libvirt domain";
+ unless ($readwrite) {
+ # In the case where we want read-only access to a domain,
+ # allow the user to specify an active domain too.
+ push @doms, $conn->list_domains ();
+ $isitinactive = "a libvirt domain";
+ }
+ foreach (@doms) {
+ if ($_->get_name () eq $images[0]) {
+ $dom = $_;
+ last;
+ }
+ }
+ die "$images[0] is not the name of $isitinactive\n" unless $dom;
+
+ # Get the names of the image(s).
+ my $xml = $dom->get_xml_description ();
+
+ my $p = XML::XPath->new (xml => $xml);
+ my @disks = $p->findnodes ('//devices/disk/source/@dev');
+ @images = map { $_->getData } @disks;
+ }
+
+ # We've now got the list of @images, so feed them to libguestfs.
+ my $g = Sys::Guestfs->new ();
+ foreach (@images) {
+ if ($readwrite) {
+ $g->add_drive ($_);
+ } else {
+ $g->add_drive_ro ($_);
+ }
+ }
+
+ return wantarray ? ($g, $conn, $dom) : $g
+}
+
+1;
+
+=head1 COPYRIGHT
+
+Copyright (C) 2009 Red Hat Inc.
+
+=head1 LICENSE
+
+Please see the file COPYING.LIB for the full license.
+
+=head1 SEE ALSO
+
+L<virt-inspector(1)>,
+L<Sys::Guestfs(3)>,
+L<guestfs(3)>,
+L<http://libguestfs.org/>,
+L<Sys::Virt(3)>,
+L<http://libvirt.org/>,
+L<guestfish(1)>.
+
+=cut