perl/lib/Sys/Guestfs/Lib.pm

   1 # Sys::Guestfs::Lib
   2 # Copyright (C) 2009 Red Hat Inc.
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 package Sys::Guestfs::Lib;
  19
  20 use strict;
  21 use warnings;
  22
  23 use Sys::Guestfs;
  24
  25 # Optional:
  26 eval "use Sys::Virt;";
  27 eval "use XML::XPath;";
  28 eval "use XML::XPath::XMLParser;";
  29
  30 =pod
  31
  32 =head1 NAME
  33
  34 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
  35
  36 =head1 SYNOPSIS
  37
  38  use Sys::Guestfs::Lib qw(#any symbols you want to use);
  39
  40  $g = open_guest ($name);
  41
  42 =head1 DESCRIPTION
  43
  44 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
  45 the libguestfs API from Perl.  It also provides tighter integration
  46 with libvirt.
  47
  48 The basic libguestfs API is not covered by this manpage.  Please refer
  49 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
  50 also not covered.  For that, see L<Sys::Virt(3)>.
  51
  52 =head1 FUNCTIONS
  53
  54 =cut
  55
  56 require Exporter;
  57
  58 use vars qw(@EXPORT_OK @ISA);
  59
  60 @ISA = qw(Exporter);
  61 @EXPORT_OK = qw(open_guest get_partitions);
  62
  63 =head2 open_guest
  64
  65  $g = open_guest ($name);
  66
  67  $g = open_guest ($name, rw => 1, ...);
  68
  69  $g = open_guest ($name, address => $uri, ...);
  70
  71  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
  72
  73  ($g, $conn, $dom) = open_guest ($name);
  74
  75 This function opens a libguestfs handle for either the libvirt domain
  76 called C<$name>, or the disk image called C<$name>.  Any disk images
  77 found through libvirt or specified explicitly are attached to the
  78 libguestfs handle.
  79
  80 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
  81 it throws an exception.  To catch errors, wrap the call in an eval
  82 block.
  83
  84 The first parameter is either a string referring to a libvirt domain
  85 or a disk image, or (if a guest has several disk images) an arrayref
  86 C<[$img1, $img2, ...]>.
  87
  88 The handle is I<read-only> by default.  Use the optional parameter
  89 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
  90 read-write handle, this function will refuse to use active libvirt
  91 domains.
  92
  93 The handle is still in the config state when it is returned, so you
  94 have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
  95
  96 The optional C<address> parameter can be added to specify the libvirt
  97 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
  98 passed through to C<Sys::Virt-E<gt>new> unchanged.
  99
 100 The implicit libvirt handle is closed after this function, I<unless>
 101 you call the function in C<wantarray> context, in which case the
 102 function returns a tuple of: the open libguestfs handle, the open
 103 libvirt handle, and the open libvirt domain handle.  (This is useful
 104 if you want to do other things like pulling the XML description of the
 105 guest).  Note that if this is a straight disk image, then C<$conn> and
 106 C<$dom> will be C<undef>.
 107
 108 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
 109 and this function can only open disk images.
 110
 111 =cut
 112
 113 sub open_guest
 114 {
 115     my $first = shift;
 116     my %params = @_;
 117
 118     my $readwrite = $params{rw};
 119
 120     my @images = ();
 121     if (ref ($first) eq "ARRAY") {
 122         @images = @$first;
 123     } elsif (ref ($first) eq "SCALAR") {
 124         @images = ($first);
 125     } else {
 126         die "open_guest: first parameter must be a string or an arrayref"
 127     }
 128
 129     my ($conn, $dom);
 130
 131     if (-e $images[0]) {
 132         foreach (@images) {
 133             die "guest image $_ does not exist or is not readable"
 134                 unless -r $_;
 135         }
 136     } else {
 137         die "open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
 138             unless exists $INC{"Sys/Virt.pm"} &&
 139             exists $INC{"XML/XPath.pm"} &&
 140             exists $INC{"XML/XPath/XMLParser.pm"};
 141
 142         die "open_guest: too many domains listed on command line"
 143             if @images > 1;
 144
 145         $conn = Sys::Virt->new (readonly => 1, @_);
 146         die "open_guest: cannot connect to libvirt" unless $conn;
 147
 148         my @doms = $conn->list_defined_domains ();
 149         my $isitinactive = "an inactive libvirt domain";
 150         unless ($readwrite) {
 151             # In the case where we want read-only access to a domain,
 152             # allow the user to specify an active domain too.
 153             push @doms, $conn->list_domains ();
 154             $isitinactive = "a libvirt domain";
 155         }
 156         foreach (@doms) {
 157             if ($_->get_name () eq $images[0]) {
 158                 $dom = $_;
 159                 last;
 160             }
 161         }
 162         die "$images[0] is not the name of $isitinactive\n" unless $dom;
 163
 164         # Get the names of the image(s).
 165         my $xml = $dom->get_xml_description ();
 166
 167         my $p = XML::XPath->new (xml => $xml);
 168         my @disks = $p->findnodes ('//devices/disk/source/@dev');
 169         @images = map { $_->getData } @disks;
 170     }
 171
 172     # We've now got the list of @images, so feed them to libguestfs.
 173     my $g = Sys::Guestfs->new ();
 174     foreach (@images) {
 175         if ($readwrite) {
 176             $g->add_drive ($_);
 177         } else {
 178             $g->add_drive_ro ($_);
 179         }
 180     }
 181
 182     return wantarray ? ($g, $conn, $dom) : $g
 183 }
 184
 185 =head2 get_partitions
 186
 187  @partitions = get_partitions ($g);
 188
 189 This function takes an open libguestfs handle C<$g> and returns all
 190 partitions and logical volumes found on it.
 191
 192 What is returned is everything that could contain a filesystem (or
 193 swap).  Physical volumes are excluded from the list, and so are any
 194 devices which are partitioned (eg. C</dev/sda> would not be returned
 195 if C</dev/sda1> exists).
 196
 197 =cut
 198
 199 sub get_partitions
 200 {
 201     my $g = shift;
 202
 203     my @partitions = $g->list_partitions ();
 204     my @pvs = $g->pvs ();
 205     @partitions = grep { ! is_pv ($_, @pvs) } @partitions;
 206
 207     my @lvs = $g->lvs ();
 208
 209     return sort (@lvs, @partitions);
 210 }
 211
 212 sub is_pv {
 213     local $_;
 214     my $t = shift;
 215
 216     foreach (@_) {
 217         return 1 if $_ eq $t;
 218     }
 219     0;
 220 }
 221
 222 1;
 223
 224 =head1 COPYRIGHT
 225
 226 Copyright (C) 2009 Red Hat Inc.
 227
 228 =head1 LICENSE
 229
 230 Please see the file COPYING.LIB for the full license.
 231
 232 =head1 SEE ALSO
 233
 234 L<virt-inspector(1)>,
 235 L<Sys::Guestfs(3)>,
 236 L<guestfs(3)>,
 237 L<http://libguestfs.org/>,
 238 L<Sys::Virt(3)>,
 239 L<http://libvirt.org/>,
 240 L<guestfish(1)>.
 241
 242 =cut