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;
74 if (!PerlFilterActive) return NULL;
75 filter = perl_get_cv("filter_art", 0);
76 if (!filter) return NULL;
78 /* Create %hdr and stash a copy of every known header. Path has to be
79 handled separately since it's been munged by article processing. */
80 hdr = perl_get_hv("hdr", 1);
81 for (i = 0 ; i < MAX_ARTHEADER ; i++) {
84 hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
88 /* Store the article body. We don't want to make another copy of it,
89 * since it could potentially be quite large. In testing, this produced
90 * a 17% speed improvement over making a copy of the article body
91 * for a fairly heavy filter.
92 * Available since Perl 5.7.1, newSVpvn_share allows to avoid such
93 * a copy (getting round its use for older versions of Perl leads
94 * to unreliable SV * bodies as for regexps). And for Perl not to
95 * compute a hash for artBody, we give it "42". */
97 #if (PERL_REVISION == 5) && ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 1)))
98 hv_store(hdr, "__BODY__", 8, newSVpv(artBody, artLen), 0);
100 hv_store(hdr, "__BODY__", 8, newSVpvn_share(artBody, artLen, 42), 0);
101 #endif /* Perl < 5.7.1 */
104 hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);
109 rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
114 /* Check $@, which will be set if the sub died. */
117 syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
118 HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
122 } else if (rc == 1) {
125 strlcpy(buf, p, sizeof(buf));
131 return (buf[0] != '\0') ? buf : NULL;
136 ** Run an incoming message ID from CHECK or IHAVE through the Perl filter.
137 ** Returns NULL to accept the article or a rejection message to reject it.
140 PLmidfilter(char *messageID)
146 static char buf[256];
148 if (!PerlFilterActive) return NULL;
149 filter = perl_get_cv("filter_messageid", 0);
150 if (!filter) return NULL;
152 /* Pass filter_messageid() the message ID on the Perl stack. */
156 XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
158 rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
161 /* Check $@, which will be set if the sub died. */
164 syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
165 messageID, SvPV(ERRSV, PL_na));
168 } else if (rc == 1) {
171 strlcpy(buf, p, sizeof(buf));
177 return (buf[0] != '\0') ? buf : NULL;
182 ** Call a Perl sub on any change in INN's mode, passing in the old and new
183 ** mode and the reason.
186 PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
192 filter = perl_get_cv("filter_mode", 0);
195 /* Current mode goes into $mode{Mode}, new mode in $mode{NewMode}, and
196 the reason in $mode{reason}. */
197 mode = perl_get_hv("mode", 1);
199 if (Mode == OMrunning)
200 hv_store(mode, "Mode", 4, newSVpv("running", 0), 0);
201 if (Mode == OMpaused)
202 hv_store(mode, "Mode", 4, newSVpv("paused", 0), 0);
203 if (Mode == OMthrottled)
204 hv_store(mode, "Mode", 4, newSVpv("throttled", 0), 0);
206 if (NewMode == OMrunning)
207 hv_store(mode, "NewMode", 7, newSVpv("running", 0), 0);
208 if (NewMode == OMpaused)
209 hv_store(mode, "NewMode", 7, newSVpv("paused", 0), 0);
210 if (NewMode == OMthrottled)
211 hv_store(mode, "NewMode", 7, newSVpv("throttled", 0), 0);
213 hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);
216 perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);
218 /* Check $@, which will be set if the sub died. */
220 syslog(L_ERROR, "Perl function filter_mode died: %s",
229 ** Called by CCmode, this returns the Perl filter statistics if a Perl
230 ** function to generate such statistics has been defined, or NULL otherwise.
231 ** If a string is returned, it's in newly allocated memory that must be freed
238 char *argv[] = { NULL };
240 if (perl_get_cv("filter_stats", false) == NULL)
248 perl_call_argv("filter_stats", G_EVAL | G_NOARGS, argv);
251 if (result != NULL && *result)
252 stats = xstrdup(result);
263 ** The remainder of this file are XS callbacks visible to embedded Perl
264 ** code to perform various innd functions. They were originally written by
265 ** Ed Mooring (mooring@acm.org) on May 14, 1998, and have since been split
266 ** between this file and lib/perl.c (which has the ones that can also be
267 ** used in nnrpd). The function that registers them at startup is at the
272 ** Add an entry to history. Takes message ID and optionally arrival,
273 ** article, and expire times and storage API token. If the times aren't
274 ** given, they default to now. If the token isn't given, that field will
275 ** be left empty. Returns boolean success.
284 if (items < 1 || items > 5)
285 croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");
287 for (i = 0; i < items; i++)
288 parambuf[i] = (char *) SvPV(ST(0), PL_na);
290 /* If any of the times are missing, they should default to now. */
292 snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
297 /* The token defaults to an empty string. */
303 /* CCaddhist returns NULL on success. */
304 if (CCaddhist(parambuf))
312 ** Takes the message ID of an article and returns the full article as a
313 ** string or undef if the article wasn't found. It will be converted from
314 ** wire format to native format. Note that this call isn't particularly
315 ** optimized or cheap.
327 croak("Usage: INN::article(msgid)");
329 /* Get the article token from the message ID and the history file. */
330 msgid = (char *) SvPV(ST(0), PL_na);
331 if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
333 /* Retrieve the article and convert it from wire format. */
334 art = SMretrieve(token, RETR_ALL);
335 if (art == NULL) XSRETURN_UNDEF;
336 p = FromWireFmt(art->data, art->len, &len);
339 /* Push a copy of the article onto the Perl stack, free our temporary
340 memory allocation, and return the article to Perl. */
341 ST(0) = sv_2mortal(newSVpv(p, len));
348 ** Cancel a message by message ID; returns boolean success. Equivalent to
349 ** ctlinnd cancel <message>.
358 croak("Usage: INN::cancel(msgid)");
360 msgid = (char *) SvPV(ST(0), PL_na);
364 /* CCcancel returns NULL on success. */
365 if (CCcancel(parambuf))
373 ** Return the files for a given message ID, taken from the history file.
374 ** This function should really be named INN::token() and probably will be
384 croak("Usage: INN::filesfor(msgid)");
386 msgid = (char *) SvPV(ST(0), PL_na);
387 if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
388 XSRETURN_PV(TokenToText(token));
396 ** Whether message ID is in the history file; returns boolean.
404 croak("Usage: INN::havehist(msgid)");
406 msgid = (char *) SvPV(ST(0), PL_na);
407 if (HIScheck(History, msgid))
415 ** Takes the message ID of an article and returns the article headers as
416 ** a string or undef if the article wasn't found. Each line of the header
429 croak("Usage: INN::head(msgid)");
431 /* Get the article token from the message ID and the history file. */
432 msgid = (char *) SvPV(ST(0), PL_na);
433 if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
435 /* Retrieve the article header and convert it from wire format. */
436 art = SMretrieve(token, RETR_HEAD);
437 if (art == NULL) XSRETURN_UNDEF;
438 p = FromWireFmt(art->data, art->len, &len);
441 /* Push a copy of the article header onto the Perl stack, free our
442 temporary memory allocation, and return the header to Perl. */
443 ST(0) = sv_2mortal(newSVpv(p, len));
450 ** Returns the active file flag for a newsgroup or undef if it isn't in the
462 croak("Usage: INN::newsgroup(group)");
463 newsgroup = (char *) SvPV(ST(0), PL_na);
465 ngp = NGfind(newsgroup);
469 /* ngp->Rest is newline-terminated; find the end. */
470 end = strchr(ngp->Rest, '\n');
472 size = strlen(ngp->Rest);
474 size = end - ngp->Rest;
476 ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
483 ** Initialize the XS callbacks defined in this file.
488 newXS("INN::addhist", XS_INN_addhist, "perl.c");
489 newXS("INN::article", XS_INN_article, "perl.c");
490 newXS("INN::cancel", XS_INN_cancel, "perl.c");
491 newXS("INN::havehist", XS_INN_havehist, "perl.c");
492 newXS("INN::head", XS_INN_head, "perl.c");
493 newXS("INN::newsgroup", XS_INN_newsgroup, "perl.c");
494 newXS("INN::filesfor", XS_INN_filesfor, "perl.c");
497 #endif /* defined(DO_PERL) */