summaryrefslogtreecommitdiffstats
path: root/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-05-05 18:37:14 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-05-05 18:37:14 +0000
commitea648e70a989cca190cd7403fe892fd2dcc290b4 (patch)
treee2b6b1c647da68b0d4d66082835e256eb30970e8 /contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs
parentInitial commit. (diff)
downloadbind9-ea648e70a989cca190cd7403fe892fd2dcc290b4.tar.xz
bind9-ea648e70a989cca190cd7403fe892fd2dcc290b4.zip
Adding upstream version 1:9.11.5.P4+dfsg.upstream/1%9.11.5.P4+dfsgupstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs')
-rw-r--r--contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs81
1 files changed, 81 insertions, 0 deletions
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..fd341d9
--- /dev/null
+++ b/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs
@@ -0,0 +1,81 @@
+/*
+ * Copyright (C) 2012 John Eaglesham
+ *
+ * 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 JOHN EAGLESHAM
+ * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+ * JOHN EAGLESHAM 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)));
+