lib/perl.c

   1 /*  $Id: perl.c 7929 2008-06-29 17:55:04Z iulius $
   2 **
   3 **  Embedded Perl support for INN.
   4 **
   5 **  Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
   6 **  he wouldn't recongize it any more, so don't blame him) and modified,
   7 **  expanded, and tweaked by James Brister, Dave Hayes, and Russ Allbery
   8 **  among others.
   9 **
  10 **  This file contains the Perl linkage shared by both nnrpd and innd.  It
  11 **  assumes Perl 5.004 or later.
  12 */
  13
  14 #include "config.h"
  15
  16 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
  17 #if DO_PERL
  18
  19 #include "clibrary.h"
  20 #include <fcntl.h>
  21 #include <syslog.h>
  22
  23 #include "libinn.h"
  24
  25 #include <EXTERN.h>
  26 #include <perl.h>
  27 #include <XSUB.h>
  28 #include "ppport.h"
  29
  30 #include "innperl.h"
  31
  32 /* Provided by DynaLoader but not declared in Perl's header files. */
  33 extern void boot_DynaLoader(CV *cv);
  34
  35 /* Forward declarations. */
  36 void    PerlSilence(void);
  37 void    PerlUnSilence(void);
  38 void    xs_init(void);
  39
  40 /* Whether Perl filtering is currently active. */
  41 bool PerlFilterActive = false;
  42
  43 /* The filter sub called (filter_art or filter_post). */
  44 CV *perl_filter_cv;
  45
  46 /* The embedded Perl interpretor. */
  47 static PerlInterpreter *PerlCode;
  48
  49
  50 static void LogPerl(void)
  51 {
  52    syslog(L_NOTICE, "SERVER perl filtering %s", PerlFilterActive ? "enabled" : "disabled");
  53 }
  54
  55
  56 /*
  57 **  Enable or disable the Perl filter.  Takes the desired state of the filter
  58 **  as an argument and returns success or failure.  Failure to enable
  59 **  indicates that the filter is not defined.
  60 */
  61 bool
  62 PerlFilter(bool value)
  63 {
  64     dSP;
  65     char *argv[] = { NULL };
  66
  67     if (value == PerlFilterActive)
  68         return true;
  69
  70     if (!value) {
  71         /* Execute an end function, if one is defined. */
  72         if (perl_get_cv("filter_end", false) != NULL) {
  73             ENTER;
  74             SAVETMPS;
  75             perl_call_argv("filter_end", G_EVAL | G_DISCARD | G_NOARGS, argv);
  76             if (SvTRUE(ERRSV)) {
  77                 syslog (L_ERROR, "SERVER perl function filter_end died: %s",
  78                         SvPV(ERRSV, PL_na));
  79                 (void) POPs;
  80             }
  81             FREETMPS;
  82             LEAVE;
  83         }
  84         PerlFilterActive = value;
  85         LogPerl();
  86         return true;
  87     } else {
  88         if (perl_filter_cv == NULL) {
  89             syslog (L_ERROR, "SERVER perl filter not defined");
  90             return false;
  91         } else {
  92             PerlFilterActive = value;
  93             LogPerl();
  94             return true;
  95         }
  96     }
  97 }
  98
  99
 100
 101 /*
 102 ** Loads a setup Perl module.  startupfile is the name of the file loaded
 103 ** one-time at startup.  filterfile is the file containing the filter
 104 ** functions which is loaded at startup and at each reload.  function is a
 105 ** function name that must be defined after the filterfile file is loaded for
 106 ** filtering to be turned on to start with.
 107 */
 108 void PERLsetup (char *startupfile, char *filterfile, const char *function)
 109 {
 110     if (PerlCode == NULL) {
 111         /* Perl waits on standard input if not called with '-e'. */
 112         int argc = 3;
 113         const char *argv[] = { "innd", "-e", "0", NULL };
 114         char *env[]  = { NULL };
 115 #ifdef PERL_SYS_INIT3
 116         PERL_SYS_INIT3(&argc, &argv, &env);
 117 #endif
 118         PerlCode = perl_alloc();
 119         perl_construct(PerlCode);
 120         perl_parse(PerlCode, xs_init, argc, (char **)argv, env) ;
 121     }
 122
 123     if (startupfile != NULL && filterfile != NULL) {
 124         char *evalfile = NULL;
 125         size_t length;
 126         dSP;
 127
 128         ENTER ;
 129         SAVETMPS ;
 130
 131         /* The Perl expression which will be evaluated. */
 132         length = strlen("do '%s'") + strlen(startupfile);
 133         evalfile = xmalloc(length);
 134         snprintf(evalfile, length, "do '%s'", startupfile);
 135
 136         PerlSilence();
 137         perl_eval_pv(evalfile, TRUE);
 138         PerlUnSilence();
 139
 140         SPAGAIN ;
 141
 142         if (SvTRUE(ERRSV))     /* check $@ */ {
 143             syslog(L_ERROR,"SERVER perl loading %s failed: %s",
 144                    startupfile, SvPV(ERRSV, PL_na)) ;
 145             PerlFilter (false) ;
 146
 147         } else {
 148             PERLreadfilter (filterfile,function) ;
 149         }
 150
 151         FREETMPS ;
 152         LEAVE ;
 153     } else {
 154         PERLreadfilter (filterfile,function) ;
 155     }
 156 }
 157
 158
 159 /* Load the perl file FILTERFILE. After it is load check that the give
 160    function is defined. If yes filtering is turned on. If not it is turned
 161    off. We remember whether the filter function was defined properly so
 162    that we can catch when the use tries to turn filtering on without the
 163    the funciton there. */
 164 int PERLreadfilter(char *filterfile, const char *function)
 165 {
 166     dSP ;
 167     char *argv[] = { NULL };
 168     char *evalfile = NULL;
 169     size_t length;
 170
 171     ENTER ;
 172     SAVETMPS ;
 173
 174     if (perl_get_cv("filter_before_reload", false) != NULL)    {
 175         perl_call_argv("filter_before_reload", G_EVAL|G_DISCARD|G_NOARGS, argv);
 176         if (SvTRUE(ERRSV))     /* check $@ */ {
 177             syslog (L_ERROR,"SERVER perl function filter_before_reload died: %s",
 178                     SvPV(ERRSV, PL_na)) ;
 179             (void)POPs ;
 180             PerlFilter (false) ;
 181         }
 182     }
 183
 184     /* The Perl expression which will be evaluated. */
 185     length = strlen("do '%s'") + strlen(filterfile);
 186     evalfile = xmalloc(length);
 187     snprintf(evalfile, length, "do '%s'", filterfile);
 188
 189     PerlSilence();
 190     perl_eval_pv(evalfile, TRUE);
 191     PerlUnSilence();
 192
 193     free(evalfile);
 194     evalfile = NULL;
 195
 196     if (SvTRUE(ERRSV))     /* check $@ */ {
 197         syslog (L_ERROR,"SERVER perl loading %s failed: %s",
 198                 filterfile, SvPV(ERRSV, PL_na)) ;
 199         PerlFilter (false) ;
 200
 201         /* If the reload failed we don't want the old definition hanging
 202            around. */
 203         length = strlen("undef &%s") + strlen(function);
 204         evalfile = xmalloc(length);
 205         snprintf(evalfile, length, "undef &%s", function);
 206         perl_eval_pv(evalfile, TRUE);
 207
 208         if (SvTRUE(ERRSV))     /* check $@ */ {
 209             syslog (L_ERROR,"SERVER perl undef &%s failed: %s",
 210                     function, SvPV(ERRSV, PL_na)) ;
 211         }
 212     } else if ((perl_filter_cv = perl_get_cv(function, false)) == NULL) {
 213         PerlFilter (false) ;
 214     }
 215
 216     if (perl_get_cv("filter_after_reload", false) != NULL) {
 217         perl_call_argv("filter_after_reload", G_EVAL|G_DISCARD|G_NOARGS, argv);
 218         if (SvTRUE(ERRSV))     /* check $@ */ {
 219             syslog (L_ERROR,"SERVER perl function filter_after_reload died: %s",
 220                     SvPV(ERRSV, PL_na)) ;
 221             (void)POPs ;
 222             PerlFilter (false) ;
 223         }
 224     }
 225
 226     FREETMPS ;
 227     LEAVE ;
 228
 229     return (perl_filter_cv != NULL) ;
 230 }
 231
 232
 233 /*
 234 **  Stops using the Perl filter
 235 */
 236 void PerlClose(void)
 237 {
 238    perl_destruct(PerlCode);
 239    perl_free(PerlCode);
 240 #ifdef PERL_SYS_TERM
 241    PERL_SYS_TERM();
 242 #endif
 243    PerlFilterActive = false;
 244 }
 245
 246 /*
 247 **  Redirects STDOUT/STDERR briefly (otherwise PERL complains to the net
 248 **  connection for NNRPD and that just won't do) -- dave@jetcafe.org
 249 */
 250 static int savestdout = 0;
 251 static int savestderr = 0;
 252 void PerlSilence(void)
 253 {
 254   int newfd;
 255
 256   /* Save the descriptors */
 257   if ( (savestdout = dup(1)) < 0) {
 258     syslog(L_ERROR,"SERVER perl silence cant redirect stdout: %m");
 259     savestdout = 0;
 260     return;
 261   }
 262   if ( (savestderr = dup(2)) < 0) {
 263     syslog(L_ERROR,"SERVER perl silence cant redirect stderr: %m");
 264     savestdout = 0;
 265     savestderr = 0;
 266     return;
 267   }
 268
 269   /* Open /dev/null */
 270   if ((newfd = open("/dev/null",O_WRONLY)) < 0) {
 271     syslog(L_ERROR,"SERVER perl silence cant open /dev/null: %m");
 272     savestdout = 0;
 273     savestderr = 0;
 274     return;
 275   }
 276
 277   /* Redirect descriptors */
 278   if (dup2(newfd,1) < 0) {
 279     syslog(L_ERROR,"SERVER perl silence cant redirect stdout: %m");
 280     savestdout = 0;
 281     return;
 282   }
 283
 284   if (dup2(newfd,2) < 0) {
 285     syslog(L_ERROR,"SERVER perl silence cant redirect stderr: %m");
 286     savestderr = 0;
 287     return;
 288   }
 289   close(newfd);
 290 }
 291
 292 void PerlUnSilence(void) {
 293   if (savestdout != 0) {
 294     if (dup2(savestdout,1) < 0) {
 295       syslog(L_ERROR,"SERVER perl silence cant restore stdout: %m");
 296     }
 297     close(savestdout);
 298     savestdout = 0;
 299   }
 300
 301   if (savestderr != 0) {
 302     if (dup2(savestderr,2) < 0) {
 303       syslog(L_ERROR,"SERVER perl silence cant restore stderr: %m");
 304     }
 305     close(savestderr);
 306     savestderr = 0;
 307   }
 308 }
 309
 310 /*
 311 **  The remainder of this file consists of XS callbacks usable by either
 312 **  innd or nnrpd and initialized automatically when the Perl filter is
 313 **  initialized, as well as the function that initializes them.
 314 */
 315
 316 /*
 317 **  Log a message via syslog.  Only the first letter of the priority
 318 **  matters, and this function assumes that the controlling program has
 319 **  already done an openlog().  The argument must be a complete message, not
 320 **  a printf-style format.
 321 */
 322 XS(XS_INN_syslog)
 323 {
 324     dXSARGS;
 325     const char *loglevel;
 326     const char *logmsg;
 327     int priority;
 328
 329     if (items != 2)
 330         croak("Usage: INN::syslog(level, message)");
 331
 332     loglevel = (const char *) SvPV(ST(0), PL_na);
 333     logmsg = (const char *) SvPV(ST(1), PL_na);
 334
 335     switch (*loglevel) {
 336         default:                priority = LOG_NOTICE;
 337         case 'a': case 'A':     priority = LOG_ALERT;           break;
 338         case 'c': case 'C':     priority = LOG_CRIT;            break;
 339         case 'e': case 'E':     priority = LOG_ERR;             break;
 340         case 'w': case 'W':     priority = LOG_WARNING;         break;
 341         case 'n': case 'N':     priority = LOG_NOTICE;          break;
 342         case 'i': case 'I':     priority = LOG_INFO;            break;
 343         case 'd': case 'D':     priority = LOG_DEBUG;           break;
 344     }
 345     syslog(priority, "filter: %s", logmsg);
 346     XSRETURN_UNDEF;
 347 }
 348
 349 extern void
 350 xs_init()
 351 {
 352     dXSUB_SYS;
 353     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, "perl.c");
 354     newXS("INN::syslog", XS_INN_syslog, "perl.c");
 355 }
 356
 357 #endif /* defined(DO_PERL) */