plugins/perl/perl.c

   1 /* nbdkit
   2  * Copyright (C) 2013-2018 Red Hat Inc.
   3  *
   4  * Redistribution and use in source and binary forms, with or without
   5  * modification, are permitted provided that the following conditions are
   6  * met:
   7  *
   8  * * Redistributions of source code must retain the above copyright
   9  * notice, this list of conditions and the following disclaimer.
  10  *
  11  * * Redistributions in binary form must reproduce the above copyright
  12  * notice, this list of conditions and the following disclaimer in the
  13  * documentation and/or other materials provided with the distribution.
  14  *
  15  * * Neither the name of Red Hat nor the names of its contributors may be
  16  * used to endorse or promote products derived from this software without
  17  * specific prior written permission.
  18  *
  19  * THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
  20  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  21  * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  22  * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
  23  * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  24  * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  25  * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
  26  * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  27  * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  28  * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
  29  * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  30  * SUCH DAMAGE.
  31  */
  32
  33 #include <config.h>
  34
  35 #include <stdio.h>
  36 #include <stdlib.h>
  37 #include <stdarg.h>
  38 #include <stdint.h>
  39 #include <inttypes.h>
  40 #include <string.h>
  41 #include <unistd.h>
  42 #include <assert.h>
  43 #include <errno.h>
  44
  45 #include <XSUB.h>
  46 #include <EXTERN.h>
  47 #include <perl.h>
  48
  49 #include <nbdkit-plugin.h>
  50
  51 #include "cleanup.h"
  52
  53 /* Use of perl.h insists on shadowing my_perl during XS(). */
  54 #pragma GCC diagnostic ignored "-Wshadow"
  55
  56 static PerlInterpreter *my_perl;
  57 static const char *script;
  58
  59 static void
  60 perl_load (void)
  61 {
  62   int argc = 1;
  63   const char *argv[2] = { "nbdkit", NULL };
  64
  65   /* Full Perl interpreter initialization is deferred until we read
  66    * the first config parameter (which MUST be "script").
  67    */
  68   PERL_SYS_INIT3 (&argc, (char ***) &argv, &environ);
  69   my_perl = perl_alloc ();
  70   if (!my_perl) {
  71     nbdkit_error ("out of memory allocating Perl interpreter");
  72     exit (EXIT_FAILURE);
  73   }
  74   perl_construct (my_perl);
  75 }
  76
  77 static void
  78 perl_unload (void)
  79 {
  80   if (my_perl != NULL) {
  81     perl_destruct (my_perl);
  82     perl_free (my_perl);
  83     PERL_SYS_TERM ();
  84   }
  85 }
  86
  87 /* We use this function to test if the named callback is defined
  88  * in the loaded Perl code.
  89  */
  90 static int
  91 callback_defined (const char *perl_func_name)
  92 {
  93   SV *ret;
  94   CLEANUP_FREE char *cmd = NULL;
  95
  96   if (asprintf (&cmd, "defined &%s", perl_func_name) == -1) {
  97     perror ("asprintf");
  98     exit (EXIT_FAILURE);
  99   }
 100
 101   ret = eval_pv (cmd, FALSE);
 102
 103   return SvTRUE (ret);
 104 }
 105
 106 /* Check for a Perl exception, and convert it to an nbdkit error. */
 107 static int
 108 check_perl_failure (void)
 109 {
 110   SV *errsv = get_sv ("@", TRUE);
 111
 112   if (SvTRUE (errsv)) {
 113     const char *err;
 114     STRLEN n;
 115     CLEANUP_FREE char *err_copy = NULL;
 116
 117     err = SvPV (errsv, n);
 118
 119     /* Need to chop off the final \n if there is one.  The only way to
 120      * do this is to copy the string.
 121      */
 122     err_copy = strndup (err, n);
 123     if (err_copy == NULL) {
 124       nbdkit_error ("malloc failure: original error: %s", err);
 125       return -1;
 126     }
 127     if (n > 0 && err_copy[n-1] == '\n')
 128       err_copy[n-1] = '\0';
 129
 130     nbdkit_error ("%s", err_copy);
 131
 132     return -1;
 133   }
 134
 135   return 0;
 136 }
 137
 138 static int last_error;
 139
 140 XS(set_error)
 141 {
 142   dXSARGS;
 143   /* Is it worth adding error checking for bad arguments? */
 144   if (items >= 1) {
 145     last_error = SvIV (ST (0));
 146     nbdkit_set_error (last_error);
 147   }
 148   XSRETURN_EMPTY;
 149 }
 150
 151 EXTERN_C void boot_DynaLoader (pTHX_ CV *cv);
 152
 153 static void
 154 xs_init (pTHX)
 155 {
 156   char *file = __FILE__;
 157   newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 158   newXS ("Nbdkit::set_error", set_error, file);
 159 }
 160
 161 static void
 162 perl_dump_plugin (void)
 163 {
 164   dSP;
 165
 166 #ifdef PERL_VERSION_STRING
 167   printf ("perl_version=%s\n", PERL_VERSION_STRING);
 168 #endif
 169
 170   if (script && callback_defined ("dump_plugin")) {
 171     ENTER;
 172     SAVETMPS;
 173     PUSHMARK (SP);
 174     PUTBACK;
 175     call_pv ("dump_plugin", G_EVAL|G_VOID|G_DISCARD);
 176     SPAGAIN;
 177     PUTBACK;
 178     FREETMPS;
 179     LEAVE;
 180   }
 181 }
 182
 183 static int
 184 perl_config (const char *key, const char *value)
 185 {
 186   if (!script) {
 187     int argc = 2;
 188     char *argv[3] = { "nbdkit", NULL, NULL };
 189
 190     /* The first parameter MUST be "script". */
 191     if (strcmp (key, "script") != 0) {
 192       nbdkit_error ("the first parameter must be "
 193                     "script=/path/to/perl/script.pl");
 194       return -1;
 195     }
 196     script = value;
 197
 198     assert (my_perl);
 199
 200     /* Load the Perl script. */
 201     argv[1] = (char *) script;
 202     if (perl_parse (my_perl, xs_init, argc, argv, NULL) == -1) {
 203       nbdkit_error ("%s: error parsing this script", script);
 204       return -1;
 205     }
 206
 207     /* Run the Perl script.  Note that top-level definitions such as
 208      * global variables don't work at all unless you do this.
 209      */
 210     if (perl_run (my_perl) == -1) {
 211       nbdkit_error ("%s: error running this script", script);
 212       return -1;
 213     }
 214
 215     /* Minimal set of callbacks which are required (by nbdkit itself). */
 216     if (!callback_defined ("open") ||
 217         !callback_defined ("get_size") ||
 218         !callback_defined ("pread")) {
 219       nbdkit_error ("%s: one of the required callbacks "
 220                     "'open', 'get_size' or 'pread' "
 221                     "is not defined by this Perl script.  "
 222                     "nbdkit requires these callbacks.", script);
 223       return -1;
 224     }
 225   }
 226   else if (callback_defined ("config")) {
 227     dSP;
 228
 229     /* Other parameters are passed to the Perl .config callback. */
 230     ENTER;
 231     SAVETMPS;
 232     PUSHMARK (SP);
 233     XPUSHs (sv_2mortal (newSVpv (key, strlen (key))));
 234     XPUSHs (sv_2mortal (newSVpv (value, strlen (value))));
 235     PUTBACK;
 236     call_pv ("config", G_EVAL|G_VOID|G_DISCARD);
 237     SPAGAIN;
 238     PUTBACK;
 239     FREETMPS;
 240     LEAVE;
 241
 242     if (check_perl_failure () == -1)
 243       return -1;
 244   }
 245   else {
 246     /* Emulate what core nbdkit does if a config callback is NULL. */
 247     nbdkit_error ("%s: this plugin does not need command line configuration",
 248                   script);
 249     return -1;
 250   }
 251
 252   return 0;
 253 }
 254
 255 static int
 256 perl_config_complete (void)
 257 {
 258   dSP;
 259
 260   if (callback_defined ("config_complete")) {
 261     ENTER;
 262     SAVETMPS;
 263     PUSHMARK (SP);
 264     PUTBACK;
 265     call_pv ("config_complete", G_EVAL|G_VOID|G_DISCARD);
 266     SPAGAIN;
 267     PUTBACK;
 268     FREETMPS;
 269     LEAVE;
 270     if (check_perl_failure () == -1)
 271       return -1;
 272   }
 273
 274   return 0;
 275 }
 276
 277 static void *
 278 perl_open (int readonly)
 279 {
 280   SV *sv;
 281   dSP;
 282
 283   /* We check in perl_config that this callback is defined. */
 284   ENTER;
 285   SAVETMPS;
 286   PUSHMARK (SP);
 287   XPUSHs (readonly ? &PL_sv_yes : &PL_sv_no);
 288   PUTBACK;
 289   call_pv ("open", G_EVAL|G_SCALAR);
 290   SPAGAIN;
 291   sv = newSVsv (POPs);
 292   PUTBACK;
 293   FREETMPS;
 294   LEAVE;
 295
 296   if (check_perl_failure () == -1)
 297     return NULL;
 298
 299   nbdkit_debug ("open returns handle (SV *) = %p (type %d)",
 300                 sv, SvTYPE (sv));
 301
 302   return sv;
 303 }
 304
 305 static void
 306 perl_close (void *handle)
 307 {
 308   dSP;
 309
 310   nbdkit_debug ("close called with handle (SV *) = %p (type %d)",
 311                 handle, SvTYPE ((SV *) handle));
 312
 313   if (callback_defined ("close")) {
 314     ENTER;
 315     SAVETMPS;
 316     PUSHMARK (SP);
 317     XPUSHs (handle);
 318     PUTBACK;
 319     call_pv ("close", G_EVAL|G_VOID|G_DISCARD);
 320     SPAGAIN;
 321     PUTBACK;
 322     FREETMPS;
 323     LEAVE;
 324
 325     check_perl_failure ();      /* ignore return value */
 326   }
 327
 328   /* Since nbdkit has closed (and forgotten) the handle, we can now
 329    * drop its refcount.
 330    */
 331   SvREFCNT_dec ((SV *) handle);
 332 }
 333
 334 static int64_t
 335 perl_get_size (void *handle)
 336 {
 337   dSP;
 338   SV *sv;
 339   int64_t size;
 340
 341   /* We check in perl_config that this callback is defined. */
 342   ENTER;
 343   SAVETMPS;
 344   PUSHMARK (SP);
 345   XPUSHs (handle);
 346   PUTBACK;
 347   call_pv ("get_size", G_EVAL|G_SCALAR);
 348   SPAGAIN;
 349   /* For some reason, this only works if split into two separate statements: */
 350   sv = POPs;
 351   size = SvIV (sv);
 352   PUTBACK;
 353   FREETMPS;
 354   LEAVE;
 355
 356   if (check_perl_failure () == -1)
 357     return -1;
 358
 359   nbdkit_debug ("get_size returned %" PRIi64, size);
 360
 361   return size;
 362 }
 363
 364 static int
 365 perl_boolean (void *handle, const char *callback_name, const char *fn_name)
 366 {
 367   dSP;
 368   SV *sv;
 369   int r;
 370
 371   if (callback_defined (callback_name)) {
 372     /* If there's a Perl callback, call it. */
 373     ENTER;
 374     SAVETMPS;
 375     PUSHMARK (SP);
 376     XPUSHs (handle);
 377     PUTBACK;
 378     call_pv (callback_name, G_EVAL|G_SCALAR);
 379     SPAGAIN;
 380     sv = POPs;
 381     r = SvIV (sv);
 382     PUTBACK;
 383     FREETMPS;
 384     LEAVE;
 385
 386     if (check_perl_failure () == -1)
 387       return -1;
 388
 389     return r;
 390   }
 391   /* No Perl callback.  If the function is defined, return 1. */
 392   else if (fn_name && callback_defined (fn_name))
 393     return 1;
 394   else
 395     return 0;
 396 }
 397
 398 static int
 399 perl_can_write (void *handle)
 400 {
 401   return perl_boolean (handle, "can_write", "write");
 402 }
 403
 404 static int
 405 perl_can_flush (void *handle)
 406 {
 407   return perl_boolean (handle, "can_flush", "flush");
 408 }
 409
 410 static int
 411 perl_can_trim (void *handle)
 412 {
 413   return perl_boolean (handle, "can_trim", "trim");
 414 }
 415
 416 static int
 417 perl_is_rotational (void *handle)
 418 {
 419   return perl_boolean (handle, "is_rotational", NULL);
 420 }
 421
 422 static int
 423 perl_pread (void *handle, void *buf,
 424             uint32_t count, uint64_t offset)
 425 {
 426   dSP;
 427   SV *sv;
 428   const char *pbuf;
 429   STRLEN len;
 430   int ret = 0;
 431
 432   /* We check in perl_config that this callback is defined. */
 433   ENTER;
 434   SAVETMPS;
 435   PUSHMARK (SP);
 436   XPUSHs (handle);
 437   XPUSHs (sv_2mortal (newSViv (count)));
 438   XPUSHs (sv_2mortal (newSViv (offset)));
 439   PUTBACK;
 440   call_pv ("pread", G_EVAL|G_SCALAR);
 441   SPAGAIN;
 442   sv = POPs;
 443   pbuf = SvPV (sv, len);
 444   if (len < count) {
 445     nbdkit_error ("buffer returned from pread is too small");
 446     ret = -1;
 447   }
 448   else
 449     memcpy (buf, pbuf, count);
 450   PUTBACK;
 451   FREETMPS;
 452   LEAVE;
 453
 454   if (check_perl_failure () == -1)
 455     ret = -1;
 456
 457   return ret;
 458 }
 459
 460 static int
 461 perl_pwrite (void *handle, const void *buf,
 462              uint32_t count, uint64_t offset)
 463 {
 464   dSP;
 465
 466   if (callback_defined ("pwrite")) {
 467     ENTER;
 468     SAVETMPS;
 469     PUSHMARK (SP);
 470     XPUSHs (handle);
 471     XPUSHs (sv_2mortal (newSVpv (buf, count)));
 472     XPUSHs (sv_2mortal (newSViv (offset)));
 473     PUTBACK;
 474     call_pv ("pwrite", G_EVAL|G_VOID|G_DISCARD);
 475     SPAGAIN;
 476     PUTBACK;
 477     FREETMPS;
 478     LEAVE;
 479
 480     if (check_perl_failure () == -1)
 481       return -1;
 482
 483     return 0;
 484   }
 485
 486   nbdkit_error ("write not implemented");
 487   return -1;
 488 }
 489
 490 static int
 491 perl_zero (void *handle, uint32_t count, uint64_t offset, int may_trim)
 492 {
 493   dSP;
 494
 495   if (callback_defined ("zero")) {
 496     last_error = 0;
 497     ENTER;
 498     SAVETMPS;
 499     PUSHMARK (SP);
 500     XPUSHs (handle);
 501     XPUSHs (sv_2mortal (newSViv (count)));
 502     XPUSHs (sv_2mortal (newSViv (offset)));
 503     XPUSHs (sv_2mortal (newSViv (may_trim)));
 504     PUTBACK;
 505     call_pv ("zero", G_EVAL|G_SCALAR);
 506     SPAGAIN;
 507     PUTBACK;
 508     FREETMPS;
 509     LEAVE;
 510
 511     if (last_error == EOPNOTSUPP || last_error == ENOTSUP) {
 512       /* When user requests this particular error, we want to
 513          gracefully fall back, and to accomodate both a normal return
 514          and an exception. */
 515       nbdkit_debug ("zero requested falling back to pwrite");
 516       return -1;
 517     }
 518     if (check_perl_failure () == -1)
 519       return -1;
 520
 521     return 0;
 522   }
 523
 524   nbdkit_debug ("zero falling back to pwrite");
 525   nbdkit_set_error (EOPNOTSUPP);
 526   return -1;
 527 }
 528
 529 static int
 530 perl_flush (void *handle)
 531 {
 532   dSP;
 533
 534   if (callback_defined ("flush")) {
 535     ENTER;
 536     SAVETMPS;
 537     PUSHMARK (SP);
 538     XPUSHs (handle);
 539     PUTBACK;
 540     call_pv ("flush", G_EVAL|G_VOID|G_DISCARD);
 541     SPAGAIN;
 542     PUTBACK;
 543     FREETMPS;
 544     LEAVE;
 545
 546     if (check_perl_failure () == -1)
 547       return -1;
 548
 549     return 0;
 550   }
 551
 552   /* Ignore lack of flush callback in Perl, although probably nbdkit
 553    * will never call this since .can_flush returns false.
 554    */
 555   return 0;
 556 }
 557
 558 static int
 559 perl_trim (void *handle, uint32_t count, uint64_t offset)
 560 {
 561   dSP;
 562
 563   if (callback_defined ("trim")) {
 564     ENTER;
 565     SAVETMPS;
 566     PUSHMARK (SP);
 567     XPUSHs (handle);
 568     XPUSHs (sv_2mortal (newSViv (count)));
 569     XPUSHs (sv_2mortal (newSViv (offset)));
 570     PUTBACK;
 571     call_pv ("trim", G_EVAL|G_VOID|G_DISCARD);
 572     SPAGAIN;
 573     PUTBACK;
 574     FREETMPS;
 575     LEAVE;
 576
 577     if (check_perl_failure () == -1)
 578       return -1;
 579
 580     return 0;
 581   }
 582
 583   /* Ignore lack of trim callback in Perl, although probably nbdkit
 584    * will never call this since .can_trim returns false.
 585    */
 586   return 0;
 587 }
 588
 589 #define perl_config_help \
 590   "script=<FILENAME>     (required) The Perl plugin to run.\n" \
 591   "[other arguments may be used by the plugin that you load]"
 592
 593 #define THREAD_MODEL NBDKIT_THREAD_MODEL_SERIALIZE_ALL_REQUESTS
 594
 595 static struct nbdkit_plugin plugin = {
 596   .name              = "perl",
 597   .version           = PACKAGE_VERSION,
 598
 599   .load              = perl_load,
 600   .unload            = perl_unload,
 601   .dump_plugin       = perl_dump_plugin,
 602
 603   .config            = perl_config,
 604   .config_complete   = perl_config_complete,
 605   .config_help       = perl_config_help,
 606
 607   .open              = perl_open,
 608   .close             = perl_close,
 609
 610   .get_size          = perl_get_size,
 611   .can_write         = perl_can_write,
 612   .can_flush         = perl_can_flush,
 613   .is_rotational     = perl_is_rotational,
 614   .can_trim          = perl_can_trim,
 615
 616   .pread             = perl_pread,
 617   .pwrite            = perl_pwrite,
 618   .flush             = perl_flush,
 619   .trim              = perl_trim,
 620   .zero              = perl_zero,
 621 };
 622
 623 NBDKIT_REGISTER_PLUGIN(plugin)