chiark / gitweb /
more manpage, remove -h option
[innduct.git] / 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) */