mirrors/libguestfs
1
0
Fork 0
mirror of https://github.com/libguestfs/libguestfs.git synced 2026-03-21 22:53:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

First version of Perl bindings, compiled but not tested.

Browse Source
This commit is contained in:
Richard Jones
2009-04-08 13:44:13 +01:00
parent 8dcc88f867
commit 1ee6da96ef
8 changed files with 1051 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View 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

2
configure.ac
View 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?

361
perl/Guestfs.xs Normal file
View File

@@ -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);

28
perl/Makefile.PL.in Normal file
View File

@@ -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',
);

20
perl/Makefile.am
View File

@@ -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

235
perl/lib/Sys/Guestfs.pm Normal file
View File

@@ -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

17
perl/typemap Normal file
View File

@@ -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);

395
src/generator.ml
View File

@@ -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 ();