summaryrefslogtreecommitdiffstats
path: root/contrib/dlz/modules/perl
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-27 07:24:22 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-27 07:24:22 +0000
commit45d6379135504814ab723b57f0eb8be23393a51d (patch)
treed4f2ec4acca824a8446387a758b0ce4238a4dffa /contrib/dlz/modules/perl
parentInitial commit. (diff)
downloadbind9-45d6379135504814ab723b57f0eb8be23393a51d.tar.xz
bind9-45d6379135504814ab723b57f0eb8be23393a51d.zip
Adding upstream version 1:9.16.44.upstream/1%9.16.44upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'contrib/dlz/modules/perl')
-rw-r--r--contrib/dlz/modules/perl/Makefile63
-rw-r--r--contrib/dlz/modules/perl/README38
-rw-r--r--contrib/dlz/modules/perl/dlz_perl_callback.xs88
-rw-r--r--contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs94
-rw-r--r--contrib/dlz/modules/perl/dlz_perl_driver.c715
-rw-r--r--contrib/dlz/modules/perl/dlz_perl_driver.h37
-rw-r--r--contrib/dlz/modules/perl/testing/dlz_perl_example.pm185
-rw-r--r--contrib/dlz/modules/perl/testing/named.conf26
8 files changed, 1246 insertions, 0 deletions
diff --git a/contrib/dlz/modules/perl/Makefile b/contrib/dlz/modules/perl/Makefile
new file mode 100644
index 0000000..ec99e00
--- /dev/null
+++ b/contrib/dlz/modules/perl/Makefile
@@ -0,0 +1,63 @@
+# Copyright Internet Systems Consortium, Inc. ("ISC")
+#
+# This Source Code Form is subject to the terms of the Mozilla Public
+# License, v. 2.0. If a copy of the MPL was not distributed with this
+# file, you can obtain one at https://mozilla.org/MPL/2.0/.
+
+# Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+# Copyright (C) John Eaglesham
+#
+# The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+# conceived and contributed by Rob Butler.
+#
+# SPDX-License-Identifier: ISC and MPL-2.0
+#
+# Permission to use, copy, modify, and distribute this software for any purpose
+# with or without fee is hereby granted, provided that the above copyright
+# notice and this permission notice appear in all copies.
+#
+# THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET DISCLAIMS ALL WARRANTIES
+# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL STICHTING NLNET BE LIABLE FOR
+# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
+# OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+# For building the dlz_perl_driver driver we don't use
+# the bind9 build structure as the aim is to provide an
+# perl_driver that is separable from the bind9 source tree
+
+CFLAGS += -fPIC -O2 -I../include
+FLAGS_PERL ?= perl
+LIBNAME = dlz_perl_driver.so
+
+all: $(LIBNAME)
+
+dlz_perl_driver.o: dlz_perl_driver.c
+ $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_driver.o dlz_perl_driver.c
+
+
+dlz_perl_callback_clientinfo.c: dlz_perl_callback_clientinfo.xs
+ ${FLAGS_PERL} `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/xsubpp -prototypes -typemap `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/typemap dlz_perl_callback_clientinfo.xs > dlz_perl_callback_clientinfo.c
+
+dlz_perl_callback_clientinfo.o: dlz_perl_callback_clientinfo.c
+ $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_callback_clientinfo.o dlz_perl_callback_clientinfo.c
+
+
+dlz_perl_callback.c: dlz_perl_callback.xs
+ ${FLAGS_PERL} `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/xsubpp -prototypes -typemap `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/typemap dlz_perl_callback.xs > dlz_perl_callback.c
+
+dlz_perl_callback.o: dlz_perl_callback.c
+ $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_callback.o dlz_perl_callback.c
+
+
+$(LIBNAME): dlz_perl_driver.o dlz_perl_callback_clientinfo.o dlz_perl_callback.o
+ $(CC) $(LDFLAGS) -shared -o $(LIBNAME) dlz_perl_driver.o dlz_perl_callback_clientinfo.o dlz_perl_callback.o `${FLAGS_PERL} -MExtUtils::Embed -e ldopts`
+
+clean:
+ rm -f dlz_perl_driver.o dlz_perl_driver.so dlz_perl_callback_clientinfo.c dlz_perl_callback_clientinfo.o dlz_perl_callback.c dlz_perl_callback.o
+
+install: dlz_perl_driver.so
+ mkdir -p $(DESTDIR)$(libdir)
+ install dlz_perl_driver.so $(DESTDIR)$(libdir)
diff --git a/contrib/dlz/modules/perl/README b/contrib/dlz/modules/perl/README
new file mode 100644
index 0000000..324054a
--- /dev/null
+++ b/contrib/dlz/modules/perl/README
@@ -0,0 +1,38 @@
+<!--
+Copyright Internet Systems Consortium, Inc. ("ISC")
+
+This Source Code Form is subject to the terms of the Mozilla Public
+License, v. 2.0. If a copy of the MPL was not distributed with this
+file, you can obtain one at https://mozilla.org/MPL/2.0/.
+
+Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+Copyright (C) John Eaglesham
+
+The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+conceived and contributed by Rob Butler.
+
+SPDX-License-Identifier: ISC and MPL-2.0
+
+Permission to use, copy, modify, and distribute this software for any purpose
+with or without fee is hereby granted, provided that the above copyright
+notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL STICHTING NLNET BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
+OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+-->
+
+
+BIND 9 DLZ Perl module (bind-dlz-tools)
+
+Written by John Eaglesham <dns@8192.net>
+
+A dynamically loadable zone (DLZ) plugin embedding a Perl
+interpreter in BIND, allowing Perl scripts to be written to
+integrate with BIND and serve DNS data.
+
+More information/updates at http://bind-dlz-tools.sourceforge.net/
diff --git a/contrib/dlz/modules/perl/dlz_perl_callback.xs b/contrib/dlz/modules/perl/dlz_perl_callback.xs
new file mode 100644
index 0000000..0b9f504
--- /dev/null
+++ b/contrib/dlz/modules/perl/dlz_perl_callback.xs
@@ -0,0 +1,88 @@
+/*
+ * Copyright (C) Internet Systems Consortium, Inc. ("ISC")
+ *
+ * SPDX-License-Identifier: MPL-2.0 and ISC
+ *
+ * This Source Code Form is subject to the terms of the Mozilla Public
+ * License, v. 2.0. If a copy of the MPL was not distributed with this
+ * file, you can obtain one at https://mozilla.org/MPL/2.0/.
+ */
+
+/*
+ * Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+ * Copyright (C) John Eaglesham
+ *
+ * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+ * conceived and contributed by Rob Butler.
+ *
+ * Permission to use, copy, modify, and distribute this software for any purpose
+ * with or without fee is hereby granted, provided that the above copyright
+ * notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+ * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+ * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+ * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "dlz_perl_driver.h"
+
+#include <dlz_minimal.h>
+
+/* And some XS code. */
+MODULE = DLZ_Perl PACKAGE = DLZ_Perl
+
+int
+LOG_INFO()
+ CODE:
+ RETVAL = ISC_LOG_INFO;
+ OUTPUT:
+ RETVAL
+
+int
+LOG_NOTICE()
+ CODE:
+ RETVAL = ISC_LOG_NOTICE;
+ OUTPUT:
+ RETVAL
+
+int
+LOG_WARNING()
+ CODE:
+ RETVAL = ISC_LOG_WARNING;
+ OUTPUT:
+ RETVAL
+
+int
+LOG_ERROR()
+ CODE:
+ RETVAL = ISC_LOG_ERROR;
+ OUTPUT:
+ RETVAL
+
+int
+LOG_CRITICAL()
+ CODE:
+ RETVAL = ISC_LOG_CRITICAL;
+ OUTPUT:
+ RETVAL
+
+
+void
+log(opaque, level, msg)
+ IV opaque
+ int level
+ char *msg
+
+ PREINIT:
+ log_t *log = (log_t *) opaque;
+
+ CODE:
+ log( level, msg );
+
diff --git a/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs b/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs
new file mode 100644
index 0000000..22aec66
--- /dev/null
+++ b/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs
@@ -0,0 +1,94 @@
+/*
+ * Copyright (C) Internet Systems Consortium, Inc. ("ISC")
+ *
+ * SPDX-License-Identifier: MPL-2.0 and ISC
+ *
+ * This Source Code Form is subject to the terms of the Mozilla Public
+ * License, v. 2.0. If a copy of the MPL was not distributed with this
+ * file, you can obtain one at https://mozilla.org/MPL/2.0/.
+ */
+
+/*
+ * Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+ * Copyright (C) John Eaglesham
+ *
+ * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+ * conceived and contributed by Rob Butler.
+ *
+ * Permission to use, copy, modify, and distribute this software for any purpose
+ * with or without fee is hereby granted, provided that the above copyright
+ * notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+ * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+ * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+ * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ */
+
+#define ADDR_BUF_LEN INET6_ADDRSTRLEN
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "dlz_perl_driver.h"
+
+#include <dlz_minimal.h>
+
+/* And some XS code. */
+MODULE = DLZ_Perl::clientinfo PACKAGE = DLZ_Perl::clientinfo
+
+PROTOTYPES: DISABLE
+
+void
+sourceip(opaque)
+ SV *opaque
+
+ PREINIT:
+ const char *ret;
+ char addr_buf[ADDR_BUF_LEN];
+ int port;
+ isc_sockaddr_t *src;
+ dlz_perl_clientinfo_opaque *ci;
+ I32 wantarray = GIMME_V;
+
+ PPCODE:
+ if (!SvTRUE(opaque) || !SvIOK(opaque)) XSRETURN_EMPTY;
+
+ /*
+ * Safe, because Perl guarantees that an IV (the type we
+ * pass into DLZ functions who pass it here) is able to
+ * hold a pointer.
+ */
+ ci = (dlz_perl_clientinfo_opaque *) SvIV(opaque);
+ if (wantarray == G_VOID || ci->methods == NULL ||
+ ci->methods->version - ci->methods->age <
+ DNS_CLIENTINFOMETHODS_VERSION)
+ XSRETURN_EMPTY;
+
+ ci->methods->sourceip(ci->clientinfo, &src);
+
+ switch (src->type.sa.sa_family) {
+ case AF_INET:
+ port = ntohs(src->type.sin.sin_port);
+ ret = inet_ntop(AF_INET,
+ &src->type.sin.sin_addr,
+ addr_buf, ADDR_BUF_LEN);
+ break;
+ case AF_INET6:
+ port = ntohs(src->type.sin6.sin6_port);
+ ret = inet_ntop(AF_INET6,
+ &src->type.sin6.sin6_addr,
+ addr_buf, ADDR_BUF_LEN);
+ break;
+ default:
+ ret = NULL;
+ }
+
+ if (ret == NULL) XSRETURN_EMPTY;
+
+ XPUSHs(sv_2mortal(newSVpv(addr_buf, strlen(addr_buf))));
+ if (wantarray == G_ARRAY) XPUSHs(sv_2mortal(newSViv(port)));
+
diff --git a/contrib/dlz/modules/perl/dlz_perl_driver.c b/contrib/dlz/modules/perl/dlz_perl_driver.c
new file mode 100644
index 0000000..b99b296
--- /dev/null
+++ b/contrib/dlz/modules/perl/dlz_perl_driver.c
@@ -0,0 +1,715 @@
+/*
+ * Copyright (C) Internet Systems Consortium, Inc. ("ISC")
+ *
+ * SPDX-License-Identifier: MPL-2.0 and ISC
+ *
+ * This Source Code Form is subject to the terms of the Mozilla Public
+ * License, v. 2.0. If a copy of the MPL was not distributed with this
+ * file, you can obtain one at https://mozilla.org/MPL/2.0/.
+ */
+
+/*
+ * Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+ * Copyright (C) John Eaglesham
+ *
+ * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+ * conceived and contributed by Rob Butler.
+ *
+ * Permission to use, copy, modify, and distribute this software for any purpose
+ * with or without fee is hereby granted, provided that the above copyright
+ * notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+ * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+ * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+ * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ */
+
+#include "dlz_perl_driver.h"
+#include <EXTERN.h>
+#include <perl.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <dlz_minimal.h>
+
+#define BUF_LEN 64 /* Should be big enough, right? hah */
+
+/* Enable debug logging? */
+#if 0
+#define carp(...) cd->log(ISC_LOG_INFO, __VA_ARGS__);
+#else /* if 0 */
+#define carp(...)
+#endif /* if 0 */
+
+#ifndef MULTIPLICITY
+/* This is a pretty terrible work-around for handling HUP/rndc reconfig, but
+ * the way BIND/DLZ handles reloads causes it to create a second back end
+ * before removing the first. In the case of a single global interpreter,
+ * serious problems arise. We can hack around this, but it's much better to do
+ * it properly and link against a perl compiled with multiplicity. */
+static PerlInterpreter *global_perl = NULL;
+static int global_perl_dont_free = 0;
+#endif /* ifndef MULTIPLICITY */
+
+typedef struct config_data {
+ PerlInterpreter *perl;
+ char *perl_source;
+ SV *perl_class;
+
+ /* Functions given to us by bind9 */
+ log_t *log;
+ dns_sdlz_putrr_t *putrr;
+ dns_sdlz_putnamedrr_t *putnamedrr;
+ dns_dlz_writeablezone_t *writeable_zone;
+} config_data_t;
+
+/* Note, this code generates warnings due to lost type qualifiers. This code
+ * is (almost) verbatim from perlembed, and is known to work correctly despite
+ * the warnings.
+ */
+EXTERN_C void xs_init(pTHX);
+EXTERN_C void
+boot_DynaLoader(pTHX_ CV *cv);
+EXTERN_C void
+boot_DLZ_Perl__clientinfo(pTHX_ CV *cv);
+EXTERN_C void
+boot_DLZ_Perl(pTHX_ CV *cv);
+EXTERN_C void
+xs_init(pTHX) {
+ const char *file = __FILE__;
+ dXSUB_SYS;
+
+ /* DynaLoader is a special case */
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("DLZ_Perl::clientinfo::bootstrap", boot_DLZ_Perl__clientinfo,
+ file);
+ newXS("DLZ_Perl::bootstrap", boot_DLZ_Perl, file);
+}
+
+/*
+ * methods
+ */
+
+/*
+ * remember a helper function, from the bind9 dlz_dlopen driver
+ */
+static void
+b9_add_helper(config_data_t *state, const char *helper_name, void *ptr) {
+ if (strcmp(helper_name, "log") == 0) {
+ state->log = ptr;
+ }
+ if (strcmp(helper_name, "putrr") == 0) {
+ state->putrr = ptr;
+ }
+ if (strcmp(helper_name, "putnamedrr") == 0) {
+ state->putnamedrr = ptr;
+ }
+ if (strcmp(helper_name, "writeable_zone") == 0) {
+ state->writeable_zone = ptr;
+ }
+}
+
+int
+dlz_version(unsigned int *flags) {
+ UNUSED(flags);
+ return (DLZ_DLOPEN_VERSION);
+}
+
+isc_result_t
+dlz_allnodes(const char *zone, void *dbdata, dns_sdlzallnodes_t *allnodes) {
+ config_data_t *cd = (config_data_t *)dbdata;
+ isc_result_t retval;
+ int rrcount, r;
+ SV *record_ref;
+ SV **rr_name;
+ SV **rr_type;
+ SV **rr_ttl;
+ SV **rr_data;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+ dSP;
+
+ PERL_SET_CONTEXT(cd->perl);
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(cd->perl_class);
+ XPUSHs(sv_2mortal(newSVpv(zone, 0)));
+ PUTBACK;
+
+ carp("DLZ Perl: Calling allnodes for zone %s", zone);
+ rrcount = call_method("allnodes", G_ARRAY | G_EVAL);
+ carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount);
+
+ SPAGAIN;
+
+ if (SvTRUE(ERRSV)) {
+ (void)POPs;
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: allnodes for zone %s died in eval: %s", zone,
+ SvPV_nolen(ERRSV));
+ retval = ISC_R_FAILURE;
+ goto CLEAN_UP_AND_RETURN;
+ }
+
+ if (!rrcount) {
+ retval = ISC_R_NOTFOUND;
+ goto CLEAN_UP_AND_RETURN;
+ }
+
+ retval = ISC_R_SUCCESS;
+ r = 0;
+ while (r++ < rrcount) {
+ record_ref = POPs;
+ if ((!SvROK(record_ref)) ||
+ (SvTYPE(SvRV(record_ref)) != SVt_PVAV))
+ {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: allnodes for zone %s "
+ "returned an invalid value "
+ "(expected array of arrayrefs)",
+ zone);
+ retval = ISC_R_FAILURE;
+ break;
+ }
+
+ record_ref = SvRV(record_ref);
+
+ rr_name = av_fetch((AV *)record_ref, 0, 0);
+ rr_type = av_fetch((AV *)record_ref, 1, 0);
+ rr_ttl = av_fetch((AV *)record_ref, 2, 0);
+ rr_data = av_fetch((AV *)record_ref, 3, 0);
+
+ if (rr_name == NULL || rr_type == NULL || rr_ttl == NULL ||
+ rr_data == NULL)
+ {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: allnodes for zone %s "
+ "returned an array that was missing data",
+ zone);
+ retval = ISC_R_FAILURE;
+ break;
+ }
+
+ carp("DLZ Perl: Got record %s/%s = %s", SvPV_nolen(*rr_name),
+ SvPV_nolen(*rr_type), SvPV_nolen(*rr_data));
+ retval = cd->putnamedrr(allnodes, SvPV_nolen(*rr_name),
+ SvPV_nolen(*rr_type), SvIV(*rr_ttl),
+ SvPV_nolen(*rr_data));
+ if (retval != ISC_R_SUCCESS) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: putnamedrr in allnodes "
+ "for zone %s failed with code %i "
+ "(did lookup return invalid record data?)",
+ zone, retval);
+ break;
+ }
+ }
+
+CLEAN_UP_AND_RETURN:
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ carp("DLZ Perl: Returning from allnodes, r = %i, retval = %i", r,
+ retval);
+
+ return (retval);
+}
+
+isc_result_t
+dlz_allowzonexfr(void *dbdata, const char *name, const char *client) {
+ config_data_t *cd = (config_data_t *)dbdata;
+ int r;
+ isc_result_t retval;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+ dSP;
+
+ PERL_SET_CONTEXT(cd->perl);
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(cd->perl_class);
+ XPUSHs(sv_2mortal(newSVpv(name, 0)));
+ XPUSHs(sv_2mortal(newSVpv(client, 0)));
+ PUTBACK;
+
+ r = call_method("allowzonexfr", G_SCALAR | G_EVAL);
+ SPAGAIN;
+
+ if (SvTRUE(ERRSV)) {
+ /*
+ * On error there's an undef at the top of the stack. Pop
+ * it away so we don't leave junk on the stack for the next
+ * caller.
+ */
+ (void)POPs;
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: allowzonexfr died in eval: %s",
+ SvPV_nolen(ERRSV));
+ retval = ISC_R_FAILURE;
+ } else if (r == 0) {
+ /* Client returned nothing -- zone not found. */
+ retval = ISC_R_NOTFOUND;
+ } else if (r > 1) {
+ /* Once again, clean out the stack when possible. */
+ while (r--) {
+ POPi;
+ }
+ cd->log(ISC_LOG_ERROR, "DLZ Perl: allowzonexfr returned too "
+ "many parameters!");
+ retval = ISC_R_FAILURE;
+ } else {
+ /*
+ * Client returned true/false -- we're authoritative for
+ * the zone.
+ */
+ r = POPi;
+ if (r) {
+ retval = ISC_R_SUCCESS;
+ } else {
+ retval = ISC_R_NOPERM;
+ }
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return (retval);
+}
+
+#if DLZ_DLOPEN_VERSION < 3
+isc_result_t
+dlz_findzonedb(void *dbdata, const char *name)
+#else /* if DLZ_DLOPEN_VERSION < 3 */
+isc_result_t
+dlz_findzonedb(void *dbdata, const char *name, dns_clientinfomethods_t *methods,
+ dns_clientinfo_t *clientinfo)
+#endif /* if DLZ_DLOPEN_VERSION < 3 */
+{
+ config_data_t *cd = (config_data_t *)dbdata;
+ int r;
+ isc_result_t retval;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+
+#if DLZ_DLOPEN_VERSION >= 3
+ UNUSED(methods);
+ UNUSED(clientinfo);
+#endif /* if DLZ_DLOPEN_VERSION >= 3 */
+
+ dSP;
+ carp("DLZ Perl: findzone looking for '%s'", name);
+
+ PERL_SET_CONTEXT(cd->perl);
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(cd->perl_class);
+ XPUSHs(sv_2mortal(newSVpv(name, 0)));
+ PUTBACK;
+
+ r = call_method("findzone", G_SCALAR | G_EVAL);
+ SPAGAIN;
+
+ if (SvTRUE(ERRSV)) {
+ /*
+ * On error there's an undef at the top of the stack. Pop
+ * it away so we don't leave junk on the stack for the next
+ * caller.
+ */
+ (void)POPs;
+ cd->log(ISC_LOG_ERROR, "DLZ Perl: findzone died in eval: %s",
+ SvPV_nolen(ERRSV));
+ retval = ISC_R_FAILURE;
+ } else if (r == 0) {
+ retval = ISC_R_FAILURE;
+ } else if (r > 1) {
+ /* Once again, clean out the stack when possible. */
+ while (r--) {
+ POPi;
+ }
+ cd->log(ISC_LOG_ERROR, "DLZ Perl: findzone returned too many "
+ "parameters!");
+ retval = ISC_R_FAILURE;
+ } else {
+ r = POPi;
+ if (r) {
+ retval = ISC_R_SUCCESS;
+ } else {
+ retval = ISC_R_NOTFOUND;
+ }
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return (retval);
+}
+
+#if DLZ_DLOPEN_VERSION == 1
+isc_result_t
+dlz_lookup(const char *zone, const char *name, void *dbdata,
+ dns_sdlzlookup_t *lookup)
+#else /* if DLZ_DLOPEN_VERSION == 1 */
+isc_result_t
+dlz_lookup(const char *zone, const char *name, void *dbdata,
+ dns_sdlzlookup_t *lookup, dns_clientinfomethods_t *methods,
+ dns_clientinfo_t *clientinfo)
+#endif /* if DLZ_DLOPEN_VERSION == 1 */
+{
+ isc_result_t retval;
+ config_data_t *cd = (config_data_t *)dbdata;
+ int rrcount, r;
+ dlz_perl_clientinfo_opaque opaque;
+ SV *record_ref;
+ SV **rr_type;
+ SV **rr_ttl;
+ SV **rr_data;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+
+#if DLZ_DLOPEN_VERSION >= 2
+ UNUSED(methods);
+ UNUSED(clientinfo);
+#endif /* if DLZ_DLOPEN_VERSION >= 2 */
+
+ dSP;
+ PERL_SET_CONTEXT(cd->perl);
+ ENTER;
+ SAVETMPS;
+
+ opaque.methods = methods;
+ opaque.clientinfo = clientinfo;
+
+ PUSHMARK(SP);
+ XPUSHs(cd->perl_class);
+ XPUSHs(sv_2mortal(newSVpv(name, 0)));
+ XPUSHs(sv_2mortal(newSVpv(zone, 0)));
+ XPUSHs(sv_2mortal(newSViv((IV)&opaque)));
+ PUTBACK;
+
+ carp("DLZ Perl: Searching for name %s in zone %s", name, zone);
+ rrcount = call_method("lookup", G_ARRAY | G_EVAL);
+ carp("DLZ Perl: Call to lookup returned %i", rrcount);
+
+ SPAGAIN;
+
+ if (SvTRUE(ERRSV)) {
+ (void)POPs;
+ cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s",
+ SvPV_nolen(ERRSV));
+ retval = ISC_R_FAILURE;
+ goto CLEAN_UP_AND_RETURN;
+ }
+
+ if (!rrcount) {
+ retval = ISC_R_NOTFOUND;
+ goto CLEAN_UP_AND_RETURN;
+ }
+
+ retval = ISC_R_SUCCESS;
+ r = 0;
+ while (r++ < rrcount) {
+ record_ref = POPs;
+ if ((!SvROK(record_ref)) ||
+ (SvTYPE(SvRV(record_ref)) != SVt_PVAV))
+ {
+ cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup returned an "
+ "invalid value (expected array "
+ "of arrayrefs)!");
+ retval = ISC_R_FAILURE;
+ break;
+ }
+
+ record_ref = SvRV(record_ref);
+
+ rr_type = av_fetch((AV *)record_ref, 0, 0);
+ rr_ttl = av_fetch((AV *)record_ref, 1, 0);
+ rr_data = av_fetch((AV *)record_ref, 2, 0);
+
+ if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: lookup for record %s in "
+ "zone %s returned an array that was "
+ "missing data",
+ name, zone);
+ retval = ISC_R_FAILURE;
+ break;
+ }
+
+ carp("DLZ Perl: Got record %s = %s", SvPV_nolen(*rr_type),
+ SvPV_nolen(*rr_data));
+ retval = cd->putrr(lookup, SvPV_nolen(*rr_type), SvIV(*rr_ttl),
+ SvPV_nolen(*rr_data));
+
+ if (retval != ISC_R_SUCCESS) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl: putrr for lookup of %s in "
+ "zone %s failed with code %i "
+ "(did lookup return invalid record data?)",
+ name, zone, retval);
+ break;
+ }
+ }
+
+CLEAN_UP_AND_RETURN:
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ carp("DLZ Perl: Returning from lookup, r = %i, retval = %i", r, retval);
+
+ return (retval);
+}
+
+static const char *
+#ifdef MULTIPLICITY
+missing_perl_method(const char *perl_class_name, PerlInterpreter *my_perl)
+#else /* ifdef MULTIPLICITY */
+missing_perl_method(const char *perl_class_name)
+#endif /* ifdef MULTIPLICITY */
+{
+ char full_name[BUF_LEN];
+ const char *methods[] = { "new", "findzone", "lookup", NULL };
+ int i = 0;
+
+ while (methods[i] != NULL) {
+ snprintf(full_name, BUF_LEN, "%s::%s", perl_class_name,
+ methods[i]);
+
+ if (get_cv(full_name, 0) == NULL) {
+ return (methods[i]);
+ }
+ i++;
+ }
+
+ return (NULL);
+}
+
+isc_result_t
+dlz_create(const char *dlzname, unsigned int argc, char *argv[], void **dbdata,
+ ...) {
+ config_data_t *cd;
+ char *perlrun[] = { (char *)"", NULL, (char *)"dlz perl", NULL };
+ char *perl_class_name;
+ int r;
+ va_list ap;
+ const char *helper_name;
+ const char *missing_method_name;
+ char *call_argv_args = NULL;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl;
+#endif /* ifdef MULTIPLICITY */
+
+ cd = malloc(sizeof(config_data_t));
+ if (cd == NULL) {
+ return (ISC_R_NOMEMORY);
+ }
+
+ memset(cd, 0, sizeof(config_data_t));
+
+ /* fill in the helper functions */
+ va_start(ap, dbdata);
+ while ((helper_name = va_arg(ap, const char *)) != NULL) {
+ b9_add_helper(cd, helper_name, va_arg(ap, void *));
+ }
+ va_end(ap);
+
+ if (argc < 2) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': Missing script argument.", dlzname);
+ free(cd);
+ return (ISC_R_FAILURE);
+ }
+
+ if (argc < 3) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': Missing class name argument.", dlzname);
+ free(cd);
+ return (ISC_R_FAILURE);
+ }
+ perl_class_name = argv[2];
+
+ cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'",
+ dlzname, perl_class_name, argv[1], argc);
+
+#ifndef MULTIPLICITY
+ if (global_perl) {
+ /*
+ * PERL_SET_CONTEXT not needed here as we're guaranteed to
+ * have an implicit context thanks to an undefined
+ * MULTIPLICITY.
+ */
+ PL_perl_destruct_level = 1;
+ perl_destruct(global_perl);
+ perl_free(global_perl);
+ global_perl = NULL;
+ global_perl_dont_free = 1;
+ }
+#endif /* ifndef MULTIPLICITY */
+
+ cd->perl = perl_alloc();
+ if (cd->perl == NULL) {
+ free(cd);
+ return (ISC_R_FAILURE);
+ }
+#ifdef MULTIPLICITY
+ my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+ PERL_SET_CONTEXT(cd->perl);
+
+ /*
+ * We will re-create the interpreter during an rndc reconfig, so we
+ * must set this variable per perlembed in order to insure we can
+ * clean up Perl at a later time.
+ */
+ PL_perl_destruct_level = 1;
+ perl_construct(cd->perl);
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+ /* Prevent crashes from clients writing to $0 */
+ PL_origalen = 1;
+
+ cd->perl_source = strdup(argv[1]);
+ if (cd->perl_source == NULL) {
+ free(cd);
+ return (ISC_R_NOMEMORY);
+ }
+
+ perlrun[1] = cd->perl_source;
+ if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': Failed to parse Perl script, aborting",
+ dlzname);
+ goto CLEAN_UP_PERL_AND_FAIL;
+ }
+
+ /* Let Perl know about our callbacks. */
+ call_argv("DLZ_Perl::clientinfo::bootstrap", G_DISCARD | G_NOARGS,
+ &call_argv_args);
+ call_argv("DLZ_Perl::bootstrap", G_DISCARD | G_NOARGS, &call_argv_args);
+
+ /*
+ * Run the script. We don't really need to do this since we have
+ * the init callback, but there's not really a downside either.
+ */
+ if (perl_run(cd->perl)) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': Script exited with an error, aborting",
+ dlzname);
+ goto CLEAN_UP_PERL_AND_FAIL;
+ }
+
+#ifdef MULTIPLICITY
+ if ((missing_method_name = missing_perl_method(perl_class_name,
+ my_perl)))
+#else /* ifdef MULTIPLICITY */
+ if ((missing_method_name = missing_perl_method(perl_class_name)))
+#endif /* ifdef MULTIPLICITY */
+ {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': Missing required function '%s', "
+ "aborting",
+ dlzname, missing_method_name);
+ goto CLEAN_UP_PERL_AND_FAIL;
+ }
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));
+
+ /* Build flattened hash of config info. */
+ XPUSHs(sv_2mortal(newSVpv("log_context", 0)));
+ XPUSHs(sv_2mortal(newSViv((IV)cd->log)));
+
+ /* Argument to pass to new? */
+ if (argc == 4) {
+ XPUSHs(sv_2mortal(newSVpv("argv", 0)));
+ XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));
+ }
+
+ PUTBACK;
+
+ r = call_method("new", G_EVAL | G_SCALAR);
+
+ SPAGAIN;
+
+ if (r) {
+ cd->perl_class = SvREFCNT_inc(POPs);
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ if (SvTRUE(ERRSV)) {
+ (void)POPs;
+ cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': new died in eval: %s",
+ dlzname, SvPV_nolen(ERRSV));
+ goto CLEAN_UP_PERL_AND_FAIL;
+ }
+
+ if (!r || !sv_isobject(cd->perl_class)) {
+ cd->log(ISC_LOG_ERROR,
+ "DLZ Perl '%s': new failed to return a blessed object",
+ dlzname);
+ goto CLEAN_UP_PERL_AND_FAIL;
+ }
+
+ *dbdata = cd;
+
+#ifndef MULTIPLICITY
+ global_perl = cd->perl;
+#endif /* ifndef MULTIPLICITY */
+ return (ISC_R_SUCCESS);
+
+CLEAN_UP_PERL_AND_FAIL:
+ PL_perl_destruct_level = 1;
+ perl_destruct(cd->perl);
+ perl_free(cd->perl);
+ free(cd->perl_source);
+ free(cd);
+ return (ISC_R_FAILURE);
+}
+
+void
+dlz_destroy(void *dbdata) {
+ config_data_t *cd = (config_data_t *)dbdata;
+#ifdef MULTIPLICITY
+ PerlInterpreter *my_perl = cd->perl;
+#endif /* ifdef MULTIPLICITY */
+
+ cd->log(ISC_LOG_INFO, "DLZ Perl: Unloading driver.");
+
+#ifndef MULTIPLICITY
+ if (!global_perl_dont_free) {
+#endif /* ifndef MULTIPLICITY */
+ PERL_SET_CONTEXT(cd->perl);
+ PL_perl_destruct_level = 1;
+ perl_destruct(cd->perl);
+ perl_free(cd->perl);
+#ifndef MULTIPLICITY
+ global_perl_dont_free = 0;
+ global_perl = NULL;
+ }
+#endif /* ifndef MULTIPLICITY */
+
+ free(cd->perl_source);
+ free(cd);
+}
diff --git a/contrib/dlz/modules/perl/dlz_perl_driver.h b/contrib/dlz/modules/perl/dlz_perl_driver.h
new file mode 100644
index 0000000..2cfb24d
--- /dev/null
+++ b/contrib/dlz/modules/perl/dlz_perl_driver.h
@@ -0,0 +1,37 @@
+/*
+ * Copyright (C) Internet Systems Consortium, Inc. ("ISC")
+ *
+ * SPDX-License-Identifier: MPL-2.0 and ISC
+ *
+ * This Source Code Form is subject to the terms of the Mozilla Public
+ * License, v. 2.0. If a copy of the MPL was not distributed with this
+ * file, you can obtain one at https://mozilla.org/MPL/2.0/.
+ */
+
+/*
+ * Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+ * Copyright (C) John Eaglesham
+ *
+ * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+ * conceived and contributed by Rob Butler.
+ *
+ * Permission to use, copy, modify, and distribute this software for any purpose
+ * with or without fee is hereby granted, provided that the above copyright
+ * notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+ * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+ * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+ * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ */
+
+#include <dlz_minimal.h>
+
+/* This is the only part that differs from dlz_minimal.h. */
+typedef struct dlz_perl_clientinfo_opaque {
+ dns_clientinfomethods_t *methods;
+ dns_clientinfo_t *clientinfo;
+} dlz_perl_clientinfo_opaque;
diff --git a/contrib/dlz/modules/perl/testing/dlz_perl_example.pm b/contrib/dlz/modules/perl/testing/dlz_perl_example.pm
new file mode 100644
index 0000000..eafa87c
--- /dev/null
+++ b/contrib/dlz/modules/perl/testing/dlz_perl_example.pm
@@ -0,0 +1,185 @@
+# Copyright Internet Systems Consortium, Inc. ("ISC")
+#
+# This Source Code Form is subject to the terms of the Mozilla Public
+# License, v. 2.0. If a copy of the MPL was not distributed with this
+# file, you can obtain one at https://mozilla.org/MPL/2.0/.
+
+# Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl.
+# Copyright (C) John Eaglesham
+#
+# The development of Dynamically Loadable Zones (DLZ) for Bind 9 was
+# conceived and contributed by Rob Butler.
+#
+# SPDX-License-Identifier: ISC and MPL-2.0
+#
+# Permission to use, copy, modify, and distribute this software for any purpose
+# with or without fee is hereby granted, provided that the above copyright
+# notice and this permission notice appear in all copies.
+#
+# THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET DISCLAIMS ALL WARRANTIES
+# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL STICHTING NLNET BE LIABLE FOR
+# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
+# OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+package dlz_perl_example;
+
+use warnings;
+use strict;
+
+use Data::Dumper;
+$Data::Dumper::Sortkeys = 1;
+
+# Constructor. Everything after the class name can be folded into a hash of
+# various options and settings. Right now only log_context and argv are
+# available.
+sub new {
+ my ( $class, %config ) = @_;
+ my $self = {};
+ bless $self, $class;
+
+ $self->{log} = sub {
+ my ( $level, $msg ) = @_;
+ DLZ_Perl::log( $config{log_context}, $level, $msg );
+ };
+
+ if ( $config{argv} ) { warn "Got argv: $config{argv}\n"; }
+
+ $self->{zones} = {
+ 'example.com' => {
+ '@' => [
+ {
+ type => 'SOA',
+ ttl => 86400,
+ data =>
+ 'ns1.example.com. hostmaster.example.com. 12345 172800 900 1209600 3600',
+ }
+ ],
+ perlrr => [
+ {
+ type => 'A',
+ ttl => 444,
+ data => '1.1.1.1',
+ },
+ {
+ type => 'A',
+ ttl => 444,
+ data => '1.1.1.2',
+ }
+ ],
+ perltime => [
+ {
+ code => sub {
+ return ['TXT', '1', time()];
+ },
+ },
+ ],
+ sourceip => [
+ {
+ code => sub {
+ my ( $opaque ) = @_;
+ # Passing anything other than the proper opaque value,
+ # 0, or undef to this function will cause a crash (at
+ # best!).
+ my ( $addr, $port ) =
+ DLZ_Perl::clientinfo::sourceip( $opaque );
+ if ( !$addr ) { $addr = $port = 'unknown'; }
+ return ['TXT', '1', $addr], ['TXT', '1', $port];
+ },
+ },
+ ],
+ },
+ };
+
+ $self->{log}->(
+ DLZ_Perl::LOG_INFO(),
+ 'DLZ Perl Script: Called init. Loaded zone data: '
+ . Dumper( $self->{zones} )
+ );
+ return $self;
+}
+
+# Do we have data for this zone? Expects a simple true or false return value.
+sub findzone {
+ my ( $self, $zone ) = @_;
+ $self->{log}->(
+ DLZ_Perl::LOG_INFO(),
+ "DLZ Perl Script: Called findzone, looking for zone $zone"
+ );
+
+ return exists $self->{zones}->{$zone};
+}
+
+# Return the data for a given record in a given zone. The final parameter is
+# an opaque value that can be passed to DLZ_Perl::clientinfo::sourceip to
+# retrieve the client source IP and port. Expected return value is an array
+# of array refs, with each array ref representing one record and containing
+# the type, ttl, and data in that order. Data is as it appears in a zone file.
+sub lookup {
+ my ( $self, $name, $zone, $client_info ) = @_;
+ $self->{log}->(
+ DLZ_Perl::LOG_INFO(),
+ "DLZ Perl Script: Called lookup, looking for record $name in zone $zone"
+ );
+ return unless $self->{zones}->{$zone}->{$name};
+
+ my @results;
+ foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) {
+ if ( $rr->{'code'} ) {
+ my @r = $rr->{'code'}->( $client_info );
+ if ( @r ) {
+ push @results, @r;
+ }
+ } else {
+ push @results, [$rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}];
+ }
+ }
+
+ return @results;
+}
+
+# Will we allow zone transfer for this client? Expects a simple true or false
+# return value.
+sub allowzonexfr {
+ my ( $self, $zone, $client ) = @_;
+ $self->{log}->(
+ DLZ_Perl::LOG_INFO(),
+ "DLZ Perl Script: Called allowzonexfr, looking for zone $zone for " .
+ "client $client"
+ );
+ if ( $client eq '127.0.0.1' ) { return 1; }
+ return 0;
+}
+
+# Note the return AoA for this method differs from lookup in that it must
+# return the name of the record as well as the other data.
+sub allnodes {
+ my ( $self, $zone ) = @_;
+ my @results;
+ $self->{log}->(
+ DLZ_Perl::LOG_INFO(),
+ "DLZ Perl Script: Called allnodes, looking for zone $zone"
+ );
+
+ foreach my $name ( keys %{ $self->{zones}->{$zone} } ) {
+ foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) {
+ if ( $rr->{'code'} ) {
+ my @r = $rr->{'code'}->();
+ # The code returns an array of array refs without the name.
+ # This makes things easy for lookup but hard here. We must
+ # iterate over each array ref and inject the name into it.
+ foreach my $a ( @r ) {
+ unshift @{$a}, $name;
+ }
+ push @results, @r;
+ } else {
+ push @results,
+ [$name, $rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}];
+ }
+ }
+ }
+ return @results;
+}
+
+1;
diff --git a/contrib/dlz/modules/perl/testing/named.conf b/contrib/dlz/modules/perl/testing/named.conf
new file mode 100644
index 0000000..293d655
--- /dev/null
+++ b/contrib/dlz/modules/perl/testing/named.conf
@@ -0,0 +1,26 @@
+/*
+ * Copyright (C) Internet Systems Consortium, Inc. ("ISC")
+ *
+ * SPDX-License-Identifier: MPL-2.0
+ *
+ * This Source Code Form is subject to the terms of the Mozilla Public
+ * License, v. 2.0. If a copy of the MPL was not distributed with this
+ * file, you can obtain one at https://mozilla.org/MPL/2.0/.
+ *
+ * See the COPYRIGHT file distributed with this work for additional
+ * information regarding copyright ownership.
+ */
+
+options {
+ port 5300;
+ pid-file "named.pid";
+ session-keyfile "session.key";
+ listen-on { 127.0.0.1; };
+ listen-on-v6 { none; };
+ recursion no;
+ notify no;
+};
+
+dlz "perl zone" {
+ database "dlopen ../dlz_perl_driver.so dlz_perl_example.pm dlz_perl_example";
+};