1 /* $Id: perl.c 7815 2008-05-05 08:43:58Z iulius $
3 ** Perl filtering support for innd.
5 ** Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
6 ** he wouldn't recognise it anymore so don't blame him) and modified,
7 ** expanded and tweaked since by James Brister, Jeremy Nixon, Ed Mooring,
8 ** Russell Vincent, and Russ Allbery.
10 ** This file should contain all innd-specific Perl linkage. Linkage
11 ** applicable to both innd and nnrpd should go into lib/perl.c instead.
13 ** We are assuming Perl 5.004 or later.
17 ** - What we're doing with Path headers right now doesn't work for folded
18 ** headers. It's also kind of gross. There has to be a better way of
21 ** - The breakdown between this file, lib/perl.c, and nnrpd/perl.c should
22 ** be rethought, ideally in the light of supporting multiple filters in
23 ** different languages.
25 ** - We're still calling strlen() on artBody, which should be avoidable
26 ** since we've already walked it several times. We should just cache
27 ** the length somewhere for speed.
29 ** - Variable and key names should be standardized between this and nnrpd.
31 ** - The XS code is still calling CC* functions. The common code between
32 ** the two control interfaces should be factored out into the rest of
35 ** - There's a needless perl_get_cv() call for *every message ID* offered
36 ** to the server right now. We need to stash whether that filter is
42 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
55 /* From art.c. Ew. Need header parsing that doesn't use globals. */
56 extern char *filterPath;
59 ** Run an incoming article through the Perl article filter. Returns NULL
60 ** accept the article or a rejection message to reject it.
63 PLartfilter(const ARTDATA *data, char *artBody, long artLen, int lines)
67 const HDRCONTENT *hc = data->HdrContent;
72 static SV * body = NULL;
75 if (!PerlFilterActive) return NULL;
76 filter = perl_get_cv("filter_art", 0);
77 if (!filter) return NULL;
79 /* Create %hdr and stash a copy of every known header. Path has to be
80 handled separately since it's been munged by article processing. */
81 hdr = perl_get_hv("hdr", 1);
82 for (i = 0 ; i < MAX_ARTHEADER ; i++) {
85 hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
89 /* Store the article body. We don't want to make another copy of it,
90 since it could potentially be quite large. Instead, stash the
91 pointer in the static SV * body. We set LEN to 0 and inc the
92 refcount to tell Perl not to free it (either one should be enough).
93 Requires 5.004. In testing, this produced a 17% speed improvement
94 over making a copy of the article body for a fairly heavy filter. */
98 (void) SvUPGRADE(body, SVt_PV);
100 SvPVX(body) = artBody;
101 SvCUR_set(body, artLen);
104 (void) SvREADONLY_on(body);
105 (void) SvREFCNT_inc(body);
106 hv_store(hdr, "__BODY__", 8, body, 0);
109 hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);
114 rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
119 /* Check $@, which will be set if the sub died. */
122 syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
123 HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
127 } else if (rc == 1) {
130 strlcpy(buf, p, sizeof(buf));
136 return (buf[0] != '\0') ? buf : NULL;
141 ** Run an incoming message ID from CHECK or IHAVE through the Perl filter.
142 ** Returns NULL to accept the article or a rejection message to reject it.
145 PLmidfilter(char *messageID)
151 static char buf[256];
153 if (!PerlFilterActive) return NULL;
154 filter = perl_get_cv("filter_messageid", 0);
155 if (!filter) return NULL;
157 /* Pass filter_messageid() the message ID on the Perl stack. */
161 XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
163 rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
166 /* Check $@, which will be set if the sub died. */
169 syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
170 messageID, SvPV(ERRSV, PL_na));
173 } else if (rc == 1) {
176 strlcpy(buf, p, sizeof(buf));
182 return (buf[0] != '\0') ? buf : NULL;
187 ** Call a Perl sub on any change in INN's mode, passing in the old and new
188 ** mode and the reason.
191 PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
197 filter = perl_get_cv("filter_mode", 0);
200 /* Current mode goes into $mode{Mode}, new mode in $mode{NewMode}, and
201 the reason in $mode{reason}. */
202 mode = perl_get_hv("mode", 1);
204 if (Mode == OMrunning)
205 hv_store(mode, "Mode", 4, newSVpv("running", 0), 0);
206 if (Mode == OMpaused)
207 hv_store(mode, "Mode", 4, newSVpv("paused", 0), 0);
208 if (Mode == OMthrottled)
209 hv_store(mode, "Mode", 4, newSVpv("throttled", 0), 0);
211 if (NewMode == OMrunning)
212 hv_store(mode, "NewMode", 7, newSVpv("running", 0), 0);
213 if (NewMode == OMpaused)
214 hv_store(mode, "NewMode", 7, newSVpv("paused", 0), 0);
215 if (NewMode == OMthrottled)
216 hv_store(mode, "NewMode", 7, newSVpv("throttled", 0), 0);
218 hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);
221 perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);
223 /* Check $@, which will be set if the sub died. */
225 syslog(L_ERROR, "Perl function filter_mode died: %s",
234 ** Called by CCmode, this returns the Perl filter statistics if a Perl
235 ** function to generate such statistics has been defined, or NULL otherwise.
236 ** If a string is returned, it's in newly allocated memory that must be freed
243 char *argv[] = { NULL };
245 if (perl_get_cv("filter_stats", false) == NULL)
253 perl_call_argv("filter_stats", G_EVAL | G_NOARGS, argv);
256 if (result != NULL && *result)
257 stats = xstrdup(result);
268 ** The remainder of this file are XS callbacks visible to embedded Perl
269 ** code to perform various innd functions. They were originally written by
270 ** Ed Mooring (mooring@acm.org) on May 14, 1998, and have since been split
271 ** between this file and lib/perl.c (which has the ones that can also be
272 ** used in nnrpd). The function that registers them at startup is at the
277 ** Add an entry to history. Takes message ID and optionally arrival,
278 ** article, and expire times and storage API token. If the times aren't
279 ** given, they default to now. If the token isn't given, that field will
280 ** be left empty. Returns boolean success.
289 if (items < 1 || items > 5)
290 croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");
292 for (i = 0; i < items; i++)
293 parambuf[i] = (char *) SvPV(ST(0), PL_na);
295 /* If any of the times are missing, they should default to now. */
297 snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
302 /* The token defaults to an empty string. */
308 /* CCaddhist returns NULL on success. */
309 if (CCaddhist(parambuf))
317 ** Takes the message ID of an article and returns the full article as a
318 ** string or undef if the article wasn't found. It will be converted from
319 ** wire format to native format. Note that this call isn't particularly
320 ** optimized or cheap.
332 croak("Usage: INN::article(msgid)");
334 /* Get the article token from the message ID and the history file. */
335 msgid = (char *) SvPV(ST(0), PL_na);
336 if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
338 /* Retrieve the article and convert it from wire format. */
339 art = SMretrieve(token, RETR_ALL);
340 if (art == NULL) XSRETURN_UNDEF;
341 p = FromWireFmt(art->data, art->len, &len);
344 /* Push a copy of the article onto the Perl stack, free our temporary
345 memory allocation, and return the article to Perl. */
346 ST(0) = sv_2mortal(newSVpv(p, len));
353 ** Cancel a message by message ID; returns boolean success. Equivalent to
354 ** ctlinnd cancel <message>.
363 croak("Usage: INN::cancel(msgid)");
365 msgid = (char *) SvPV(ST(0), PL_na);
369 /* CCcancel returns NULL on success. */
370 if (CCcancel(parambuf))
378 ** Return the files for a given message ID, taken from the history file.
379 ** This function should really be named INN::token() and probably will be
389 croak("Usage: INN::filesfor(msgid)");
391 msgid = (char *) SvPV(ST(0), PL_na);
392 if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
393 XSRETURN_PV(TokenToText(token));
401 ** Whether message ID is in the history file; returns boolean.
409 croak("Usage: INN::havehist(msgid)");
411 msgid = (char *) SvPV(ST(0), PL_na);
412 if (HIScheck(History, msgid))
420 ** Takes the message ID of an article and returns the article headers as
421 ** a string or undef if the article wasn't found. Each line of the header
434 croak("Usage: INN::head(msgid)");
436 /* Get the article token from the message ID and the history file. */
437 msgid = (char *) SvPV(ST(0), PL_na);
438 if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
440 /* Retrieve the article header and convert it from wire format. */
441 art = SMretrieve(token, RETR_HEAD);
442 if (art == NULL) XSRETURN_UNDEF;
443 p = FromWireFmt(art->data, art->len, &len);
446 /* Push a copy of the article header onto the Perl stack, free our
447 temporary memory allocation, and return the header to Perl. */
448 ST(0) = sv_2mortal(newSVpv(p, len));
455 ** Returns the active file flag for a newsgroup or undef if it isn't in the
467 croak("Usage: INN::newsgroup(group)");
468 newsgroup = (char *) SvPV(ST(0), PL_na);
470 ngp = NGfind(newsgroup);
474 /* ngp->Rest is newline-terminated; find the end. */
475 end = strchr(ngp->Rest, '\n');
477 size = strlen(ngp->Rest);
479 size = end - ngp->Rest;
481 ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
488 ** Initialize the XS callbacks defined in this file.
493 newXS("INN::addhist", XS_INN_addhist, "perl.c");
494 newXS("INN::article", XS_INN_article, "perl.c");
495 newXS("INN::cancel", XS_INN_cancel, "perl.c");
496 newXS("INN::havehist", XS_INN_havehist, "perl.c");
497 newXS("INN::head", XS_INN_head, "perl.c");
498 newXS("INN::newsgroup", XS_INN_newsgroup, "perl.c");
499 newXS("INN::filesfor", XS_INN_filesfor, "perl.c");
502 #endif /* defined(DO_PERL) */