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