Fixed Perl bindings, they now work properly.

10 files changed, 306 insertions, 12 deletions

diff --git a/perl/Guestfs.xs b/perl/Guestfs.xs
index e3f17c25..58def0d7 100644
--- a/perl/Guestfs.xs
+++ b/perl/Guestfs.xs
@@ -25,8 +25,6 @@
 
 #include <guestfs.h>
 
-/* #include cannot be used for local files in XS */
-
 #ifndef PRId64
 #define PRId64 "lld"
 #endif
@@ -79,19 +77,112 @@ MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
 
 guestfs_h *
 _create ()
-CODE:
-    RETVAL = guestfs_create ();
-    if (!RETVAL)
-      croak ("could not create guestfs handle");
-    guestfs_set_error_handler (RETVAL, error_handler, NULL);
-OUTPUT:
-    RETVAL
+   CODE:
+      RETVAL = guestfs_create ();
+      if (!RETVAL)
+        croak ("could not create guestfs handle");
+      guestfs_set_error_handler (RETVAL, error_handler, NULL);
+ OUTPUT:
+      RETVAL
 
 void
 DESTROY (g)
-    guestfs_h *g;
-PPCODE:
-    guestfs_close (g);
+      guestfs_h *g;
+ PPCODE:
+      guestfs_close (g);
+
+void
+add_drive (g, filename)
+      guestfs_h *g;
+      const char *filename;
+   CODE:
+      if (guestfs_add_drive (g, filename) == -1)
+        croak ("add_drive: %s", last_error);
+
+void
+add_cdrom (g, filename)
+      guestfs_h *g;
+      const char *filename;
+   CODE:
+      if (guestfs_add_cdrom (g, filename) == -1)
+        croak ("add_cdrom: %s", last_error);
+
+void
+config (g, param, value)
+      guestfs_h *g;
+      const char *param;
+      const char *value;
+   CODE:
+      if (guestfs_config (g, param, value) == -1)
+        croak ("config: %s", last_error);
+
+void
+launch (g)
+      guestfs_h *g;
+   CODE:
+      if (guestfs_launch (g) == -1)
+        croak ("launch: %s", last_error);
+
+void
+wait_ready (g)
+      guestfs_h *g;
+   CODE:
+      if (guestfs_wait_ready (g) == -1)
+        croak ("wait_ready: %s", last_error);
+
+void
+set_path (g, path)
+      guestfs_h *g;
+      const char *path;
+   CODE:
+      guestfs_set_path (g, path);
+
+SV *
+get_path (g)
+      guestfs_h *g;
+PREINIT:
+      const char *path;
+   CODE:
+      path = guestfs_get_path (g);
+      RETVAL = newSVpv (path, 0);
+ OUTPUT:
+      RETVAL
+
+void
+set_autosync (g, autosync)
+      guestfs_h *g;
+      int autosync;
+   CODE:
+      guestfs_set_autosync (g, autosync);
+
+SV *
+get_autosync (g)
+      guestfs_h *g;
+PREINIT:
+      int autosync;
+   CODE:
+      autosync = guestfs_get_autosync (g);
+      RETVAL = newSViv (autosync);
+ OUTPUT:
+      RETVAL
+
+void
+set_verbose (g, verbose)
+      guestfs_h *g;
+      int verbose;
+   CODE:
+      guestfs_set_verbose (g, verbose);
+
+SV *
+get_verbose (g)
+      guestfs_h *g;
+PREINIT:
+      int verbose;
+   CODE:
+      verbose = guestfs_get_verbose (g);
+      RETVAL = newSViv (verbose);
+ OUTPUT:
+      RETVAL
 
 void
 mount (g, device, mountpoint)
diff --git a/perl/Makefile.am b/perl/Makefile.am
index ea9835b0..2b5b1ddb 100644
--- a/perl/Makefile.am
+++ b/perl/Makefile.am
@@ -26,6 +26,9 @@ if HAVE_PERL
 
 # Interfacing automake and ExtUtils::MakeMaker known to be
 # a nightmare, news at 11.
+
+TESTS = run-perl-tests
+
 all:
 	perl Makefile.PL
 	make -f Makefile-pl
