From 6edf6b4e261011342c40e871231d8430db31f490 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 6 Feb 2014 13:42:38 +0000 Subject: [PATCH] perl: New plugin lets you write plugins as Perl scripts. --- README | 2 + TODO | 11 +- configure.ac | 46 ++- plugins/Makefile.am | 3 +- plugins/{ => perl}/Makefile.am | 48 ++- plugins/perl/example.pl | 70 ++++ plugins/perl/nbdkit-perl-plugin.pod | 350 ++++++++++++++++++++ plugins/perl/perl.c | 619 ++++++++++++++++++++++++++++++++++++ 8 files changed, 1132 insertions(+), 17 deletions(-) copy plugins/{ => perl}/Makefile.am (65%) create mode 100644 plugins/perl/example.pl create mode 100644 plugins/perl/nbdkit-perl-plugin.pod create mode 100644 plugins/perl/perl.c diff --git a/README b/README index 8c2041c0..c5d76dfd 100644 --- a/README +++ b/README @@ -33,6 +33,8 @@ for the plugins: - pod2man (from perl): to build the manual pages + - perl development libraries: to build the embedded perl plugin + - zlib: to build the gzip plugin - liblzma: to build the xz plugin diff --git a/TODO b/TODO index fa747b7f..6141f0ba 100644 --- a/TODO +++ b/TODO @@ -1,11 +1,14 @@ +* Can we do language bindings using #!'s? + You would enter: + nbdkit foo [args] + where nbdkit-foo-plugin is a Perl script starting: + #!perl + which causes nbdkit to load the perl plugin wrapper. + * syslog? journal? * An easy way to run nbdkit captive under libguestfs. -* Language bindings. It should be possible to write plugins in other - languages apart from C: - nbdkit perl =/path/to/script.pl [other parameters ...] - * Glance and/or cinder plugins. * Performance - measure and improve it. diff --git a/configure.ac b/configure.ac index dc4c0d45..d8e9d0bc 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ # nbdkit -# Copyright (C) 2013 Red Hat Inc. +# Copyright (C) 2013-2014 Red Hat Inc. # All rights reserved. # # Redistribution and use in source and binary forms, with or without @@ -112,6 +112,49 @@ dnl Check for Perl POD. AC_CHECK_PROG([POD2MAN], [pod2man], [pod2man], [no]) AM_CONDITIONAL([HAVE_POD2MAN], [test "x$POD2MAN" != "xno"]) +dnl Check for Perl, for embedding in the perl plugin. +AC_CHECK_PROG([PERL],[perl],[perl],[no]) +AC_ARG_ENABLE([perl], + AS_HELP_STRING([--disable-perl], [disable Perl embed plugin]), + [], + [enable_perl=yes]) +AS_IF([test "x$PERL" != "xno" && test "x$enable_perl" != "xno"],[ + dnl Check for Perl archlib. + AC_MSG_CHECKING([for Perl embed archlib]) + PERL_ARCHLIB="$($PERL -MConfig -e 'print $Config{archlib}')" + AS_IF([ test -n "$PERL_ARCHLIB" ],[ + AC_MSG_RESULT([$PERL_ARCHLIB]) + ],[ + AC_MSG_NOTICE([Perl embed module disabled]) + enable_perl=no + ]) + + dnl Check for Perl CFLAGS. + AC_MSG_CHECKING([for Perl embed CFLAGS]) + PERL_CFLAGS="$($PERL -MConfig -e 'print $Config{ccflags}')" + AS_IF([ test -n "$PERL_CFLAGS" ],[ + AC_MSG_RESULT([$PERL_CFLAGS]) + ],[ + AC_MSG_NOTICE([Perl embed module disabled]) + enable_perl=no + ]) + + dnl Check for Perl LIBS. + AC_MSG_CHECKING([for Perl embed LIBS]) + PERL_LIBS="$($PERL -MConfig -e 'print $Config{libs}')" + + dnl Check for Perl LDFLAGS. + AC_MSG_CHECKING([for Perl embed LDFLAGS]) + PERL_LDFLAGS="$($PERL -MConfig -e 'print $Config{ldflags}')" + + dnl XXX Could check these actually work. +]) +AM_CONDITIONAL([HAVE_PERL],[test "x$enable_perl" != "xno" && test "x$PERL" != "xno"]) +AC_SUBST([PERL_ARCHLIB]) +AC_SUBST([PERL_CFLAGS]) +AC_SUBST([PERL_LIBS]) +AC_SUBST([PERL_LDFLAGS]) + dnl Check for libvirt (only if you want to compile the libvirt plugin). AC_ARG_WITH([libvirt],[ AS_HELP_STRING([--without-libvirt], @@ -220,6 +263,7 @@ AC_CONFIG_FILES([Makefile plugins/guestfs/Makefile plugins/gzip/Makefile plugins/libvirt/Makefile + plugins/perl/Makefile plugins/vddk/Makefile plugins/xz/Makefile src/Makefile diff --git a/plugins/Makefile.am b/plugins/Makefile.am index b38cba83..64c668ce 100644 --- a/plugins/Makefile.am +++ b/plugins/Makefile.am @@ -1,5 +1,5 @@ # nbdkit -# Copyright (C) 2013 Red Hat Inc. +# Copyright (C) 2013-2014 Red Hat Inc. # All rights reserved. # # Redistribution and use in source and binary forms, with or without @@ -38,5 +38,6 @@ SUBDIRS = \ guestfs \ gzip \ libvirt \ + perl \ vddk \ xz diff --git a/plugins/Makefile.am b/plugins/perl/Makefile.am similarity index 65% copy from plugins/Makefile.am copy to plugins/perl/Makefile.am index b38cba83..72817fd2 100644 --- a/plugins/Makefile.am +++ b/plugins/perl/Makefile.am @@ -1,5 +1,5 @@ # nbdkit -# Copyright (C) 2013 Red Hat Inc. +# Copyright (C) 2013-2014 Red Hat Inc. # All rights reserved. # # Redistribution and use in source and binary forms, with or without @@ -30,13 +30,39 @@ # OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. -SUBDIRS = \ - example1 \ - example2 \ - example3 \ - file \ - guestfs \ - gzip \ - libvirt \ - vddk \ - xz +EXTRA_DIST = nbdkit-perl-plugin.pod + +plugindir = $(libdir)/nbdkit/plugins + +if HAVE_PERL + +plugin_LTLIBRARIES = nbdkit-perl-plugin.la + +nbdkit_perl_plugin_la_SOURCES = \ + perl.c \ + $(top_srcdir)/include/nbdkit-plugin.h + +nbdkit_perl_plugin_la_CPPFLAGS = \ + -I$(top_srcdir)/include +nbdkit_perl_plugin_la_CFLAGS = \ + $(WARNINGS_CFLAGS) \ + $(PERL_CFLAGS) \ + -I$(PERL_ARCHLIB)/CORE +nbdkit_perl_plugin_la_LIBADD = \ + -lperl $(PERL_LIBS) +nbdkit_perl_plugin_la_LDFLAGS = \ + -module -avoid-version -shared \ + $(PERL_LDFLAGS) + +if HAVE_POD2MAN + +man_MANS = nbdkit-perl-plugin.1 + +nbdkit-perl-plugin.1: nbdkit-perl-plugin.pod + $(POD2MAN) -u --stderr --section=1 --center=nbdkit --release=nbdkit --name=`basename $@` $< $@ + +endif + +endif + +CLEANFILES = *~ diff --git a/plugins/perl/example.pl b/plugins/perl/example.pl new file mode 100644 index 00000000..7b90e853 --- /dev/null +++ b/plugins/perl/example.pl @@ -0,0 +1,70 @@ +use strict; + +# Example Perl plugin. +# +# This example can be freely used for any purpose. + +# Run it from the build directory like this: +# +# ./src/nbdkit -f -v ./plugins/perl/.libs/nbdkit-perl-plugin.so \ +# script=./plugins/perl/example.pl test1=foo test2=bar +# +# You can connect to the server using guestfish or qemu: +# +# guestfish --format=raw -a nbd://localhost run + +# This is the string used to store the emulated disk (initially all +# zero bytes). There is one disk per nbdkit instance. You could also +# put this into the handle, so there would be a fresh disk per handle. +my $disk = "\0" x (1024*1024); + +# This just prints the extra command line parameters, but real plugins +# should parse them and reject any unknown parameters. +sub config +{ + my $key = shift; + my $value = shift; + + print "$0: ignored parameter $key=$value\n"; +} + +sub open +{ + my $readonly = shift; + + printf ("$0: open: readonly=%d\n", $readonly); + + # You can return any Perl value from open, and the same Perl value + # will be passed as the first arg to the other callbacks [in the + # client connected phase]. In most cases it's convenient to use a + # hashref. + my $h = { readonly => $readonly }; + + return $h; +} + +sub get_size +{ + my $h = shift; + + return length ($disk); +} + +sub pread +{ + my $h = shift; + my $count = shift; + my $offset = shift; + + return substr ($disk, $offset, $count); +} + +sub pwrite +{ + my $h = shift; + my $buf = shift; + my $count = length ($buf); + my $offset = shift; + + substr ($disk, $offset, $count) = $buf; +} diff --git a/plugins/perl/nbdkit-perl-plugin.pod b/plugins/perl/nbdkit-perl-plugin.pod new file mode 100644 index 00000000..6a0c051d --- /dev/null +++ b/plugins/perl/nbdkit-perl-plugin.pod @@ -0,0 +1,350 @@ +=encoding utf8 + +=head1 NAME + +nbdkit-perl-plugin - nbdkit perl plugin + +=head1 SYNOPSIS + + nbdkit perl script=/path/to/plugin.pl [arguments...] + +=head1 DESCRIPTION + +C is an embedded Perl interpreter for L, +allowing you to write nbdkit plugins in Perl. + +Broadly speaking, Perl nbdkit plugins work like C ones, so you should +probably read L first. + +=head2 USING A PERL NBDKIT PLUGIN + +Assuming you have a Perl script which is an nbdkit plugin, you run it +like this: + + nbdkit perl script=/path/to/plugin.pl + +You may have to add further key=value arguments to the command line. +Read the Perl script to see if it requires any. C I +come first on the command line. + +=head1 WRITING A PERL NBDKIT PLUGIN + +There is an example Perl nbdkit plugin called C which +ships with the nbdkit source. + +To write a Perl nbdkit plugin, you create a Perl file which contains +at least the following required subroutines: + + sub open + { + # see below + } + sub get_size + { + # see below + } + sub pread + { + # see below + } + +Note that the subroutines must have those literal names (like +C), because the C part looks up and calls those functions +directly. You may want to include documentation and globals (eg. for +storing global state). Also any top-level statements, C +statements, C statements and so on are run when nbdkit starts up +and shuts down, just like ordinary Perl. + +The file does I need to include a C<#!> (hash-bang) at the top, +and does I need to be executable. In fact it's a good idea +I to do that, because running the plugin directly as a Perl +script won't work. + +=head2 EXCEPTIONS + +Instead of returning error codes, as in C, Perl callbacks should +indicate problems by throwing Perl exceptions (ie. C, C +etc). The Perl error message is captured and printed by nbdkit. + +=head2 32 vs 64 BIT + +It is likely that Perl plugins won't work well, or maybe won't work at +all, on 32 bit platforms. This is simply because Perl doesn't have an +easy way to use 64 bit integers on 32 bit platforms, and 64 bit +integers (eg. file offsets, disk sizes) are required for many nbdkit +operations. + +=head2 PERL CALLBACKS + +This just documents the arguments to the callbacks in Perl, and any +way that they differ from the C callbacks. In all other respects they +work the same way as the C callbacks, so you should go and read +L. + +=over 4 + +=item C + +(Optional) + + sub config + { + my $key = shift; + my $value = shift; + # No return value. + } + +=item C + +(Optional) + +There are no arguments or return value. + +=item C + +(Required) + + sub open + { + my $readonly = shift; + my $handle = {}; + return $handle; + } + +The C flag is a boolean. + +You can return any Perl value as the handle. It is passed back to +subsequent calls. It's usually convenient to use a hashref, since +that lets you store arbitrary fields. + +=item C + +(Optional) + + sub close + { + my $handle = shift; + # No return value + } + +After C returns, the reference count of the handle is +decremented in the C part, which usually means that the handle and its +contents will be garbage collected. + +=item C + +(Required) + + sub get_size + { + my $handle = shift; + my $i64 = .. the size of the disk ..; + return $i64; + } + +This returns the size of the disk. You can return any Perl object +that evaluates to an integer. + +=item C + +(Optional) + + sub can_write + { + my $handle = shift; + my $bool = ...; + return $bool; + } + +Return a boolean indicating whether the disk is writable. + +=item C + +(Optional) + + sub can_flush + { + my $handle = shift; + my $bool = ...; + return $bool; + } + +Return a boolean indicating whether flush can be performed. + +=item C + +(Optional) + + sub is_rotational + { + my $handle = shift; + my $bool = ...; + return $bool; + } + +Return a boolean indicating whether the disk is rotational. + +=item C + +(Optional) + + sub can_trim + { + my $handle = shift; + my $bool = ...; + return $bool; + } + +Return a boolean indicating whether trim/discard can be performed. + +=item C + +(Required) + + sub pread + { + my $handle = shift; + my $count = shift; + my $offset = shift; + # Construct a buffer of length $count bytes and return it. + return $buf; + } + +The body of your C function should construct a buffer of length +(at least) C<$count> bytes. You should read C<$count> bytes from the +disk starting at C<$offset>. + +NBD only supports whole reads, so your function should try to read the +whole region (perhaps requiring a loop). If the read fails or is +partial, your function should C. + +=item C + +(Optional) + + sub pwrite + { + my $handle = shift; + my $buf = shift; + my $count = length ($buf); + my $offset = shift; + # No return value + } + +The body of your C function should write the C<$buf> string to +the disk. You should write C<$count> bytes to the disk starting at +C<$offset>. + +NBD only supports whole writes, so your function should try to write +the whole region (perhaps requiring a loop). If the write fails or is +partial, your function should C. + +=item C + +(Optional) + + sub flush + { + my $handle = shift; + # No return value + } + +The body of your C function should do a L or +L or equivalent on the backing store. + +If there is an error, the function should call C. + +=item C + +(Optional) + + sub flush + { + my $handle = shift; + my $count = shift; + my $offset = shift; + # No return value + } + +The body of your C function should "punch a hole" in the backing +store. + +If there is an error, the function should call C. + +=back + +=head2 MISSING CALLBACKS + +=over 4 + +=item Missing: C and C + +These are not needed because you can just use regular Perl C +and C constructs. + +=item Missing: C, C, C, C, C + +These are not yet supported. + +=back + +=head2 THREADS + +The thread model for Perl callbacks currently cannot be set from Perl. +It is hard-coded in the C part to +C. This may change or be +settable in future. + +=head1 SEE ALSO + +L, +L, +L. + +=head1 AUTHORS + +Richard W.M. Jones + +=head1 COPYRIGHT + +Copyright (C) 2013-2014 Red Hat Inc. + +=head1 LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +=over 4 + +=item * + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +=item * + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +=item * + +Neither the name of Red Hat nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +=back + +THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/plugins/perl/perl.c b/plugins/perl/perl.c new file mode 100644 index 00000000..935e1ba8 --- /dev/null +++ b/plugins/perl/perl.c @@ -0,0 +1,619 @@ +/* nbdkit + * Copyright (C) 2013-2014 Red Hat Inc. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * * Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * * Neither the name of Red Hat nor the names of its contributors may be + * used to endorse or promote products derived from this software without + * specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, + * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR + * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF + * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND + * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT + * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +#include + +static PerlInterpreter *my_perl; +static const char *script; + +static void +perl_load (void) +{ + int argc = 1; + const char *argv[2] = { "nbdkit", NULL }; + + /* Full Perl interpreter initialization is deferred until we read + * the first config parameter (which MUST be "script"). + */ + PERL_SYS_INIT3 (&argc, (char ***) &argv, &environ); + my_perl = perl_alloc (); + if (!my_perl) { + nbdkit_error ("out of memory allocating Perl interpreter"); + exit (EXIT_FAILURE); + } + perl_construct (my_perl); +} + +static void +perl_unload (void) +{ + if (my_perl != NULL) { + perl_destruct (my_perl); + perl_free (my_perl); + PERL_SYS_TERM (); + } +} + +/* We use this function to test if the named callback is defined + * in the loaded Perl code. + * + * There is a subtle nbdkit problem here. Because we don't load the + * script until the configuration phase, we don't know until too late + * which callbacks are defined in Perl. Therefore we cannot set the + * .plugin fields to NULL appropriately (also because nbdkit copies + * that struct, we cannot modify the struct after the module is + * loaded). So what we have to do is copy the default behaviour of + * nbdkit for missing Perl callbacks. + */ +static int +callback_defined (const char *perl_func_name) +{ + SV *ret; + char *cmd; + + if (asprintf (&cmd, "defined &%s", perl_func_name) == -1) { + perror ("asprintf"); + exit (EXIT_FAILURE); + } + + ret = eval_pv (cmd, FALSE); + free (cmd); + + return SvTRUE (ret); +} + +/* Check for a Perl exception, and convert it to an nbdkit error. */ +static int +check_perl_failure (void) +{ + SV *errsv = get_sv ("@", TRUE); + + if (SvTRUE (errsv)) { + const char *err; + STRLEN n; + char *err_copy; + + err = SvPV (errsv, n); + + /* Need to chop off the final \n if there is one. The only way to + * do this is to copy the string. + */ + err_copy = strndup (err, n); + if (err_copy == NULL) { + nbdkit_error ("malloc failure: original error: %s", err); + return -1; + } + if (n > 0 && err_copy[n-1] == '\n') + err_copy[n-1] = '\0'; + + nbdkit_error ("%s", err_copy); + free (err_copy); + + return -1; + } + + return 0; +} + +static int +perl_config (const char *key, const char *value) +{ + if (!script) { + int argc = 2; + char *argv[3] = { "nbdkit", NULL, NULL }; + + /* The first parameter MUST be "script". */ + if (strcmp (key, "script") != 0) { + nbdkit_error ("the first parameter must be script=/path/to/perl/script.pl"); + return -1; + } + script = value; + + assert (my_perl); + + /* Load the Perl script. */ + argv[1] = (char *) script; + if (perl_parse (my_perl, NULL, argc, argv, NULL) == -1) { + nbdkit_error ("%s: error parsing this script", script); + return -1; + } + + /* Run the Perl script. Note that top-level definitions such as + * global variables don't work at all unless you do this. + */ + if (perl_run (my_perl) == -1) { + nbdkit_error ("%s: error running this script", script); + return -1; + } + + /* Minimal set of callbacks which are required (by nbdkit itself). */ + if (!callback_defined ("open") || + !callback_defined ("get_size") || + !callback_defined ("pread")) { + nbdkit_error ("%s: one of the required callbacks 'open', 'get_size' or 'pread' is not defined by this Perl script. nbdkit requires these callbacks.", script); + return -1; + } + } + else if (callback_defined ("config")) { + dSP; + + /* Other parameters are passed to the Perl .config callback. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (sv_2mortal (newSVpv (key, strlen (key)))); + XPUSHs (sv_2mortal (newSVpv (value, strlen (value)))); + PUTBACK; + call_pv ("config", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + } + else { + /* Emulate what core nbdkit does if a config callback is NULL. */ + nbdkit_error ("%s: this plugin does not need command line configuration", + script); + return -1; + } + + return 0; +} + +static int +perl_config_complete (void) +{ + dSP; + + if (callback_defined ("config_complete")) { + ENTER; + SAVETMPS; + PUSHMARK (SP); + PUTBACK; + call_pv ("config_complete", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + if (check_perl_failure () == -1) + return -1; + } + + return 0; +} + +static void * +perl_open (int readonly) +{ + SV *sv; + dSP; + + /* We check in perl_config that this callback is defined. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (readonly ? &PL_sv_yes : &PL_sv_no); + PUTBACK; + call_pv ("open", G_EVAL|G_SCALAR); + SPAGAIN; + sv = newSVsv (POPs); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return NULL; + + nbdkit_debug ("open returns handle (SV *) = %p (type %d)", + sv, SvTYPE (sv)); + + return sv; +} + +static void +perl_close (void *handle) +{ + dSP; + + nbdkit_debug ("close called with handle (SV *) = %p (type %d)", + handle, SvTYPE ((SV *) handle)); + + if (callback_defined ("close")) { + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("close", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + + check_perl_failure (); /* ignore return value */ + } + + /* Since nbdkit has closed (and forgotten) the handle, we can now + * drop its refcount. + */ + SvREFCNT_dec ((SV *) handle); +} + +static int64_t +perl_get_size (void *handle) +{ + dSP; + SV *sv; + int64_t size; + + /* We check in perl_config that this callback is defined. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("get_size", G_EVAL|G_SCALAR); + SPAGAIN; + /* For some reason, this only works if split into two separate statements: */ + sv = POPs; + size = SvIV (sv); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + nbdkit_debug ("get_size returned %" PRIi64, size); + + return size; +} + +static int +perl_pread (void *handle, void *buf, + uint32_t count, uint64_t offset) +{ + dSP; + SV *sv; + const char *pbuf; + STRLEN len; + int ret = 0; + + /* We check in perl_config that this callback is defined. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + XPUSHs (sv_2mortal (newSViv (count))); + XPUSHs (sv_2mortal (newSViv (offset))); + PUTBACK; + call_pv ("pread", G_EVAL|G_SCALAR); + SPAGAIN; + sv = POPs; + pbuf = SvPV (sv, len); + if (len < count) { + nbdkit_error ("buffer returned from pread is too small"); + ret = -1; + } + else + memcpy (buf, pbuf, count); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + ret = -1; + + return ret; +} + +static int +perl_pwrite (void *handle, const void *buf, + uint32_t count, uint64_t offset) +{ + dSP; + + if (callback_defined ("pwrite")) { + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + XPUSHs (sv_2mortal (newSVpv (buf, count))); + XPUSHs (sv_2mortal (newSViv (offset))); + PUTBACK; + call_pv ("pwrite", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return 0; + } + + nbdkit_error ("write not implemented"); + return -1; +} + +static int +perl_can_write (void *handle) +{ + dSP; + SV *sv; + int r; + + if (callback_defined ("can_write")) { + /* If there's a Perl callback, call it. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("can_write", G_EVAL|G_SCALAR); + SPAGAIN; + sv = POPs; + r = SvIV (sv); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return r; + } + /* No Perl can_write callback, but there's a Perl pwrite callback + * defined, so return 1. (In C modules, nbdkit would do this). + */ + else if (callback_defined ("pwrite")) + return 1; + else + return 0; +} + +static int +perl_can_flush (void *handle) +{ + dSP; + SV *sv; + int r; + + if (callback_defined ("can_flush")) { + /* If there's a Perl callback, call it. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("can_flush", G_EVAL|G_SCALAR); + SPAGAIN; + sv = POPs; + r = SvIV (sv); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return r; + } + /* No Perl can_flush callback, but there's a Perl flush callback + * defined, so return 1. (In C modules, nbdkit would do this). + */ + else if (callback_defined ("flush")) + return 1; + else + return 0; +} + +static int +perl_can_trim (void *handle) +{ + dSP; + SV *sv; + int r; + + if (callback_defined ("can_trim")) { + /* If there's a Perl callback, call it. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("can_trim", G_EVAL|G_SCALAR); + SPAGAIN; + sv = POPs; + r = SvIV (sv); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return r; + } + /* No Perl can_trim callback, but there's a Perl trim callback + * defined, so return 1. (In C modules, nbdkit would do this). + */ + else if (callback_defined ("trim")) + return 1; + else + return 0; +} + +static int +perl_is_rotational (void *handle) +{ + dSP; + SV *sv; + int r; + + if (callback_defined ("is_rotational")) { + /* If there's a Perl callback, call it. */ + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("is_rotational", G_EVAL|G_SCALAR); + SPAGAIN; + sv = POPs; + r = SvIV (sv); + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return r; + } + else + return 0; +} + +static int +perl_flush (void *handle) +{ + dSP; + + if (callback_defined ("flush")) { + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + PUTBACK; + call_pv ("flush", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return 0; + } + + /* Ignore lack of flush callback in Perl, although probably nbdkit + * will never call this since .can_flush returns false. + */ + return 0; +} + +static int +perl_trim (void *handle, uint32_t count, uint64_t offset) +{ + dSP; + + if (callback_defined ("trim")) { + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (handle); + XPUSHs (sv_2mortal (newSViv (count))); + XPUSHs (sv_2mortal (newSViv (offset))); + PUTBACK; + call_pv ("trim", G_EVAL|G_VOID|G_DISCARD); + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + + if (check_perl_failure () == -1) + return -1; + + return 0; + } + + /* Ignore lack of trim callback in Perl, although probably nbdkit + * will never call this since .can_trim returns false. + */ + return 0; +} + +#define perl_config_help \ + "script= (required) The Perl plugin to run.\n" \ + "[other arguments may be used by the plugin that you load]" + +#define THREAD_MODEL NBDKIT_THREAD_MODEL_SERIALIZE_ALL_REQUESTS + +static struct nbdkit_plugin plugin = { + .name = "perl", + .version = PACKAGE_VERSION, + + .load = perl_load, + .unload = perl_unload, + + .config = perl_config, + .config_complete = perl_config_complete, + .config_help = perl_config_help, + + .open = perl_open, + .close = perl_close, + + .get_size = perl_get_size, + .can_write = perl_can_write, + .can_flush = perl_can_flush, + .is_rotational = perl_is_rotational, + .can_trim = perl_can_trim, + + .pread = perl_pread, + .pwrite = perl_pwrite, + .flush = perl_flush, + .trim = perl_trim, +}; + +NBDKIT_REGISTER_PLUGIN(plugin) -- 2.11.4.GIT