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
xs_init(pTHX)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 */
b9_add_helper(config_data_t * state,const char * helper_name,void * ptr)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
dlz_version(unsigned int * flags)153 int dlz_version(unsigned int *flags) {
154 return DLZ_DLOPEN_VERSION;
155 }
156
dlz_allnodes(const char * zone,void * dbdata,dns_sdlzallnodes_t * allnodes)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
dlz_allowzonexfr(void * dbdata,const char * name,const char * client)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
dlz_findzonedb(void * dbdata,const char * name)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
dlz_lookup(const char * zone,const char * name,void * dbdata,dns_sdlzlookup_t * lookup)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
missing_perl_method(const char * perl_class_name,PerlInterpreter * my_perl)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
dlz_create(const char * dlzname,unsigned int argc,char * argv[],void ** dbdata,...)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
dlz_destroy(void * dbdata)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 }
748