diff --git a/perl/examples/LICENSE b/perl/examples/LICENSE
new file mode 100644
index 00000000..ff237009
--- /dev/null
+++ b/perl/examples/LICENSE
@@ -0,0 +1,2 @@
+All the examples in the perl/examples/ subdirectory may be freely
+copied without any restrictions.
diff --git a/perl/examples/README b/perl/examples/README
new file mode 100644
index 00000000..a7c654f7
--- /dev/null
+++ b/perl/examples/README
@@ -0,0 +1,17 @@
+This directory contains various example programs which use the perl
+Sys::Guestfs bindings to the libguestfs API.
+
+As they are examples, these are licensed so they can be freely copied
+and used without any restrictions.
+
+Tips:
+
+(1) To enable verbose messages, set environment variable LIBGUESTFS_DEBUG=1
+
+(2) To run a program without installing the library, set PERL5LIB and
+LIBGUESTFS_PATH as in this example (if run from the root directory of
+the source distribution):
+
+  LIBGUESTFS_PATH=$(pwd) \
+  PERL5LIB=$(pwd)/perl/blib/lib:$(pwd)/perl/blib/arch/auto/Sys/Guestfs \
+  perl/examples/foo
diff --git a/perl/examples/lvs.pl b/perl/examples/lvs.pl
new file mode 100755
index 00000000..152db088
--- /dev/null
+++ b/perl/examples/lvs.pl
@@ -0,0 +1,29 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Sys::Guestfs;
+
+# Look for LVM LVs, VGs and PVs in a guest image.
+
+die "Usage: lvs.pl guest.img\n" if @ARGV != 1 || ! -f $ARGV[0];
+
+print "Creating the libguestfs handle\n";
+my $h = Sys::Guestfs->new ();
+$h->add_drive ($ARGV[0]);
+
+print "Launching, this can take a few seconds\n";
+$h->launch ();
+$h->wait_ready ();
+
+print "Looking for PVs on the disk image\n";
+my @pvs = $h->pvs ();
+print "PVs found: (", join (", ", @pvs), ")\n";
+
+print "Looking for VGs on the disk image\n";
+my @vgs = $h->vgs ();
+print "VGs found: (", join (", ", @vgs), ")\n";
+
+print "Looking for LVs on the disk image\n";
+my @lvs = $h->lvs ();
+print "LVs found: (", join (", ", @lvs), ")\n";
diff --git a/perl/lib/Sys/Guestfs.pm b/perl/lib/Sys/Guestfs.pm
index c0a9b79f..0a8226fe 100644
--- a/perl/lib/Sys/Guestfs.pm
+++ b/perl/lib/Sys/Guestfs.pm
@@ -91,6 +91,62 @@ sub new {
   return $self;
 }
 
+=item $h->add_drive ($filename);
+
+=item $h->add_cdrom ($filename);
+
+This function adds a virtual machine disk image C<filename> to the
+guest.  The first time you call this function, the disk appears as IDE
+disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
+so on.
+
+You don't necessarily need to be root when using libguestfs.  However
+you obviously do need sufficient permissions to access the filename
+for whatever operations you want to perform (ie. read access if you
+just want to read the image or write access if you want to modify the
+image).
+
+The C<add_cdrom> variation adds a CD-ROM device.
+
+=item $h->config ($param, $value);
+
+=item $h->config ($param);
+
+Use this to add arbitrary parameters to the C<qemu> command line.
+See L<qemu(1)>.
+
+=item $h->launch ();
+
+=item $h->wait_ready ();
+
+Internally libguestfs is implemented by running a virtual machine
+using L<qemu(1)>.  These calls are necessary in order to boot the
+virtual machine.
+
+You should call these two functions after configuring the handle
+(eg. adding drives) but before performing any actions.
+
+=item $h->set_path ($path);
+
+=item $path = $h->get_path ();
+
+See the discussion of C<PATH> in the L<guestfs(3)>
+manpage.
+
+=item $h->set_autosync ($autosync);
+
+=item $autosync = $h->get_autosync ();
+
+See the discussion of I<AUTOSYNC> in the L<guestfs(3)>
+manpage.
+
+=item $h->set_verbose ($verbose);
+
+=item $verbose = $h->get_verbose ();
+
+This sets or gets the verbose messages flag.  Verbose
+messages are sent to C<stderr>.
+
 =item $content = $h->cat (path);
 
 Return the contents of the file named C<path>.
diff --git a/perl/run-perl-tests b/perl/run-perl-tests
new file mode 100755
index 00000000..7fc29219
--- /dev/null
+++ b/perl/run-perl-tests
@@ -0,0 +1,19 @@
+#!/bin/sh -
+# libguestfs Perl bindings
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+make -f Makefile-pl test
diff --git a/perl/t/005-pod.t b/perl/t/005-pod.t
new file mode 100644
index 00000000..54025f12
--- /dev/null
+++ b/perl/t/005-pod.t
@@ -0,0 +1,24 @@
+# libguestfs Perl bindings -*- perl -*-
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+use Test::More;
+use strict;
+use warnings;
+
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok ();
diff --git a/perl/t/006-pod-coverage.t b/perl/t/006-pod-coverage.t
new file mode 100644
index 00000000..fd1c4058
--- /dev/null
+++ b/perl/t/006-pod-coverage.t
@@ -0,0 +1,24 @@
+# libguestfs Perl bindings -*- perl -*-
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+use Test::More;
+use strict;
+use warnings;
+
+eval "use Test::Pod::Coverage 1.00";
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD" if $@;
+all_pod_coverage_ok ();
diff --git a/perl/t/010-load.t b/perl/t/010-load.t
new file mode 100644
index 00000000..4aeffb7f
--- /dev/null
+++ b/perl/t/010-load.t
@@ -0,0 +1,29 @@
+# libguestfs Perl bindings -*- perl -*-
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+use strict;
+use warnings;
+use Test::More;
+
+plan tests => 1;
+
+BEGIN {
+    use_ok ("Sys::Guestfs") or die;
+}
+
+my $h = Sys::Guestfs::create ();
+ok ($h);