plugins/perl/perl.c

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