From: Richard Jones Date: Wed, 8 Apr 2009 12:44:13 +0000 (+0100) Subject: First version of Perl bindings, compiled but not tested. X-Git-Tag: 0.5~9 X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=1ee6da96efe8340a7d3904a865d80cd59d9d3fde;p=libguestfs.git First version of Perl bindings, compiled but not tested. --- diff --git a/.gitignore b/.gitignore index 63ec1f6..6772ac2 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/configure.ac b/configure.ac index 1359cb0..29ab3ce 100644 --- a/configure.ac +++ b/configure.ac @@ -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 index 0000000..e3f17c2 --- /dev/null +++ b/perl/Guestfs.xs @@ -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 + +/* #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 index 0000000..423b4a1 --- /dev/null +++ b/perl/Makefile.PL.in @@ -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', + ); diff --git a/perl/Makefile.am b/perl/Makefile.am index 6b12064..ea9835b 100644 --- a/perl/Makefile.am +++ b/perl/Makefile.am @@ -14,3 +14,23 @@ # 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 index 0000000..c0a9b79 --- /dev/null +++ b/perl/lib/Sys/Guestfs.pm @@ -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 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 (see L). + +=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. + +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-Eread_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 + +=item @partitions = $h->list_partitions (); + +List all the partitions detected on all block devices. + +The full partition device names are returned, eg. C + +This does not return logical volumes. For that you will need to +call C<$h-Elvs>. + +=item $listing = $h->ll (directory); + +List the files in C (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 intended that you try to parse the output string. + +=item @listing = $h->ls (directory); + +List the files in C (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-Ereaddir> instead. + +=item @logvols = $h->lvs (); + +List all the logical volumes detected. This is the equivalent +of the L command. + +This returns a list of the logical volume device names +(eg. C). + +See also C<$h-Elvs_full>. + +=item @logvols = $h->lvs_full (); + +List all the logical volumes detected. This is the equivalent +of the L 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, C and so on, as they were added to +the guest. If those block devices contain partitions, they will have +the usual names (eg. C). Also LVM C-style +names can be used. + +The rules are the same as for L: 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 and C 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 command. + +This returns a list of just the device names that contain +PVs (eg. C). + +See also C<$h-Epvs_full>. + +=item @physvols = $h->pvs_full (); + +List all the physical volumes detected. This is the equivalent +of the L 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 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 command. + +This returns a list of just the volume group names that were +detected (eg. C). + +See also C<$h-Evgs_full>. + +=item @volgroups = $h->vgs_full (); + +List all the volumes groups detected. This is the equivalent +of the L 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, L. + +=cut diff --git a/perl/typemap b/perl/typemap new file mode 100644 index 0000000..421e73a --- /dev/null +++ b/perl/typemap @@ -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); diff --git a/src/generator.ml b/src/generator.ml index 8f5471d..8b27798 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -51,6 +51,14 @@ and argt = type flags = ProtocolLimitWarning +(* Note about long descriptions: When referring to another + * action, use the format C (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."); +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 instead."); "\ List all the block devices. -The full block device names are returned, eg. C -"); +The full block device names are returned, eg. C"); ("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 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 + +#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 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 (see L). + +=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" 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, L. + +=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 ();