--- /dev/null
+/* $Id: perl.c 7815 2008-05-05 08:43:58Z iulius $
+**
+** Perl filtering support for innd.
+**
+** Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
+** he wouldn't recognise it anymore so don't blame him) and modified,
+** expanded and tweaked since by James Brister, Jeremy Nixon, Ed Mooring,
+** Russell Vincent, and Russ Allbery.
+**
+** This file should contain all innd-specific Perl linkage. Linkage
+** applicable to both innd and nnrpd should go into lib/perl.c instead.
+**
+** We are assuming Perl 5.004 or later.
+**
+** Future work:
+**
+** - What we're doing with Path headers right now doesn't work for folded
+** headers. It's also kind of gross. There has to be a better way of
+** handling this.
+**
+** - The breakdown between this file, lib/perl.c, and nnrpd/perl.c should
+** be rethought, ideally in the light of supporting multiple filters in
+** different languages.
+**
+** - We're still calling strlen() on artBody, which should be avoidable
+** since we've already walked it several times. We should just cache
+** the length somewhere for speed.
+**
+** - Variable and key names should be standardized between this and nnrpd.
+**
+** - The XS code is still calling CC* functions. The common code between
+** the two control interfaces should be factored out into the rest of
+** innd instead.
+**
+** - There's a needless perl_get_cv() call for *every message ID* offered
+** to the server right now. We need to stash whether that filter is
+** active.
+*/
+
+#include "config.h"
+
+/* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
+#if DO_PERL
+
+#include "clibrary.h"
+#include "innd.h"
+
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#include "ppport.h"
+
+#include "innperl.h"
+
+/* From art.c. Ew. Need header parsing that doesn't use globals. */
+extern char *filterPath;
+
+/*
+** Run an incoming article through the Perl article filter. Returns NULL
+** accept the article or a rejection message to reject it.
+*/
+char *
+PLartfilter(const ARTDATA *data, char *artBody, long artLen, int lines)
+{
+ dSP;
+ const ARTHEADER * hp;
+ const HDRCONTENT *hc = data->HdrContent;
+ HV * hdr;
+ CV * filter;
+ int i, rc;
+ char * p;
+ static SV * body = NULL;
+ static char buf[256];
+
+ if (!PerlFilterActive) return NULL;
+ filter = perl_get_cv("filter_art", 0);
+ if (!filter) return NULL;
+
+ /* Create %hdr and stash a copy of every known header. Path has to be
+ handled separately since it's been munged by article processing. */
+ hdr = perl_get_hv("hdr", 1);
+ for (i = 0 ; i < MAX_ARTHEADER ; i++) {
+ if (HDR_FOUND(i)) {
+ hp = &ARTheaders[i];
+ hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
+ }
+ }
+
+ /* Store the article body. We don't want to make another copy of it,
+ since it could potentially be quite large. Instead, stash the
+ pointer in the static SV * body. We set LEN to 0 and inc the
+ refcount to tell Perl not to free it (either one should be enough).
+ Requires 5.004. In testing, this produced a 17% speed improvement
+ over making a copy of the article body for a fairly heavy filter. */
+ if (artBody) {
+ if (!body) {
+ body = newSV(0);
+ (void) SvUPGRADE(body, SVt_PV);
+ }
+ SvPVX(body) = artBody;
+ SvCUR_set(body, artLen);
+ SvLEN_set(body, 0);
+ SvPOK_on(body);
+ (void) SvREADONLY_on(body);
+ (void) SvREFCNT_inc(body);
+ hv_store(hdr, "__BODY__", 8, body, 0);
+ }
+
+ hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
+ SPAGAIN;
+
+ hv_undef(hdr);
+
+ /* Check $@, which will be set if the sub died. */
+ buf[0] = '\0';
+ if (SvTRUE(ERRSV)) {
+ syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
+ HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
+ SvPV(ERRSV, PL_na));
+ (void) POPs;
+ PerlFilter(false);
+ } else if (rc == 1) {
+ p = POPp;
+ if (p && *p)
+ strlcpy(buf, p, sizeof(buf));
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return (buf[0] != '\0') ? buf : NULL;
+}
+
+
+/*
+** Run an incoming message ID from CHECK or IHAVE through the Perl filter.
+** Returns NULL to accept the article or a rejection message to reject it.
+*/
+char *
+PLmidfilter(char *messageID)
+{
+ dSP;
+ CV *filter;
+ int rc;
+ char *p;
+ static char buf[256];
+
+ if (!PerlFilterActive) return NULL;
+ filter = perl_get_cv("filter_messageid", 0);
+ if (!filter) return NULL;
+
+ /* Pass filter_messageid() the message ID on the Perl stack. */
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
+ PUTBACK;
+ rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
+ SPAGAIN;
+
+ /* Check $@, which will be set if the sub died. */
+ buf[0] = '\0';
+ if (SvTRUE(ERRSV)) {
+ syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
+ messageID, SvPV(ERRSV, PL_na));
+ (void) POPs;
+ PerlFilter(false);
+ } else if (rc == 1) {
+ p = POPp;
+ if (p && *p)
+ strlcpy(buf, p, sizeof(buf));
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return (buf[0] != '\0') ? buf : NULL;
+}
+
+
+/*
+** Call a Perl sub on any change in INN's mode, passing in the old and new
+** mode and the reason.
+*/
+void
+PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
+{
+ dSP;
+ HV *mode;
+ CV *filter;
+
+ filter = perl_get_cv("filter_mode", 0);
+ if (!filter) return;
+
+ /* Current mode goes into $mode{Mode}, new mode in $mode{NewMode}, and
+ the reason in $mode{reason}. */
+ mode = perl_get_hv("mode", 1);
+
+ if (Mode == OMrunning)
+ hv_store(mode, "Mode", 4, newSVpv("running", 0), 0);
+ if (Mode == OMpaused)
+ hv_store(mode, "Mode", 4, newSVpv("paused", 0), 0);
+ if (Mode == OMthrottled)
+ hv_store(mode, "Mode", 4, newSVpv("throttled", 0), 0);
+
+ if (NewMode == OMrunning)
+ hv_store(mode, "NewMode", 7, newSVpv("running", 0), 0);
+ if (NewMode == OMpaused)
+ hv_store(mode, "NewMode", 7, newSVpv("paused", 0), 0);
+ if (NewMode == OMthrottled)
+ hv_store(mode, "NewMode", 7, newSVpv("throttled", 0), 0);
+
+ hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);
+
+ PUSHMARK(SP);
+ perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);
+
+ /* Check $@, which will be set if the sub died. */
+ if (SvTRUE(ERRSV)) {
+ syslog(L_ERROR, "Perl function filter_mode died: %s",
+ SvPV(ERRSV, PL_na));
+ (void) POPs;
+ PerlFilter(false);
+ }
+}
+
+
+/*
+** Called by CCmode, this returns the Perl filter statistics if a Perl
+** function to generate such statistics has been defined, or NULL otherwise.
+** If a string is returned, it's in newly allocated memory that must be freed
+** by the caller.
+*/
+char *
+PLstats(void)
+{
+ dSP;
+ char *argv[] = { NULL };
+
+ if (perl_get_cv("filter_stats", false) == NULL)
+ return NULL;
+ else {
+ char *stats = NULL;
+ char *result;
+
+ ENTER;
+ SAVETMPS;
+ perl_call_argv("filter_stats", G_EVAL | G_NOARGS, argv);
+ SPAGAIN;
+ result = POPp;
+ if (result != NULL && *result)
+ stats = xstrdup(result);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return stats;
+ }
+}
+
+
+/*
+** The remainder of this file are XS callbacks visible to embedded Perl
+** code to perform various innd functions. They were originally written by
+** Ed Mooring (mooring@acm.org) on May 14, 1998, and have since been split
+** between this file and lib/perl.c (which has the ones that can also be
+** used in nnrpd). The function that registers them at startup is at the
+** end.
+*/
+
+/*
+** Add an entry to history. Takes message ID and optionally arrival,
+** article, and expire times and storage API token. If the times aren't
+** given, they default to now. If the token isn't given, that field will
+** be left empty. Returns boolean success.
+*/
+XS(XS_INN_addhist)
+{
+ dXSARGS;
+ int i;
+ char tbuff[32];
+ char* parambuf[6];
+
+ if (items < 1 || items > 5)
+ croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");
+
+ for (i = 0; i < items; i++)
+ parambuf[i] = (char *) SvPV(ST(0), PL_na);
+
+ /* If any of the times are missing, they should default to now. */
+ if (i < 4) {
+ snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
+ for (; i < 4; i++)
+ parambuf[i] = tbuff;
+ }
+
+ /* The token defaults to an empty string. */
+ if (i == 4)
+ parambuf[4] = "";
+
+ parambuf[5] = NULL;
+
+ /* CCaddhist returns NULL on success. */
+ if (CCaddhist(parambuf))
+ XSRETURN_NO;
+ else
+ XSRETURN_YES;
+}
+
+
+/*
+** Takes the message ID of an article and returns the full article as a
+** string or undef if the article wasn't found. It will be converted from
+** wire format to native format. Note that this call isn't particularly
+** optimized or cheap.
+*/
+XS(XS_INN_article)
+{
+ dXSARGS;
+ char * msgid;
+ TOKEN token;
+ ARTHANDLE * art;
+ char * p;
+ size_t len;
+
+ if (items != 1)
+ croak("Usage: INN::article(msgid)");
+
+ /* Get the article token from the message ID and the history file. */
+ msgid = (char *) SvPV(ST(0), PL_na);
+ if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
+
+ /* Retrieve the article and convert it from wire format. */
+ art = SMretrieve(token, RETR_ALL);
+ if (art == NULL) XSRETURN_UNDEF;
+ p = FromWireFmt(art->data, art->len, &len);
+ SMfreearticle(art);
+
+ /* Push a copy of the article onto the Perl stack, free our temporary
+ memory allocation, and return the article to Perl. */
+ ST(0) = sv_2mortal(newSVpv(p, len));
+ free(p);
+ XSRETURN(1);
+}
+
+
+/*
+** Cancel a message by message ID; returns boolean success. Equivalent to
+** ctlinnd cancel <message>.
+*/
+XS(XS_INN_cancel)
+{
+ dXSARGS;
+ char *msgid;
+ char *parambuf[2];
+
+ if (items != 1)
+ croak("Usage: INN::cancel(msgid)");
+
+ msgid = (char *) SvPV(ST(0), PL_na);
+ parambuf[0] = msgid;
+ parambuf[1] = NULL;
+
+ /* CCcancel returns NULL on success. */
+ if (CCcancel(parambuf))
+ XSRETURN_NO;
+ else
+ XSRETURN_YES;
+}
+
+
+/*
+** Return the files for a given message ID, taken from the history file.
+** This function should really be named INN::token() and probably will be
+** some day.
+*/
+XS(XS_INN_filesfor)
+{
+ dXSARGS;
+ char *msgid;
+ TOKEN token;
+
+ if (items != 1)
+ croak("Usage: INN::filesfor(msgid)");
+
+ msgid = (char *) SvPV(ST(0), PL_na);
+ if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
+ XSRETURN_PV(TokenToText(token));
+ } else {
+ XSRETURN_UNDEF;
+ }
+}
+
+
+/*
+** Whether message ID is in the history file; returns boolean.
+*/
+XS(XS_INN_havehist)
+{
+ dXSARGS;
+ char *msgid;
+
+ if (items != 1)
+ croak("Usage: INN::havehist(msgid)");
+
+ msgid = (char *) SvPV(ST(0), PL_na);
+ if (HIScheck(History, msgid))
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+}
+
+
+/*
+** Takes the message ID of an article and returns the article headers as
+** a string or undef if the article wasn't found. Each line of the header
+** will end with \n.
+*/
+XS(XS_INN_head)
+{
+ dXSARGS;
+ char * msgid;
+ TOKEN token;
+ ARTHANDLE * art;
+ char * p;
+ size_t len;
+
+ if (items != 1)
+ croak("Usage: INN::head(msgid)");
+
+ /* Get the article token from the message ID and the history file. */
+ msgid = (char *) SvPV(ST(0), PL_na);
+ if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
+
+ /* Retrieve the article header and convert it from wire format. */
+ art = SMretrieve(token, RETR_HEAD);
+ if (art == NULL) XSRETURN_UNDEF;
+ p = FromWireFmt(art->data, art->len, &len);
+ SMfreearticle(art);
+
+ /* Push a copy of the article header onto the Perl stack, free our
+ temporary memory allocation, and return the header to Perl. */
+ ST(0) = sv_2mortal(newSVpv(p, len));
+ free(p);
+ XSRETURN(1);
+}
+
+
+/*
+** Returns the active file flag for a newsgroup or undef if it isn't in the
+** active file.
+*/
+XS(XS_INN_newsgroup)
+{
+ dXSARGS;
+ char * newsgroup;
+ NEWSGROUP * ngp;
+ char * end;
+ int size;
+
+ if (items != 1)
+ croak("Usage: INN::newsgroup(group)");
+ newsgroup = (char *) SvPV(ST(0), PL_na);
+
+ ngp = NGfind(newsgroup);
+ if (!ngp) {
+ XSRETURN_UNDEF;
+ } else {
+ /* ngp->Rest is newline-terminated; find the end. */
+ end = strchr(ngp->Rest, '\n');
+ if (end == NULL) {
+ size = strlen(ngp->Rest);
+ } else {
+ size = end - ngp->Rest;
+ }
+ ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
+ XSRETURN(1);
+ }
+}
+
+
+/*
+** Initialize the XS callbacks defined in this file.
+*/
+void
+PLxsinit(void)
+{
+ newXS("INN::addhist", XS_INN_addhist, "perl.c");
+ newXS("INN::article", XS_INN_article, "perl.c");
+ newXS("INN::cancel", XS_INN_cancel, "perl.c");
+ newXS("INN::havehist", XS_INN_havehist, "perl.c");
+ newXS("INN::head", XS_INN_head, "perl.c");
+ newXS("INN::newsgroup", XS_INN_newsgroup, "perl.c");
+ newXS("INN::filesfor", XS_INN_filesfor, "perl.c");
+}
+
+#endif /* defined(DO_PERL) */
~ian / innduct.git / blobdiff