First version of Perl bindings, compiled but not tested.
authorRichard Jones <rjones@redhat.com>
Wed, 8 Apr 2009 12:44:13 +0000 (13:44 +0100)
committerRichard Jones <rjones@redhat.com>
Wed, 8 Apr 2009 12:44:13 +0000 (13:44 +0100)
.gitignore
configure.ac
perl/Guestfs.xs [new file with mode: 0644]
perl/Makefile.PL.in [new file with mode: 0644]
perl/Makefile.am
perl/lib/Sys/Guestfs.pm [new file with mode: 0644]
perl/typemap [new file with mode: 0644]
src/generator.ml

index 63ec1f6..6772ac2 100644 (file)
@@ -50,6 +50,11 @@ ocaml/*.cma
 ocaml/*.cmxa
 ocaml/*.a
 ocaml/*.so
+perl/Guestfs.c
+perl/Makefile-pl
+perl/Makefile.PL
+perl/blib
+perl/pm_to_blib
 stamp-h1
 test*.img
 update-initramfs.sh
index 1359cb0..29ab3ce 100644 (file)
@@ -124,7 +124,7 @@ AC_CONFIG_FILES([Makefile src/Makefile fish/Makefile examples/Makefile
                 python/Makefile
                 make-initramfs.sh update-initramfs.sh
                 libguestfs.spec
-                ocaml/META])
+                ocaml/META perl/Makefile.PL])
 AC_OUTPUT
 
 dnl WTF?
diff --git a/perl/Guestfs.xs b/perl/Guestfs.xs
new file mode 100644 (file)
index 0000000..e3f17c2
--- /dev/null
@@ -0,0 +1,361 @@
+/* libguestfs generated file
+ * WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.
+ * ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.
+ *
+ * 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
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <guestfs.h>
+
+/* #include cannot be used for local files in XS */
+
+#ifndef PRId64
+#define PRId64 "lld"
+#endif
+
+static SV *
+my_newSVll(long long val) {
+#ifdef USE_64_BIT_ALL
+  return newSViv(val);
+#else
+  char buf[100];
+  int len;
+  len = snprintf(buf, 100, "%" PRId64, val);
+  return newSVpv(buf, len);
+#endif
+}
+
+#ifndef PRIu64
+#define PRIu64 "llu"
+#endif
+
+static SV *
+my_newSVull(unsigned long long val) {
+#ifdef USE_64_BIT_ALL
+  return newSVuv(val);
+#else
+  char buf[100];
+  int len;
+  len = snprintf(buf, 100, "%" PRIu64, val);
+  return newSVpv(buf, len);
+#endif
+}
+
+/* XXX Not thread-safe, and in general not safe if the caller is
+ * issuing multiple requests in parallel (on different guestfs
+ * handles).  We should use the guestfs_h handle passed to the
+ * error handle to distinguish these cases.
+ */
+static char *last_error = NULL;
+
+static void
+error_handler (guestfs_h *g,
+              void *data,
+              const char *msg)
+{
+  if (last_error != NULL) free (last_error);
+  last_error = strdup (msg);
+}
+
+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
+
+void
+DESTROY (g)
+    guestfs_h *g;
+PPCODE:
+    guestfs_close (g);
+
+void
+mount (g, device, mountpoint)
+      guestfs_h *g;
+      char *device;
+      char *mountpoint;
+ PPCODE:
+      if (guestfs_mount (g, device, mountpoint) == -1)
+        croak ("mount: %s", last_error);
+
+void
+sync (g)
+      guestfs_h *g;
+ PPCODE:
+      if (guestfs_sync (g) == -1)
+        croak ("sync: %s", last_error);
+
+void
+touch (g, path)
+      guestfs_h *g;
+      char *path;
+ PPCODE:
+      if (guestfs_touch (g, path) == -1)
+        croak ("touch: %s", last_error);
+
+SV *
+cat (g, path)
+      guestfs_h *g;
+      char *path;
+PREINIT:
+      char *content;
+   CODE:
+      content = guestfs_cat (g, path);
+      if (content == NULL)
+        croak ("cat: %s", last_error);
+      RETVAL = newSVpv (content, 0);
+      free (content);
+ OUTPUT:
+      RETVAL
+
+SV *
+ll (g, directory)
+      guestfs_h *g;
+      char *directory;
+PREINIT:
+      char *listing;
+   CODE:
+      listing = guestfs_ll (g, directory);
+      if (listing == NULL)
+        croak ("ll: %s", last_error);
+      RETVAL = newSVpv (listing, 0);
+      free (listing);
+ OUTPUT:
+      RETVAL
+
+void
+ls (g, directory)
+      guestfs_h *g;
+      char *directory;
+PREINIT:
+      char **listing;
+      int i, n;
+ PPCODE:
+      listing = guestfs_ls (g, directory);
+      if (listing == NULL)
+        croak ("ls: %s", last_error);
+      for (n = 0; listing[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (listing[i], 0)));
+        free (listing[i]);
+      }
+      free (listing);
+
+void
+list_devices (g)
+      guestfs_h *g;
+PREINIT:
+      char **devices;
+      int i, n;
+ PPCODE:
+      devices = guestfs_list_devices (g);
+      if (devices == NULL)
+        croak ("list_devices: %s", last_error);
+      for (n = 0; devices[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (devices[i], 0)));
+        free (devices[i]);
+      }
+      free (devices);
+
+void
+list_partitions (g)
+      guestfs_h *g;
+PREINIT:
+      char **partitions;
+      int i, n;
+ PPCODE:
+      partitions = guestfs_list_partitions (g);
+      if (partitions == NULL)
+        croak ("list_partitions: %s", last_error);
+      for (n = 0; partitions[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (partitions[i], 0)));
+        free (partitions[i]);
+      }
+      free (partitions);
+
+void
+pvs (g)
+      guestfs_h *g;
+PREINIT:
+      char **physvols;
+      int i, n;
+ PPCODE:
+      physvols = guestfs_pvs (g);
+      if (physvols == NULL)
+        croak ("pvs: %s", last_error);
+      for (n = 0; physvols[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (physvols[i], 0)));
+        free (physvols[i]);
+      }
+      free (physvols);
+
+void
+vgs (g)
+      guestfs_h *g;
+PREINIT:
+      char **volgroups;
+      int i, n;
+ PPCODE:
+      volgroups = guestfs_vgs (g);
+      if (volgroups == NULL)
+        croak ("vgs: %s", last_error);
+      for (n = 0; volgroups[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (volgroups[i], 0)));
+        free (volgroups[i]);
+      }
+      free (volgroups);
+
+void
+lvs (g)
+      guestfs_h *g;
+PREINIT:
+      char **logvols;
+      int i, n;
+ PPCODE:
+      logvols = guestfs_lvs (g);
+      if (logvols == NULL)
+        croak ("lvs: %s", last_error);
+      for (n = 0; logvols[n] != NULL; ++n) /**/;
+      EXTEND (SP, n);
+      for (i = 0; i < n; ++i) {
+        PUSHs (sv_2mortal (newSVpv (logvols[i], 0)));
+        free (logvols[i]);
+      }
+      free (logvols);
+
+void
+pvs_full (g)
+      guestfs_h *g;
+PREINIT:
+      struct guestfs_lvm_pv_list *physvols;
+      int i;
+      HV *hv;
+ PPCODE:
+      physvols = guestfs_pvs_full (g);
+      if (physvols == NULL)
+        croak ("pvs_full: %s", last_error);
+      EXTEND (SP, physvols->len);
+      for (i = 0; i < physvols->len; ++i) {
+        hv = newHV ();
+        (void) hv_store (hv, "pv_name", 7, newSVpv (physvols->val[i].pv_name, 0), 0);
+        (void) hv_store (hv, "pv_uuid", 7, newSVpv (physvols->val[i].pv_uuid, 32), 0);
+        (void) hv_store (hv, "pv_fmt", 6, newSVpv (physvols->val[i].pv_fmt, 0), 0);
+        (void) hv_store (hv, "pv_size", 7, my_newSVull (physvols->val[i].pv_size), 0);
+        (void) hv_store (hv, "dev_size", 8, my_newSVull (physvols->val[i].dev_size), 0);
+        (void) hv_store (hv, "pv_free", 7, my_newSVull (physvols->val[i].pv_free), 0);
+        (void) hv_store (hv, "pv_used", 7, my_newSVull (physvols->val[i].pv_used), 0);
+        (void) hv_store (hv, "pv_attr", 7, newSVpv (physvols->val[i].pv_attr, 0), 0);
+        (void) hv_store (hv, "pv_pe_count", 11, my_newSVll (physvols->val[i].pv_pe_count), 0);
+        (void) hv_store (hv, "pv_pe_alloc_count", 17, my_newSVll (physvols->val[i].pv_pe_alloc_count), 0);
+        (void) hv_store (hv, "pv_tags", 7, newSVpv (physvols->val[i].pv_tags, 0), 0);
+        (void) hv_store (hv, "pe_start", 8, my_newSVull (physvols->val[i].pe_start), 0);
+        (void) hv_store (hv, "pv_mda_count", 12, my_newSVll (physvols->val[i].pv_mda_count), 0);
+        (void) hv_store (hv, "pv_mda_free", 11, my_newSVull (physvols->val[i].pv_mda_free), 0);
+        PUSHs (sv_2mortal ((SV *) hv));
+      }
+      guestfs_free_lvm_pv_list (physvols);
+
+void
+vgs_full (g)
+      guestfs_h *g;
+PREINIT:
+      struct guestfs_lvm_vg_list *volgroups;
+      int i;
+      HV *hv;
+ PPCODE:
+      volgroups = guestfs_vgs_full (g);
+      if (volgroups == NULL)
+        croak ("vgs_full: %s", last_error);
+      EXTEND (SP, volgroups->len);
+      for (i = 0; i < volgroups->len; ++i) {
+        hv = newHV ();
+        (void) hv_store (hv, "vg_name", 7, newSVpv (volgroups->val[i].vg_name, 0), 0);
+        (void) hv_store (hv, "vg_uuid", 7, newSVpv (volgroups->val[i].vg_uuid, 32), 0);
+        (void) hv_store (hv, "vg_fmt", 6, newSVpv (volgroups->val[i].vg_fmt, 0), 0);
+        (void) hv_store (hv, "vg_attr", 7, newSVpv (volgroups->val[i].vg_attr, 0), 0);
+        (void) hv_store (hv, "vg_size", 7, my_newSVull (volgroups->val[i].vg_size), 0);
+        (void) hv_store (hv, "vg_free", 7, my_newSVull (volgroups->val[i].vg_free), 0);
+        (void) hv_store (hv, "vg_sysid", 8, newSVpv (volgroups->val[i].vg_sysid, 0), 0);
+        (void) hv_store (hv, "vg_extent_size", 14, my_newSVull (volgroups->val[i].vg_extent_size), 0);
+        (void) hv_store (hv, "vg_extent_count", 15, my_newSVll (volgroups->val[i].vg_extent_count), 0);
+        (void) hv_store (hv, "vg_free_count", 13, my_newSVll (volgroups->val[i].vg_free_count), 0);
+        (void) hv_store (hv, "max_lv", 6, my_newSVll (volgroups->val[i].max_lv), 0);
+        (void) hv_store (hv, "max_pv", 6, my_newSVll (volgroups->val[i].max_pv), 0);
+        (void) hv_store (hv, "pv_count", 8, my_newSVll (volgroups->val[i].pv_count), 0);
+        (void) hv_store (hv, "lv_count", 8, my_newSVll (volgroups->val[i].lv_count), 0);
+        (void) hv_store (hv, "snap_count", 10, my_newSVll (volgroups->val[i].snap_count), 0);
+        (void) hv_store (hv, "vg_seqno", 8, my_newSVll (volgroups->val[i].vg_seqno), 0);
+        (void) hv_store (hv, "vg_tags", 7, newSVpv (volgroups->val[i].vg_tags, 0), 0);
+        (void) hv_store (hv, "vg_mda_count", 12, my_newSVll (volgroups->val[i].vg_mda_count), 0);
+        (void) hv_store (hv, "vg_mda_free", 11, my_newSVull (volgroups->val[i].vg_mda_free), 0);
+        PUSHs (sv_2mortal ((SV *) hv));
+      }
+      guestfs_free_lvm_vg_list (volgroups);
+
+void
+lvs_full (g)
+      guestfs_h *g;
+PREINIT:
+      struct guestfs_lvm_lv_list *logvols;
+      int i;
+      HV *hv;
+ PPCODE:
+      logvols = guestfs_lvs_full (g);
+      if (logvols == NULL)
+        croak ("lvs_full: %s", last_error);
+      EXTEND (SP, logvols->len);
+      for (i = 0; i < logvols->len; ++i) {
+        hv = newHV ();
+        (void) hv_store (hv, "lv_name", 7, newSVpv (logvols->val[i].lv_name, 0), 0);
+        (void) hv_store (hv, "lv_uuid", 7, newSVpv (logvols->val[i].lv_uuid, 32), 0);
+        (void) hv_store (hv, "lv_attr", 7, newSVpv (logvols->val[i].lv_attr, 0), 0);
+        (void) hv_store (hv, "lv_major", 8, my_newSVll (logvols->val[i].lv_major), 0);
+        (void) hv_store (hv, "lv_minor", 8, my_newSVll (logvols->val[i].lv_minor), 0);
+        (void) hv_store (hv, "lv_kernel_major", 15, my_newSVll (logvols->val[i].lv_kernel_major), 0);
+        (void) hv_store (hv, "lv_kernel_minor", 15, my_newSVll (logvols->val[i].lv_kernel_minor), 0);
+        (void) hv_store (hv, "lv_size", 7, my_newSVull (logvols->val[i].lv_size), 0);
+        (void) hv_store (hv, "seg_count", 9, my_newSVll (logvols->val[i].seg_count), 0);
+        (void) hv_store (hv, "origin", 6, newSVpv (logvols->val[i].origin, 0), 0);
+        (void) hv_store (hv, "snap_percent", 12, newSVnv (logvols->val[i].snap_percent), 0);
+        (void) hv_store (hv, "copy_percent", 12, newSVnv (logvols->val[i].copy_percent), 0);
+        (void) hv_store (hv, "move_pv", 7, newSVpv (logvols->val[i].move_pv, 0), 0);
+        (void) hv_store (hv, "lv_tags", 7, newSVpv (logvols->val[i].lv_tags, 0), 0);
+        (void) hv_store (hv, "mirror_log", 10, newSVpv (logvols->val[i].mirror_log, 0), 0);
+        (void) hv_store (hv, "modules", 7, newSVpv (logvols->val[i].modules, 0), 0);
+        PUSHs (sv_2mortal ((SV *) hv));
+      }
+      guestfs_free_lvm_lv_list (logvols);
+
diff --git a/perl/Makefile.PL.in b/perl/Makefile.PL.in
new file mode 100644 (file)
index 0000000..423b4a1
--- /dev/null
@@ -0,0 +1,28 @@
+# 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.
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile (
+    FIRST_MAKEFILE => 'Makefile-pl',
+
+    NAME => 'Sys::Guestfs',
+    VERSION => '@PACKAGE_VERSION@',
+
+    LIBS => '-L@abs_top_builddir@/src/.libs -lguestfs',
+    INC => '-Wall @CFLAGS@ -I@abs_top_builddir@/src',
+    );
index 6b12064..ea9835b 100644 (file)
 # 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.
