external/bsd/bind/dist/contrib/dlz/modules/perl/dlz_perl_driver.c

   1 /*      $NetBSD: dlz_perl_driver.c,v 1.1.1.3 2014/12/10 03:34:31 christos Exp $ */
   2
   3 /*
   4  * Copyright (C) 2002 Stichting NLnet, Netherlands, stichting@nlnet.nl.
   5  *
   6  * Permission to use, copy, modify, and distribute this software for any
   7  * purpose with or without fee is hereby granted, provided that the
   8  * above copyright notice and this permission notice appear in all
   9  * copies.
  10  *
  11  * THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET
  12  * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
  13  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  14  * STICHTING NLNET BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  15  * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  16  * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  17  * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE
  18  * USE OR PERFORMANCE OF THIS SOFTWARE.
  19  *
  20  * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
  21  * conceived and contributed by Rob Butler.
  22  *
  23  * Permission to use, copy, modify, and distribute this software for any
  24  * purpose with or without fee is hereby granted, provided that the
  25  * above copyright notice and this permission notice appear in all
  26  * copies.
  27  *
  28  * THE SOFTWARE IS PROVIDED "AS IS" AND ROB BUTLER
  29  * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
  30  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  31  * ROB BUTLER BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  32  * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  33  * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  34  * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE
  35  * USE OR PERFORMANCE OF THIS SOFTWARE.
  36  */
  37
  38 /*
  39  * Copyright (C) 1999-2001  Internet Software Consortium.
  40  *
  41  * Permission to use, copy, modify, and distribute this software for any
  42  * purpose with or without fee is hereby granted, provided that the above
  43  * copyright notice and this permission notice appear in all copies.
  44  *
  45  * THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM
  46  * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
  47  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  48  * INTERNET SOFTWARE CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT,
  49  * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  50  * FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  51  * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  52  * WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  53  */
  54
  55 /*
  56  * Copyright (C) 2009-2012  John Eaglesham
  57  *
  58  * Permission to use, copy, modify, and distribute this software for any
  59  * purpose with or without fee is hereby granted, provided that the above
  60  * copyright notice and this permission notice appear in all copies.
  61  *
  62  * THE SOFTWARE IS PROVIDED "AS IS" AND JOHN EAGLESHAM
  63  * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
  64  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  65  * JOHN EAGLESHAM BE LIABLE FOR ANY SPECIAL, DIRECT,
  66  * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  67  * FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  68  * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  69  * WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  70  */
  71
  72 #include <config.h>
  73 #include <stdio.h>
  74 #include <string.h>
  75 #include <stdlib.h>
  76
  77 #include <EXTERN.h>
  78 #include <perl.h>
  79
  80 #include <dlz_minimal.h>
  81
  82 #include "dlz_perl_driver.h"
  83
  84 /* Enable debug logging? */
  85 #if 0
  86 #define carp(...)       cd->log(ISC_LOG_INFO, __VA_ARGS__);
  87 #else
  88 #define carp(...)
  89 #endif
  90
  91 #ifndef MULTIPLICITY
  92 /* This is a pretty terrible work-around for handling HUP/rndc reconfig, but
  93  * the way BIND/DLZ handles reloads causes it to create a second back end
  94  * before removing the first. In the case of a single global interpreter,
  95  * serious problems arise. We can hack around this, but it's much better to do
  96  * it properly and link against a perl compiled with multiplicity. */
  97 static PerlInterpreter *global_perl = NULL;
  98 static int global_perl_dont_free = 0;
  99 #endif
 100
 101 typedef struct config_data {
 102         PerlInterpreter *perl;
 103         char                    *perl_source;
 104         SV                              *perl_class;
 105
 106         /* Functions given to us by bind9 */
 107         log_t *log;
 108         dns_sdlz_putrr_t *putrr;
 109         dns_sdlz_putnamedrr_t *putnamedrr;
 110         dns_dlz_writeablezone_t *writeable_zone;
 111 } config_data_t;
 112
 113 /* Note, this code generates warnings due to lost type qualifiers.  This code
 114  * is (almost) verbatim from perlembed, and is known to work correctly despite
 115  * the warnings.
 116  */
 117 EXTERN_C void xs_init (pTHX);
 118 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
 119 EXTERN_C void boot_DLZ_Perl__clientinfo (pTHX_ CV* cv);
 120 EXTERN_C void boot_DLZ_Perl (pTHX_ CV* cv);
 121 EXTERN_C void
 122 xs_init(pTHX)
 123 {
 124                 char *file = __FILE__;
 125                 dXSUB_SYS;
 126
 127                 /* DynaLoader is a special case */
 128                 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 129                 newXS("DLZ_Perl::clientinfo::bootstrap", boot_DLZ_Perl__clientinfo, file);
 130                 newXS("DLZ_Perl::bootstrap", boot_DLZ_Perl, file);
 131 }
 132
 133 /*
 134  * methods
 135  */
 136
 137 /*
 138  * remember a helper function, from the bind9 dlz_dlopen driver
 139  */
 140 static void b9_add_helper(config_data_t *state,
 141                           const char *helper_name, void *ptr)
 142 {
 143         if (strcmp(helper_name, "log") == 0)
 144                 state->log = ptr;
 145         if (strcmp(helper_name, "putrr") == 0)
 146                 state->putrr = ptr;
 147         if (strcmp(helper_name, "putnamedrr") == 0)
 148                 state->putnamedrr = ptr;
 149         if (strcmp(helper_name, "writeable_zone") == 0)
 150                 state->writeable_zone = ptr;
 151 }
 152
 153 int dlz_version(unsigned int *flags) {
 154         return DLZ_DLOPEN_VERSION;
 155 }
 156
 157 isc_result_t dlz_allnodes(const char *zone, void *dbdata,
 158                           dns_sdlzallnodes_t *allnodes)
 159 {
 160         config_data_t *cd = (config_data_t *) dbdata;
 161         isc_result_t retval;
 162         int rrcount, r;
 163         SV *record_ref;
 164         SV **rr_name;
 165         SV **rr_type;
 166         SV **rr_ttl;
 167         SV **rr_data;
 168 #ifdef MULTIPLICITY
 169         PerlInterpreter *my_perl = cd->perl;
 170 #endif
 171         dSP;
 172
 173         PERL_SET_CONTEXT(cd->perl);
 174         ENTER;
 175         SAVETMPS;
 176
 177         PUSHMARK(SP);
 178         XPUSHs(cd->perl_class);
 179         XPUSHs(sv_2mortal(newSVpv(zone, 0)));
 180         PUTBACK;
 181
 182         carp("DLZ Perl: Calling allnodes for zone %s", zone);
 183         rrcount = call_method("allnodes", G_ARRAY|G_EVAL);
 184         carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount);
 185
 186         SPAGAIN;
 187
 188         if (SvTRUE(ERRSV)) {
 189                 POPs;
 190                 cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s died in eval: %s", zone, SvPV_nolen(ERRSV));
 191                 retval = ISC_R_FAILURE;
 192                 goto CLEAN_UP_AND_RETURN;
 193         }
 194
 195         if (!rrcount) {
 196                 retval = ISC_R_NOTFOUND;
 197                 goto CLEAN_UP_AND_RETURN;
 198         }
 199
 200         retval = ISC_R_SUCCESS;
 201         r = 0;
 202         while (r++ < rrcount) {
 203                 record_ref = POPs;
 204                 if (
 205                         (!SvROK(record_ref)) ||
 206                         (SvTYPE(SvRV(record_ref)) != SVt_PVAV)
 207                 ) {
 208                         cd->log(ISC_LOG_ERROR,
 209                                 "DLZ Perl: allnodes for zone %s "
 210                                 "returned an invalid value "
 211                                 "(expected array of arrayrefs)",
 212                                 zone);
 213                         retval = ISC_R_FAILURE;
 214                         break;
 215                 }
 216
 217                 record_ref = SvRV(record_ref);
 218
 219                 rr_name = av_fetch((AV *) record_ref, 0, 0);
 220                 rr_type = av_fetch((AV *) record_ref, 1, 0);
 221                 rr_ttl = av_fetch((AV *) record_ref, 2, 0);
 222                 rr_data = av_fetch((AV *) record_ref, 3, 0);
 223
 224                 if (rr_name == NULL || rr_type == NULL ||
 225                     rr_ttl == NULL || rr_data == NULL)
 226                 {
 227                         cd->log(ISC_LOG_ERROR,
 228                                 "DLZ Perl: allnodes for zone %s "
 229                                 "returned an array that was missing data",
 230                                 zone);
 231                         retval = ISC_R_FAILURE;
 232                         break;
 233                 }
 234
 235                 carp("DLZ Perl: Got record %s/%s = %s",
 236                      SvPV_nolen(*rr_name), SvPV_nolen(*rr_type),
 237                      SvPV_nolen(*rr_data));
 238                 retval = cd->putnamedrr(allnodes,
 239                                         SvPV_nolen(*rr_name),
 240                                         SvPV_nolen(*rr_type),
 241                                         SvIV(*rr_ttl), SvPV_nolen(*rr_data));
 242                 if (retval != ISC_R_SUCCESS) {
 243                         cd->log(ISC_LOG_ERROR,
 244                                 "DLZ Perl: putnamedrr in allnodes "
 245                                 "for zone %s failed with code %i "
 246                                 "(did lookup return invalid record data?)",
 247                                 zone, retval);
 248                         break;
 249                 }
 250         }
 251
 252 CLEAN_UP_AND_RETURN:
 253         PUTBACK;
 254         FREETMPS;
 255         LEAVE;
 256
 257         carp("DLZ Perl: Returning from allnodes, r = %i, retval = %i",
 258              r, retval);
 259
 260         return (retval);
 261 }
 262
 263 isc_result_t
 264 dlz_allowzonexfr(void *dbdata, const char *name, const char *client) {
 265         config_data_t *cd = (config_data_t *) dbdata;
 266         int r;
 267         isc_result_t retval;
 268 #ifdef MULTIPLICITY
 269         PerlInterpreter *my_perl = cd->perl;
 270 #endif
 271         dSP;
 272
 273         PERL_SET_CONTEXT(cd->perl);
 274         ENTER;
 275         SAVETMPS;
 276
 277         PUSHMARK(SP);
 278         XPUSHs(cd->perl_class);
 279         XPUSHs(sv_2mortal(newSVpv(name, 0)));
 280         XPUSHs(sv_2mortal(newSVpv(client, 0)));
 281         PUTBACK;
 282
 283         r = call_method("allowzonexfr", G_SCALAR|G_EVAL);
 284         SPAGAIN;
 285
 286         if (SvTRUE(ERRSV)) {
 287                 /*
 288                  * On error there's an undef at the top of the stack. Pop
 289                  * it away so we don't leave junk on the stack for the next
 290                  * caller.
 291                  */
 292                 POPs;
 293                 cd->log(ISC_LOG_ERROR,
 294                         "DLZ Perl: allowzonexfr died in eval: %s",
 295                         SvPV_nolen(ERRSV));
 296                 retval = ISC_R_FAILURE;
 297         } else if (r == 0) {
 298                 /* Client returned nothing -- zone not found. */
 299                 retval = ISC_R_NOTFOUND;
 300         } else if (r > 1) {
 301                 /* Once again, clean out the stack when possible. */
 302                 while (r--) POPi;
 303                 cd->log(ISC_LOG_ERROR,
 304                         "DLZ Perl: allowzonexfr returned too many parameters!");
 305                 retval = ISC_R_FAILURE;
 306         } else {
 307                 /*
 308                  * Client returned true/false -- we're authoritative for
 309                  * the zone.
 310                  */
 311                 r = POPi;
 312                 if (r)
 313                         retval = ISC_R_SUCCESS;
 314                 else
 315                         retval = ISC_R_NOPERM;
 316         }
 317
 318         PUTBACK;
 319         FREETMPS;
 320         LEAVE;
 321         return (retval);
 322 }
 323
 324 #if DLZ_DLOPEN_VERSION < 3
 325 isc_result_t
 326 dlz_findzonedb(void *dbdata, const char *name)
 327 #else
 328 isc_result_t
 329 dlz_findzonedb(void *dbdata, const char *name,
 330                dns_clientinfomethods_t *methods,
 331                dns_clientinfo_t *clientinfo)
 332 #endif
 333 {
 334         config_data_t *cd = (config_data_t *) dbdata;
 335         int r;
 336         isc_result_t retval;
 337 #ifdef MULTIPLICITY
 338         PerlInterpreter *my_perl = cd->perl;
 339 #endif
 340
 341 #if DLZ_DLOPEN_VERSION >= 3
 342         UNUSED(methods);
 343         UNUSED(clientinfo);
 344 #endif
 345
 346         dSP;
 347         carp("DLZ Perl: findzone looking for '%s'", name);
 348
 349         PERL_SET_CONTEXT(cd->perl);
 350         ENTER;
 351         SAVETMPS;
 352
 353         PUSHMARK(SP);
 354         XPUSHs(cd->perl_class);
 355         XPUSHs(sv_2mortal(newSVpv(name, 0)));
 356         PUTBACK;
 357
 358         r = call_method("findzone", G_SCALAR|G_EVAL);
 359         SPAGAIN;
 360
 361         if (SvTRUE(ERRSV)) {
 362                 /*
 363                  * On error there's an undef at the top of the stack. Pop
 364                  * it away so we don't leave junk on the stack for the next
 365                  * caller.
 366                  */
 367                 POPs;
 368                 cd->log(ISC_LOG_ERROR,
 369                         "DLZ Perl: findzone died in eval: %s",
 370                         SvPV_nolen(ERRSV));
 371                 retval = ISC_R_FAILURE;
 372         } else if (r == 0) {
 373                 retval = ISC_R_FAILURE;
 374         } else if (r > 1) {
 375                 /* Once again, clean out the stack when possible. */
 376                 while (r--) POPi;
 377                 cd->log(ISC_LOG_ERROR,
 378                         "DLZ Perl: findzone returned too many parameters!");
 379                 retval = ISC_R_FAILURE;
 380         } else {
 381                 r = POPi;
 382                 if (r)
 383                         retval = ISC_R_SUCCESS;
 384                 else
 385                         retval = ISC_R_NOTFOUND;
 386         }
 387
 388         PUTBACK;
 389         FREETMPS;
 390         LEAVE;
 391         return (retval);
 392 }
 393
 394
 395 #if DLZ_DLOPEN_VERSION == 1
 396 isc_result_t
 397 dlz_lookup(const char *zone, const char *name,
 398            void *dbdata, dns_sdlzlookup_t *lookup)
 399 #else
 400 isc_result_t
 401 dlz_lookup(const char *zone, const char *name,
 402            void *dbdata, dns_sdlzlookup_t *lookup,
 403            dns_clientinfomethods_t *methods,
 404            dns_clientinfo_t *clientinfo)
 405 #endif
 406 {
 407         isc_result_t retval;
 408         config_data_t *cd = (config_data_t *) dbdata;
 409         int rrcount, r;
 410         dlz_perl_clientinfo_opaque opaque;
 411         SV *record_ref;
 412         SV **rr_type;
 413         SV **rr_ttl;
 414         SV **rr_data;
 415 #ifdef MULTIPLICITY
 416         PerlInterpreter *my_perl = cd->perl;
 417 #endif
 418
 419 #if DLZ_DLOPEN_VERSION >= 2
 420         UNUSED(methods);
 421         UNUSED(clientinfo);
 422 #endif
 423
 424         dSP;
 425         PERL_SET_CONTEXT(cd->perl);
 426         ENTER;
 427         SAVETMPS;
 428
 429         opaque.methods = methods;
 430         opaque.clientinfo = clientinfo;
 431
 432         PUSHMARK(SP);
 433         XPUSHs(cd->perl_class);
 434         XPUSHs(sv_2mortal(newSVpv(name, 0)));
 435         XPUSHs(sv_2mortal(newSVpv(zone, 0)));
 436         XPUSHs(sv_2mortal(newSViv((IV)&opaque)));
 437         PUTBACK;
 438
 439         carp("DLZ Perl: Searching for name %s in zone %s", name, zone);
 440         rrcount = call_method("lookup", G_ARRAY|G_EVAL);
 441         carp("DLZ Perl: Call to lookup returned %i", rrcount);
 442
 443         SPAGAIN;
 444
 445         if (SvTRUE(ERRSV)) {
 446                 POPs;
 447                 cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s",
 448                         SvPV_nolen(ERRSV));
 449                 retval = ISC_R_FAILURE;
 450                 goto CLEAN_UP_AND_RETURN;
 451         }
 452
 453         if (!rrcount) {
 454                 retval = ISC_R_NOTFOUND;
 455                 goto CLEAN_UP_AND_RETURN;
 456         }
 457
 458         retval = ISC_R_SUCCESS;
 459         r = 0;
 460         while (r++ < rrcount) {
 461                 record_ref = POPs;
 462                 if ((!SvROK(record_ref)) ||
 463                     (SvTYPE(SvRV(record_ref)) != SVt_PVAV))
 464                 {
 465                         cd->log(ISC_LOG_ERROR,
 466                                 "DLZ Perl: lookup returned an "
 467                                 "invalid value (expected array of arrayrefs)!");
 468                         retval = ISC_R_FAILURE;
 469                         break;
 470                 }
 471
 472                 record_ref = SvRV(record_ref);
 473
 474                 rr_type = av_fetch((AV *) record_ref, 0, 0);
 475                 rr_ttl = av_fetch((AV *) record_ref, 1, 0);
 476                 rr_data = av_fetch((AV *) record_ref, 2, 0);
 477
 478                 if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) {
 479                         cd->log(ISC_LOG_ERROR,
 480                                 "DLZ Perl: lookup for record %s in "
 481                                 "zone %s returned an array that was "
 482                                 "missing data", name, zone);
 483                         retval = ISC_R_FAILURE;
 484                         break;
 485                 }
 486
 487                 carp("DLZ Perl: Got record %s = %s",
 488                      SvPV_nolen(*rr_type), SvPV_nolen(*rr_data));
 489                 retval = cd->putrr(lookup, SvPV_nolen(*rr_type),
 490                                    SvIV(*rr_ttl), SvPV_nolen(*rr_data));
 491
 492                 if (retval != ISC_R_SUCCESS) {
 493                         cd->log(ISC_LOG_ERROR,
 494                                 "DLZ Perl: putrr for lookup of %s in "
 495                                 "zone %s failed with code %i "
 496                                 "(did lookup return invalid record data?)",
 497                                 name, zone, retval);
 498                         break;
 499                 }
 500         }
 501
 502 CLEAN_UP_AND_RETURN:
 503         PUTBACK;
 504         FREETMPS;
 505         LEAVE;
 506
 507         carp("DLZ Perl: Returning from lookup, r = %i, retval = %i", r, retval);
 508
 509         return (retval);
 510 }
 511
 512 const char *
 513 #ifdef MULTIPLICITY
 514 missing_perl_method(const char *perl_class_name, PerlInterpreter *my_perl)
 515 #else
 516 missing_perl_method(const char *perl_class_name)
 517 #endif
 518 {
 519         const int BUF_LEN = 64; /* Should be big enough, right? hah */
 520         char full_name[BUF_LEN];
 521         const char *methods[] = { "new", "findzone", "lookup", NULL };
 522         int i = 0;
 523
 524         while( methods[i] != NULL ) {
 525                 snprintf(full_name, BUF_LEN, "%s::%s",
 526                          perl_class_name, methods[i]);
 527
 528                 if (get_cv(full_name, 0) == NULL) {
 529                         return methods[i];
 530                 }
 531                 i++;
 532         }
 533
 534         return (NULL);
 535 }
 536
 537 isc_result_t
 538 dlz_create(const char *dlzname, unsigned int argc, char *argv[],
 539            void **dbdata, ...)
 540 {
 541         config_data_t *cd;
 542         char *init_args[] = { NULL, NULL };
 543         char *perlrun[] = { "", NULL, "dlz perl", NULL };
 544         char *perl_class_name;
 545         int r;
 546         va_list ap;
 547         const char *helper_name;
 548         const char *missing_method_name;
 549         char *call_argv_args = NULL;
 550 #ifdef MULTIPLICITY
 551         PerlInterpreter *my_perl;
 552 #endif
 553
 554         cd = malloc(sizeof(config_data_t));
 555         if (cd == NULL)
 556                 return (ISC_R_NOMEMORY);
 557
 558         memset(cd, 0, sizeof(config_data_t));
 559
 560         /* fill in the helper functions */
 561         va_start(ap, dbdata);
 562         while ((helper_name = va_arg(ap, const char *)) != NULL) {
 563                 b9_add_helper(cd, helper_name, va_arg(ap, void*));
 564         }
 565         va_end(ap);
 566
 567         if (argc < 2) {
 568                 cd->log(ISC_LOG_ERROR,
 569                         "DLZ Perl '%s': Missing script argument.",
 570                         dlzname);
 571                 return (ISC_R_FAILURE);
 572         }
 573
 574         if (argc < 3) {
 575                 cd->log(ISC_LOG_ERROR,
 576                         "DLZ Perl '%s': Missing class name argument.",
 577                         dlzname);
 578                 return (ISC_R_FAILURE);
 579         }
 580         perl_class_name = argv[2];
 581
 582         cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'",
 583                  dlzname, perl_class_name, argv[1], argc);
 584
 585 #ifndef MULTIPLICITY
 586         if (global_perl) {
 587                 /*
 588                  * PERL_SET_CONTEXT not needed here as we're guaranteed to
 589                  * have an implicit context thanks to an undefined
 590                  * MULTIPLICITY.
 591                  */
 592                 PL_perl_destruct_level = 1;
 593                 perl_destruct(global_perl);
 594                 perl_free(global_perl);
 595                 global_perl = NULL;
 596                 global_perl_dont_free = 1;
 597         }
 598 #endif
 599
 600         cd->perl = perl_alloc();
 601         if (cd->perl == NULL) {
 602                 free(cd);
 603                 return (ISC_R_FAILURE);
 604         }
 605 #ifdef MULTIPLICITY
 606         my_perl = cd->perl;
 607 #endif
 608         PERL_SET_CONTEXT(cd->perl);
 609
 610         /*
 611          * We will re-create the interpreter during an rndc reconfig, so we
 612          * must set this variable per perlembed in order to insure we can
 613          * clean up Perl at a later time.
 614          */
 615         PL_perl_destruct_level = 1;
 616         perl_construct(cd->perl);
 617         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 618         /* Prevent crashes from clients writing to $0 */
 619         PL_origalen = 1;
 620
 621         cd->perl_source = strdup(argv[1]);
 622         if (cd->perl_source == NULL) {
 623                 free(cd);
 624                 return (ISC_R_NOMEMORY);
 625         }
 626
 627         perlrun[1] = cd->perl_source;
 628         if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {
 629                 cd->log(ISC_LOG_ERROR,
 630                         "DLZ Perl '%s': Failed to parse Perl script, aborting",
 631                         dlzname);
 632                 goto CLEAN_UP_PERL_AND_FAIL;
 633         }
 634
 635         /* Let Perl know about our callbacks. */
 636         call_argv("DLZ_Perl::clientinfo::bootstrap",
 637                   G_DISCARD|G_NOARGS, &call_argv_args);
 638         call_argv("DLZ_Perl::bootstrap",
 639                   G_DISCARD|G_NOARGS, &call_argv_args);
 640
 641         /*
 642          * Run the script. We don't really need to do this since we have
 643          * the init callback, but there's not really a downside either.
 644          */
 645         if (perl_run(cd->perl)) {
 646                 cd->log(ISC_LOG_ERROR,
 647                         "DLZ Perl '%s': Script exited with an error, aborting",
 648                         dlzname);
 649                 goto CLEAN_UP_PERL_AND_FAIL;
 650         }
 651
 652 #ifdef MULTIPLICITY
 653         if (missing_method_name = missing_perl_method(perl_class_name, my_perl))
 654 #else
 655         if (missing_method_name = missing_perl_method(perl_class_name))
 656 #endif
 657         {
 658                 cd->log(ISC_LOG_ERROR,
 659                         "DLZ Perl '%s': Missing required function '%s', "
 660                         "aborting", dlzname, missing_method_name);
 661                 goto CLEAN_UP_PERL_AND_FAIL;
 662         }
 663
 664         dSP;
 665         ENTER;
 666         SAVETMPS;
 667
 668         PUSHMARK(SP);
 669         XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));
 670
 671         /* Build flattened hash of config info. */
 672         XPUSHs(sv_2mortal(newSVpv("log_context", 0)));
 673         XPUSHs(sv_2mortal(newSViv((IV)cd->log)));
 674
 675         /* Argument to pass to new? */
 676         if (argc == 4) {
 677                 XPUSHs(sv_2mortal(newSVpv("argv", 0)));
 678                 XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));
 679         }
 680
 681         PUTBACK;
 682
 683         r = call_method("new", G_EVAL|G_SCALAR);
 684
 685         SPAGAIN;
 686
 687         if (r) cd->perl_class = SvREFCNT_inc(POPs);
 688
 689         PUTBACK;
 690         FREETMPS;
 691         LEAVE;
 692
 693         if (SvTRUE(ERRSV)) {
 694                 POPs;
 695                 cd->log(ISC_LOG_ERROR,
 696                         "DLZ Perl '%s': new died in eval: %s",
 697                         dlzname, SvPV_nolen(ERRSV));
 698                 goto CLEAN_UP_PERL_AND_FAIL;
 699         }
 700
 701         if (!r || !sv_isobject(cd->perl_class)) {
 702                 cd->log(ISC_LOG_ERROR,
 703                         "DLZ Perl '%s': new failed to return a blessed object",
 704                         dlzname);
 705                 goto CLEAN_UP_PERL_AND_FAIL;
 706         }
 707
 708         *dbdata = cd;
 709
 710 #ifndef MULTIPLICITY
 711         global_perl = cd->perl;
 712 #endif
 713         return (ISC_R_SUCCESS);
 714
 715 CLEAN_UP_PERL_AND_FAIL:
 716         PL_perl_destruct_level = 1;
 717         perl_destruct(cd->perl);
 718         perl_free(cd->perl);
 719         free(cd->perl_source);
 720         free(cd);
 721         return (ISC_R_FAILURE);
 722 }
 723
 724 void dlz_destroy(void *dbdata) {
 725         config_data_t *cd = (config_data_t *) dbdata;
 726 #ifdef MULTIPLICITY
 727         PerlInterpreter *my_perl = cd->perl;
 728 #endif
 729
 730         cd->log(ISC_LOG_INFO, "DLZ Perl: Unloading driver.");
 731
 732 #ifndef MULTIPLICITY
 733         if (!global_perl_dont_free) {
 734 #endif
 735                 PERL_SET_CONTEXT(cd->perl);
 736                 PL_perl_destruct_level = 1;
 737                 perl_destruct(cd->perl);
 738                 perl_free(cd->perl);
 739 #ifndef MULTIPLICITY
 740                 global_perl_dont_free = 0;
 741                 global_perl = NULL;
 742         }
 743 #endif
 744
 745         free(cd->perl_source);
 746         free(cd);
 747 }