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