+
+EXTRA_DIST = \
+       Makefile.PL.in \
+       Guestfs.xs \
+       guestfs_perl.c \
+       typemap \
+       perl/lib/Sys/Guestfs.pm
+
+if HAVE_PERL
+
+# Interfacing automake and ExtUtils::MakeMaker known to be
+# a nightmare, news at 11.
+all:
+       perl Makefile.PL
+       make -f Makefile-pl
+
+install-data-hook:
+       make -f Makefile-pl DESTDIR=$(DESTDIR) install
+
+endif
diff --git a/perl/lib/Sys/Guestfs.pm b/perl/lib/Sys/Guestfs.pm
new file mode 100644 (file)
index 0000000..c0a9b79
--- /dev/null
@@ -0,0 +1,235 @@
+# libguestfs generated file
+# WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.
+# ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.
+#
+# 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
+
+=pod
+
+=head1 NAME
+
+Sys::Guestfs - Perl bindings for libguestfs
+
+=head1 SYNOPSIS
+
+ use Sys::Guestfs;
+ my $h = Sys::Guestfs->new ();
+ $h->add_drive ('guest.img');
+ $h->launch ();
+ $h->wait_ready ();
+ $h->mount ('/dev/sda1', '/');
+ $h->touch ('/hello');
+ $h->sync ();
+
+=head1 DESCRIPTION
+
+The C<Sys::Guestfs> module provides a Perl XS binding to the
+libguestfs API for examining and modifying virtual machine
+disk images.
+
+Amongst the things this is good for: making batch configuration
+changes to guests, getting disk used/free statistics (see also:
+virt-df), migrating between virtualization systems (see also:
+virt-p2v), performing partial backups, performing partial guest
+clones, cloning guests and changing registry/UUID/hostname info, and
+much else besides.
+
+Libguestfs uses Linux kernel and qemu code, and can access any type of
+guest filesystem that Linux and qemu can, including but not limited
+to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
+schemes, qcow, qcow2, vmdk.
+
+Libguestfs provides ways to enumerate guest storage (eg. partitions,
+LVs, what filesystem is in each LV, etc.).  It can also run commands
+in the context of the guest.  Also you can access filesystems over FTP.
+
+=head1 ERRORS
+
+All errors turn into calls to C<croak> (see L<Carp(3)>).
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Sys::Guestfs;
+
+use strict;
+use warnings;
+
+require XSLoader;
+XSLoader::load ('Sys::Guestfs');
+
+=item $h = Sys::Guestfs->new ();
+
+Create a new guestfs handle.
+
+=cut
+
+sub new {
+  my $proto = shift;
+  my $class = ref ($proto) || $proto;
+
+  my $self = Sys::Guestfs::_create ();
+  bless $self, $class;
+  return $self;
+}
+
+=item $content = $h->cat (path);
+
+Return the contents of the file named C<path>.
+
+Note that this function cannot correctly handle binary files
+(specifically, files containing C<\0> character which is treated
+as end of string).  For those you need to use the C<$h-E<gt>read_file>
+function which has a more complex interface.
+
+Because of the message protocol, there is a transfer limit 
+of somewhere between 2MB and 4MB.  To transfer large files you should use
+FTP.
+
+=item @devices = $h->list_devices ();
+
+List all the block devices.
+
+The full block device names are returned, eg. C</dev/sda>
+
+=item @partitions = $h->list_partitions ();
+
+List all the partitions detected on all block devices.
+
+The full partition device names are returned, eg. C</dev/sda1>
+
+This does not return logical volumes.  For that you will need to
+call C<$h-E<gt>lvs>.
+
+=item $listing = $h->ll (directory);
+
+List the files in C<directory> (relative to the root directory,
+there is no cwd) in the format of 'ls -la'.
+
+This command is mostly useful for interactive sessions.  It
+is I<not> intended that you try to parse the output string.
+
+=item @listing = $h->ls (directory);
+
+List the files in C<directory> (relative to the root directory,
+there is no cwd).  The '.' and '..' entries are not returned, but
+hidden files are shown.
+
+This command is mostly useful for interactive sessions.  Programs
+should probably use C<$h-E<gt>readdir> instead.
+
+=item @logvols = $h->lvs ();
+
+List all the logical volumes detected.  This is the equivalent
+of the L<lvs(8)> command.
+
+This returns a list of the logical volume device names
+(eg. C</dev/VolGroup00/LogVol00>).
+
+See also C<$h-E<gt>lvs_full>.
+
+=item @logvols = $h->lvs_full ();
+
+List all the logical volumes detected.  This is the equivalent
+of the L<lvs(8)> command.  The "full" version includes all fields.
+
+=item $h->mount (device, mountpoint);
+
+Mount a guest disk at a position in the filesystem.  Block devices
+are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
+the guest.  If those block devices contain partitions, they will have
+the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
+names can be used.
+
+The rules are the same as for L<mount(2)>:  A filesystem must
+first be mounted on C</> before others can be mounted.  Other
+filesystems can only be mounted on directories which already
+exist.
+
+The mounted filesystem is writable, if we have sufficient permissions
+on the underlying device.
+
+The filesystem options C<sync> and C<noatime> are set with this
+call, in order to improve reliability.
+
+=item @physvols = $h->pvs ();
+
+List all the physical volumes detected.  This is the equivalent
+of the L<pvs(8)> command.
+
+This returns a list of just the device names that contain
+PVs (eg. C</dev/sda2>).
+
+See also C<$h-E<gt>pvs_full>.
+
+=item @physvols = $h->pvs_full ();
+
+List all the physical volumes detected.  This is the equivalent
+of the L<pvs(8)> command.  The "full" version includes all fields.
+
+=item $h->sync ();
+
+This syncs the disk, so that any writes are flushed through to the
+underlying disk image.
+
+You should always call this if you have modified a disk image, before
+closing the handle.
+
+=item $h->touch (path);
+
+Touch acts like the L<touch(1)> command.  It can be used to
+update the timestamps on a file, or, if the file does not exist,
+to create a new zero-length file.
+
+=item @volgroups = $h->vgs ();
+
+List all the volumes groups detected.  This is the equivalent
+of the L<vgs(8)> command.
+
+This returns a list of just the volume group names that were
+detected (eg. C<VolGroup00>).
+
+See also C<$h-E<gt>vgs_full>.
+
+=item @volgroups = $h->vgs_full ();
+
+List all the volumes groups detected.  This is the equivalent
+of the L<vgs(8)> command.  The "full" version includes all fields.
+
+=cut
+
+1;
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (C) 2009 Red Hat Inc.
+
+=head1 LICENSE
+
+Please see the file COPYING.LIB for the full license.
+
+=head1 SEE ALSO
+
+L<guestfs(3)>, L<guestfish(1)>.
+
+=cut
diff --git a/perl/typemap b/perl/typemap
new file mode 100644 (file)
index 0000000..421e73a
--- /dev/null
@@ -0,0 +1,17 @@
+TYPEMAP
+char *         T_PV
+const char *   T_PV
+guestfs_h *    O_OBJECT_guestfs_h
+
+INPUT
+O_OBJECT_guestfs_h
+    if (sv_isobject ($arg) && SvTYPE (SvRV ($arg)) == SVt_PVMG)
+        $var = ($type) SvIV ((SV *) SvRV ($arg));
+    else {
+        warn (\"${Package}::$func_name(): $var is not a blessed SV reference\");
+       XSRETURN_UNDEF;
+    }
+
+OUTPUT
+O_OBJECT_guestfs_h
+    sv_setref_pv ($arg, "Sys::Guestfs", (void *) $var);
index 8f5471d..8b27798 100755 (executable)
@@ -51,6 +51,14 @@ and argt =
 
 type flags = ProtocolLimitWarning
 
+(* Note about long descriptions: When referring to another
+ * action, use the format C<guestfs_other> (ie. the full name of
+ * the C function).  This will be replaced as appropriate in other
+ * language bindings.
+ *
+ * Apart from that, long descriptions are just perldoc paragraphs.
+ *)
+
 let functions = [
   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
    "mount a guest disk at a position in the filesystem",
@@ -79,7 +87,7 @@ This syncs the disk, so that any writes are flushed through to the
 underlying disk image.
 
 You should always call this if you have modified a disk image, before
-calling C<guestfs_close>.");
+closing the handle.");
 
   ("touch", (Err, P1 (String "path")), 3, [],
    "update file timestamps or create a new file",
@@ -122,8 +130,7 @@ should probably use C<guestfs_readdir> instead.");
    "\
 List all the block devices.
 
-The full block device names are returned, eg. C</dev/sda>
-");
+The full block device names are returned, eg. C</dev/sda>");
 
   ("list_partitions", (RStringList "partitions", P0), 8, [],
    "list the partitions",
@@ -256,9 +263,13 @@ let lv_cols = [
 let sorted_functions =
   List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions
 
-(* Useful functions. *)
+(* Useful functions.
+ * Note we don't want to use any external OCaml libraries which
+ * makes this a bit harder than it should be.
+ *)
 let failwithf fs = ksprintf failwith fs
-let replace s c1 c2 =
+
+let replace_char s c1 c2 =
   let s2 = String.copy s in
   let r = ref false in
   for i = 0 to String.length s2 - 1 do
@@ -269,6 +280,36 @@ let replace s c1 c2 =
   done;
   if not !r then s else s2
 
+let rec find s sub =
+  let len = String.length s in
+  let sublen = String.length sub in
+  let rec loop i =
+    if i <= len-sublen then (
+      let rec loop2 j =
+       if j < sublen then (
+         if s.[i+j] = sub.[j] then loop2 (j+1)
+         else -1
+       ) else
+         i (* found *)
+      in
+      let r = loop2 0 in
+      if r = -1 then loop (i+1) else r
+    ) else
+      -1 (* not found *)
+  in
+  loop 0
+
+let rec replace_str s s1 s2 =
+  let len = String.length s in
+  let sublen = String.length s1 in
+  let i = find s s1 in
+  if i = -1 then s
+  else (
+    let s' = String.sub s 0 i in
+    let s'' = String.sub s (i+sublen) (len-i-sublen) in
+    s' ^ s2 ^ replace_str s'' s1 s2
+  )
+
 (* 'pr' prints to the current output file. *)
 let chan = ref stdout
 let pr fs = ksprintf (output_string !chan) fs
@@ -293,10 +334,12 @@ let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 (* Check function names etc. for consistency. *)
 let check_functions () =
   List.iter (
-    fun (name, _, _, _, _, _) ->
+    fun (name, _, _, _, _, longdesc) ->
       if String.contains name '-' then
        failwithf "Function name '%s' should not contain '-', use '_' instead."
-         name
+         name;
+      if longdesc.[String.length longdesc-1] = '\n' then
+       failwithf "Long description of %s should not end with \\n." name
   ) functions;
 
   let proc_nrs =
@@ -1071,7 +1114,7 @@ and generate_fish_cmds () =
   pr "  list_builtin_commands ();\n";
   List.iter (
     fun (name, _, _, _, shortdesc, _) ->
-      let name = replace name '_' '-' in
+      let name = replace_char name '_' '-' in
       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
        name shortdesc
   ) sorted_functions;
@@ -1084,7 +1127,8 @@ and generate_fish_cmds () =
   pr "{\n";
   List.iter (
     fun (name, style, _, flags, shortdesc, longdesc) ->
-      let name2 = replace name '_' '-' in
+      let name2 = replace_char name '_' '-' in
+      let longdesc = replace_str longdesc "C<guestfs_" "C<" in
       let synopsis =
        match snd style with
        | P0 -> name2
@@ -1232,7 +1276,7 @@ FTP."
   pr "{\n";
   List.iter (
     fun (name, _, _, _, _, _) ->
-      let name2 = replace name '_' '-' in
+      let name2 = replace_char name '_' '-' in
       pr "  if (";
       pr "strcasecmp (cmd, \"%s\") == 0" name;
       if name <> name2 then
@@ -1253,7 +1297,8 @@ FTP."
 and generate_fish_actions_pod () =
   List.iter (
     fun (name, style, _, _, _, longdesc) ->
-      let name = replace name '_' '-' in
+      let longdesc = replace_str longdesc "C<guestfs_" "C<" in
+      let name = replace_char name '_' '-' in
       pr "=head2 %s\n\n" name;
       pr " %s" name;
       iter_args (
@@ -1466,6 +1511,326 @@ and generate_ocaml_prototype ?(is_external = false) name style =
   if is_external then pr " = \"ocaml_guestfs_%s\"" name;
   pr "\n"
 
+(* Generate Perl xs code, a sort of crazy variation of C with macros. *)
+and generate_perl_xs () =
+  generate_header CStyle LGPLv2;
+
+  pr "\
+#include \"EXTERN.h\"
+#include \"perl.h\"
+#include \"XSUB.h\"
+
+#include <guestfs.h>
+
+#ifndef PRId64
+#define PRId64 \"lld\"
+#endif
+
+static SV *
+my_newSVll(long long val) {
+#ifdef USE_64_BIT_ALL
+  return newSViv(val);
+#else
+  char buf[100];
+  int len;
+  len = snprintf(buf, 100, \"%%\" PRId64, val);
+  return newSVpv(buf, len);
+#endif
+}
+
+#ifndef PRIu64
+#define PRIu64 \"llu\"
+#endif
+
+static SV *
+my_newSVull(unsigned long long val) {
+#ifdef USE_64_BIT_ALL
+  return newSVuv(val);
+#else
+  char buf[100];
+  int len;
+  len = snprintf(buf, 100, \"%%\" PRIu64, val);
+  return newSVpv(buf, len);
+#endif
+}
+
+/* XXX Not thread-safe, and in general not safe if the caller is
+ * issuing multiple requests in parallel (on different guestfs
+ * handles).  We should use the guestfs_h handle passed to the
+ * error handle to distinguish these cases.
+ */
+static char *last_error = NULL;
+
+static void
+error_handler (guestfs_h *g,
+              void *data,
+              const char *msg)
+{
+  if (last_error != NULL) free (last_error);
+  last_error = strdup (msg);
+}
+
+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
+
+void
+DESTROY (g)
+    guestfs_h *g;
+PPCODE:
+    guestfs_close (g);
+
+";
+
+  List.iter (
+    fun (name, style, _, _, _, _) ->
+      (match fst style with
+       | Err -> pr "void\n"
+       | RString _ -> pr "SV *\n"
+       | RStringList _
+       | RPVList _ | RVGList _ | RLVList _ ->
+          pr "void\n" (* all lists returned implictly on the stack *)
+      );
+      (* Call and arguments. *)
+      pr "%s " name;
+      generate_call_args ~handle:"g" style;
+      pr "\n";
+      pr "      guestfs_h *g;\n";
+      iter_args (
+       function
+       | String n -> pr "      char *%s;\n" n
+      ) (snd style);
+      (* Code. *)
+      (match fst style with
+       | Err ->
+          pr " PPCODE:\n";
+          pr "      if (guestfs_%s " name;
+          generate_call_args ~handle:"g" style;
+          pr " == -1)\n";
+          pr "        croak (\"%s: %%s\", last_error);\n" name
+       | RString n ->
+          pr "PREINIT:\n";
+          pr "      char *%s;\n" n;
+          pr "   CODE:\n";
+          pr "      %s = guestfs_%s " n name;
+          generate_call_args ~handle:"g" style;
+          pr ";\n";
+          pr "      if (%s == NULL)\n" n;
+          pr "        croak (\"%s: %%s\", last_error);\n" name;
+          pr "      RETVAL = newSVpv (%s, 0);\n" n;
+          pr "      free (%s);\n" n;
+          pr " OUTPUT:\n";
+          pr "      RETVAL\n"
+       | RStringList n ->
+          pr "PREINIT:\n";
+          pr "      char **%s;\n" n;
+          pr "      int i, n;\n";
+          pr " PPCODE:\n";
+          pr "      %s = guestfs_%s " n name;
+          generate_call_args ~handle:"g" style;
+          pr ";\n";
+          pr "      if (%s == NULL)\n" n;
+          pr "        croak (\"%s: %%s\", last_error);\n" name;
+          pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
+          pr "      EXTEND (SP, n);\n";
+          pr "      for (i = 0; i < n; ++i) {\n";
+          pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
+          pr "        free (%s[i]);\n" n;
+          pr "      }\n";
+          pr "      free (%s);\n" n;
+       | RPVList n ->
+          generate_perl_lvm_code "pv" pv_cols name style n;
+       | RVGList n ->
+          generate_perl_lvm_code "vg" vg_cols name style n;
+       | RLVList n ->
+          generate_perl_lvm_code "lv" lv_cols name style n;
+      );
+      pr "\n"
+  ) functions
+
+and generate_perl_lvm_code typ cols name style n =
+  pr "PREINIT:\n";
+  pr "      struct guestfs_lvm_%s_list *%s;\n" typ n;
+  pr "      int i;\n";
+  pr "      HV *hv;\n";
+  pr " PPCODE:\n";
+  pr "      %s = guestfs_%s " n name;
+  generate_call_args ~handle:"g" style;
+  pr ";\n";
+  pr "      if (%s == NULL)\n" n;
+  pr "        croak (\"%s: %%s\", last_error);\n" name;
+  pr "      EXTEND (SP, %s->len);\n" n;
+  pr "      for (i = 0; i < %s->len; ++i) {\n" n;
+  pr "        hv = newHV ();\n";
+  List.iter (
+    function
+    | name, `String ->
+       pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
+         name (String.length name) n name
+    | name, `UUID ->
+       pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
+         name (String.length name) n name
+    | name, `Bytes ->
+       pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
+         name (String.length name) n name
+    | name, `Int ->
+       pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
+         name (String.length name) n name
+    | name, `OptPercent ->
+       pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
+         name (String.length name) n name
+  ) cols;
+  pr "        PUSHs (sv_2mortal ((SV *) hv));\n";
+  pr "      }\n";
+  pr "      guestfs_free_lvm_%s_list (%s);\n" typ n
+
+(* Generate Sys/Guestfs.pm. *)
+and generate_perl_pm () =
+  generate_header HashStyle LGPLv2;
+
+  pr "\
+=pod
+
+=head1 NAME
+
+Sys::Guestfs - Perl bindings for libguestfs
+
+=head1 SYNOPSIS
+
+ use Sys::Guestfs;
+ my $h = Sys::Guestfs->new ();
+ $h->add_drive ('guest.img');
+ $h->launch ();
+ $h->wait_ready ();
+ $h->mount ('/dev/sda1', '/');
+ $h->touch ('/hello');
+ $h->sync ();
+
+=head1 DESCRIPTION
+
+The C<Sys::Guestfs> module provides a Perl XS binding to the
+libguestfs API for examining and modifying virtual machine
+disk images.
+
+Amongst the things this is good for: making batch configuration
+changes to guests, getting disk used/free statistics (see also:
+virt-df), migrating between virtualization systems (see also:
+virt-p2v), performing partial backups, performing partial guest
+clones, cloning guests and changing registry/UUID/hostname info, and
+much else besides.
+
+Libguestfs uses Linux kernel and qemu code, and can access any type of
+guest filesystem that Linux and qemu can, including but not limited
+to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
+schemes, qcow, qcow2, vmdk.
+
+Libguestfs provides ways to enumerate guest storage (eg. partitions,
+LVs, what filesystem is in each LV, etc.).  It can also run commands
+in the context of the guest.  Also you can access filesystems over FTP.
+
+=head1 ERRORS
+
+All errors turn into calls to C<croak> (see L<Carp(3)>).
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Sys::Guestfs;
+
+use strict;
+use warnings;
+
+require XSLoader;
+XSLoader::load ('Sys::Guestfs');
+
+=item $h = Sys::Guestfs->new ();
+
+Create a new guestfs handle.
+
+=cut
+
+sub new {
+  my $proto = shift;
+  my $class = ref ($proto) || $proto;
+
+  my $self = Sys::Guestfs::_create ();
+  bless $self, $class;
+  return $self;
+}
+
+";
+
+  (* Actions.  We only need to print documentation for these as
+   * they are pulled in from the XS code automatically.
+   *)
+  List.iter (
+    fun (name, style, _, flags, _, longdesc) ->
+      let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
+      pr "=item ";
+      generate_perl_prototype name style;
+      pr "\n\n";
+      pr "%s\n\n" longdesc;
+      if List.mem ProtocolLimitWarning flags then
+       pr "Because of the message protocol, there is a transfer limit 
+of somewhere between 2MB and 4MB.  To transfer large files you should use
+FTP.\n\n";
+  ) sorted_functions;
+
+  (* End of file. *)
+  pr "\
+=cut
+
+1;
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (C) 2009 Red Hat Inc.
+
+=head1 LICENSE
+
+Please see the file COPYING.LIB for the full license.
+
+=head1 SEE ALSO
+
+L<guestfs(3)>, L<guestfish(1)>.
+
+=cut
+"
+
+and generate_perl_prototype name style =
+  (match fst style with
+   | Err -> ()
+   | RString n -> pr "$%s = " n
+   | RStringList n
+   | RPVList n
+   | RVGList n
+   | RLVList n -> pr "@%s = " n
+  );
+  pr "$h->%s (" name;
+  let comma = ref false in
+  iter_args (
+    fun arg ->
+      if !comma then pr ", ";
+      comma := true;
+      match arg with
+      | String n -> pr "%s" n
+  ) (snd style);
+  pr ");"
+
 let output_to filename =
   let filename_new = filename ^ ".new" in
   chan := open_out filename_new;
@@ -1532,3 +1897,11 @@ let () =
   let close = output_to "ocaml/guestfs_c_actions.c" in
   generate_ocaml_c ();
   close ();
+
+  let close = output_to "perl/Guestfs.xs" in
+  generate_perl_xs ();
+  close ();
+
+  let close = output_to "perl/lib/Sys/Guestfs.pm" in
+  generate_perl_pm ();
+  close ();