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