.pc/fix_body_regexps/innd/perl.c

   1 /*  $Id: perl.c 7815 2008-05-05 08:43:58Z iulius $
   2 **
   3 **  Perl filtering support for innd.
   4 **
   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.
   9 **
  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.
  12 **
  13 **  We are assuming Perl 5.004 or later.
  14 **
  15 **  Future work:
  16 **
  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
  19 **     handling this.
  20 **
  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.
  24 **
  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.
  28 **
  29 **   - Variable and key names should be standardized between this and nnrpd.
  30 **
  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
  33 **     innd instead.
  34 **
  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
  37 **     active.
  38 */
  39
  40 #include "config.h"
  41
  42 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
  43 #if DO_PERL
  44
  45 #include "clibrary.h"
  46 #include "innd.h"
  47
  48 #include <EXTERN.h>
  49 #include <perl.h>
  50 #include <XSUB.h>
  51 #include "ppport.h"
  52
  53 #include "innperl.h"
  54
  55 /* From art.c.  Ew.  Need header parsing that doesn't use globals. */
  56 extern char             *filterPath;
  57
  58 /*
  59 **  Run an incoming article through the Perl article filter.  Returns NULL
  60 **  accept the article or a rejection message to reject it.
  61 */
  62 char *
  63 PLartfilter(const ARTDATA *data, char *artBody, long artLen, int lines)
  64 {
  65     dSP;
  66     const ARTHEADER * hp;
  67     const HDRCONTENT *hc = data->HdrContent;
  68     HV *        hdr;
  69     CV *        filter;
  70     int         i, rc;
  71     char *      p;
  72     static SV * body = NULL;
  73     static char buf[256];
  74
  75     if (!PerlFilterActive) return NULL;
  76     filter = perl_get_cv("filter_art", 0);
  77     if (!filter) return NULL;
  78
  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++) {
  83         if (HDR_FOUND(i)) {
  84             hp = &ARTheaders[i];
  85             hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
  86         }
  87     }
  88
  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. */
  95     if (artBody) {
  96         if (!body) {
  97             body = newSV(0);
  98             (void) SvUPGRADE(body, SVt_PV);
  99         }
 100         SvPVX(body) = artBody;
 101         SvCUR_set(body, artLen);
 102         SvLEN_set(body, 0);
 103         SvPOK_on(body);
 104         (void) SvREADONLY_on(body);
 105         (void) SvREFCNT_inc(body);
 106         hv_store(hdr, "__BODY__", 8, body, 0);
 107     }
 108
 109     hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);
 110
 111     ENTER;
 112     SAVETMPS;
 113     PUSHMARK(SP);
 114     rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
 115     SPAGAIN;
 116
 117     hv_undef(hdr);
 118
 119     /* Check $@, which will be set if the sub died. */
 120     buf[0] = '\0';
 121     if (SvTRUE(ERRSV)) {
 122         syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
 123                HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
 124                SvPV(ERRSV, PL_na));
 125         (void) POPs;
 126         PerlFilter(false);
 127     } else if (rc == 1) {
 128         p = POPp;
 129         if (p && *p)
 130             strlcpy(buf, p, sizeof(buf));
 131     }
 132
 133     PUTBACK;
 134     FREETMPS;
 135     LEAVE;
 136     return (buf[0] != '\0') ? buf : NULL;
 137 }
 138
 139
 140 /*
 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.
 143 */
 144 char *
 145 PLmidfilter(char *messageID)
 146 {
 147     dSP;
 148     CV          *filter;
 149     int         rc;
 150     char        *p;
 151     static char buf[256];
 152
 153     if (!PerlFilterActive) return NULL;
 154     filter = perl_get_cv("filter_messageid", 0);
 155     if (!filter) return NULL;
 156
 157     /* Pass filter_messageid() the message ID on the Perl stack. */
 158     ENTER;
 159     SAVETMPS;
 160     PUSHMARK(SP);
 161     XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
 162     PUTBACK;
 163     rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
 164     SPAGAIN;
 165
 166     /* Check $@, which will be set if the sub died. */
 167     buf[0] = '\0';
 168     if (SvTRUE(ERRSV)) {
 169         syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
 170                messageID, SvPV(ERRSV, PL_na));
 171         (void) POPs;
 172         PerlFilter(false);
 173     } else if (rc == 1) {
 174         p = POPp;
 175         if (p && *p)
 176             strlcpy(buf, p, sizeof(buf));
 177     }
 178
 179     PUTBACK;
 180     FREETMPS;
 181     LEAVE;
 182     return (buf[0] != '\0') ? buf : NULL;
 183 }
 184
 185
 186 /*
 187 **  Call a Perl sub on any change in INN's mode, passing in the old and new
 188 **  mode and the reason.
 189 */
 190 void
 191 PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
 192 {
 193     dSP;
 194     HV          *mode;
 195     CV          *filter;
 196
 197     filter = perl_get_cv("filter_mode", 0);
 198     if (!filter) return;
 199
 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);
 203
 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);
 210
 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);
 217
 218     hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);
 219
 220     PUSHMARK(SP);
 221     perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);
 222
 223     /* Check $@, which will be set if the sub died. */
 224     if (SvTRUE(ERRSV)) {
 225         syslog(L_ERROR, "Perl function filter_mode died: %s",
 226                 SvPV(ERRSV, PL_na));
 227         (void) POPs;
 228         PerlFilter(false);
 229     }
 230 }
 231
 232
 233 /*
 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
 237 **  by the caller.
 238 */
 239 char *
 240 PLstats(void)
 241 {
 242     dSP;
 243     char *argv[] = { NULL };
 244
 245     if (perl_get_cv("filter_stats", false) == NULL)
 246         return NULL;
 247     else {
 248         char *stats = NULL;
 249         char *result;
 250
 251         ENTER;
 252         SAVETMPS;
 253         perl_call_argv("filter_stats", G_EVAL | G_NOARGS, argv);
 254         SPAGAIN;
 255         result = POPp;
 256         if (result != NULL && *result)
 257             stats = xstrdup(result);
 258         PUTBACK;
 259         FREETMPS;
 260         LEAVE;
 261
 262         return stats;
 263     }
 264 }
 265
 266
 267 /*
 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
 273 **  end.
 274 */
 275
 276 /*
 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.
 281 */
 282 XS(XS_INN_addhist)
 283 {
 284     dXSARGS;
 285     int         i;
 286     char        tbuff[32];
 287     char*       parambuf[6];
 288
 289     if (items < 1 || items > 5)
 290         croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");
 291
 292     for (i = 0; i < items; i++)
 293         parambuf[i] = (char *) SvPV(ST(0), PL_na);
 294
 295     /* If any of the times are missing, they should default to now. */
 296     if (i < 4) {
 297         snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
 298         for (; i < 4; i++)
 299             parambuf[i] = tbuff;
 300     }
 301
 302     /* The token defaults to an empty string. */
 303     if (i == 4)
 304         parambuf[4] = "";
 305
 306     parambuf[5] = NULL;
 307
 308     /* CCaddhist returns NULL on success. */
 309     if (CCaddhist(parambuf))
 310         XSRETURN_NO;
 311     else
 312         XSRETURN_YES;
 313 }
 314
 315
 316 /*
 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.
 321 */
 322 XS(XS_INN_article)
 323 {
 324     dXSARGS;
 325     char *      msgid;
 326     TOKEN       token;
 327     ARTHANDLE * art;
 328     char *      p;
 329     size_t      len;
 330
 331     if (items != 1)
 332         croak("Usage: INN::article(msgid)");
 333
 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;
 337
 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);
 342     SMfreearticle(art);
 343
 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));
 347     free(p);
 348     XSRETURN(1);
 349 }
 350
 351
 352 /*
 353 **  Cancel a message by message ID; returns boolean success.  Equivalent to
 354 **  ctlinnd cancel <message>.
 355 */
 356 XS(XS_INN_cancel)
 357 {
 358     dXSARGS;
 359     char        *msgid;
 360     char        *parambuf[2];
 361
 362     if (items != 1)
 363         croak("Usage: INN::cancel(msgid)");
 364
 365     msgid = (char *) SvPV(ST(0), PL_na);
 366     parambuf[0] = msgid;
 367     parambuf[1] = NULL;
 368
 369     /* CCcancel returns NULL on success. */
 370     if (CCcancel(parambuf))
 371         XSRETURN_NO;
 372     else
 373         XSRETURN_YES;
 374 }
 375
 376
 377 /*
 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
 380 **  some day.
 381 */
 382 XS(XS_INN_filesfor)
 383 {
 384     dXSARGS;
 385     char        *msgid;
 386     TOKEN       token;
 387
 388     if (items != 1)
 389         croak("Usage: INN::filesfor(msgid)");
 390
 391     msgid = (char *) SvPV(ST(0), PL_na);
 392     if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
 393         XSRETURN_PV(TokenToText(token));
 394     } else {
 395         XSRETURN_UNDEF;
 396     }
 397 }
 398
 399
 400 /*
 401 **  Whether message ID is in the history file; returns boolean.
 402 */
 403 XS(XS_INN_havehist)
 404 {
 405     dXSARGS;
 406     char        *msgid;
 407
 408     if (items != 1)
 409         croak("Usage: INN::havehist(msgid)");
 410
 411     msgid = (char *) SvPV(ST(0), PL_na);
 412     if (HIScheck(History, msgid))
 413         XSRETURN_YES;
 414     else
 415         XSRETURN_NO;
 416 }
 417
 418
 419 /*
 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
 422 **  will end with \n.
 423 */
 424 XS(XS_INN_head)
 425 {
 426     dXSARGS;
 427     char *      msgid;
 428     TOKEN       token;
 429     ARTHANDLE * art;
 430     char *      p;
 431     size_t      len;
 432
 433     if (items != 1)
 434         croak("Usage: INN::head(msgid)");
 435
 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;
 439
 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);
 444     SMfreearticle(art);
 445
 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));
 449     free(p);
 450     XSRETURN(1);
 451 }
 452
 453
 454 /*
 455 **  Returns the active file flag for a newsgroup or undef if it isn't in the
 456 **  active file.
 457 */
 458 XS(XS_INN_newsgroup)
 459 {
 460     dXSARGS;
 461     char *      newsgroup;
 462     NEWSGROUP * ngp;
 463     char *      end;
 464     int         size;
 465
 466     if (items != 1)
 467         croak("Usage: INN::newsgroup(group)");
 468     newsgroup = (char *) SvPV(ST(0), PL_na);
 469
 470     ngp = NGfind(newsgroup);
 471     if (!ngp) {
 472         XSRETURN_UNDEF;
 473     } else {
 474         /* ngp->Rest is newline-terminated; find the end. */
 475         end = strchr(ngp->Rest, '\n');
 476         if (end == NULL) {
 477             size = strlen(ngp->Rest);
 478         } else {
 479             size = end - ngp->Rest;
 480         }
 481         ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
 482         XSRETURN(1);
 483     }
 484 }
 485
 486
 487 /*
 488 **  Initialize the XS callbacks defined in this file.
 489 */
 490 void
 491 PLxsinit(void)
 492 {
 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");
 500 }
 501
 502 #endif /* defined(DO_PERL) */