1 /* $Id: perl.c 7929 2008-06-29 17:55:04Z iulius $
3 ** Embedded Perl support for INN.
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
10 ** This file contains the Perl linkage shared by both nnrpd and innd. It
11 ** assumes Perl 5.004 or later.
16 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
32 /* Provided by DynaLoader but not declared in Perl's header files. */
33 extern void boot_DynaLoader(CV *cv);
35 /* Forward declarations. */
36 void PerlSilence(void);
37 void PerlUnSilence(void);
40 /* Whether Perl filtering is currently active. */
41 bool PerlFilterActive = false;
43 /* The filter sub called (filter_art or filter_post). */
46 /* The embedded Perl interpretor. */
47 static PerlInterpreter *PerlCode;
50 static void LogPerl(void)
52 syslog(L_NOTICE, "SERVER perl filtering %s", PerlFilterActive ? "enabled" : "disabled");
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.
62 PerlFilter(bool value)
65 char *argv[] = { NULL };
67 if (value == PerlFilterActive)
71 /* Execute an end function, if one is defined. */
72 if (perl_get_cv("filter_end", false) != NULL) {
75 perl_call_argv("filter_end", G_EVAL | G_DISCARD | G_NOARGS, argv);
77 syslog (L_ERROR, "SERVER perl function filter_end died: %s",
84 PerlFilterActive = value;
88 if (perl_filter_cv == NULL) {
89 syslog (L_ERROR, "SERVER perl filter not defined");
92 PerlFilterActive = value;
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.
108 void PERLsetup (char *startupfile, char *filterfile, const char *function)
110 if (PerlCode == NULL) {
111 /* Perl waits on standard input if not called with '-e'. */
113 const char *argv[] = { "innd", "-e", "0", NULL };
114 char *env[] = { NULL };
115 #ifdef PERL_SYS_INIT3
116 PERL_SYS_INIT3(&argc, &argv, &env);
118 PerlCode = perl_alloc();
119 perl_construct(PerlCode);
120 perl_parse(PerlCode, xs_init, argc, (char **)argv, env) ;
123 if (startupfile != NULL && filterfile != NULL) {
124 char *evalfile = NULL;
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);
137 perl_eval_pv(evalfile, TRUE);
142 if (SvTRUE(ERRSV)) /* check $@ */ {
143 syslog(L_ERROR,"SERVER perl loading %s failed: %s",
144 startupfile, SvPV(ERRSV, PL_na)) ;
148 PERLreadfilter (filterfile,function) ;
154 PERLreadfilter (filterfile,function) ;
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)
167 char *argv[] = { NULL };
168 char *evalfile = NULL;
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)) ;
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);
190 perl_eval_pv(evalfile, TRUE);
196 if (SvTRUE(ERRSV)) /* check $@ */ {
197 syslog (L_ERROR,"SERVER perl loading %s failed: %s",
198 filterfile, SvPV(ERRSV, PL_na)) ;
201 /* If the reload failed we don't want the old definition hanging
203 length = strlen("undef &%s") + strlen(function);
204 evalfile = xmalloc(length);
205 snprintf(evalfile, length, "undef &%s", function);
206 perl_eval_pv(evalfile, TRUE);
208 if (SvTRUE(ERRSV)) /* check $@ */ {
209 syslog (L_ERROR,"SERVER perl undef &%s failed: %s",
210 function, SvPV(ERRSV, PL_na)) ;
212 } else if ((perl_filter_cv = perl_get_cv(function, false)) == NULL) {
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)) ;
229 return (perl_filter_cv != NULL) ;
234 ** Stops using the Perl filter
238 perl_destruct(PerlCode);
243 PerlFilterActive = false;
247 ** Redirects STDOUT/STDERR briefly (otherwise PERL complains to the net
248 ** connection for NNRPD and that just won't do) -- dave@jetcafe.org
250 static int savestdout = 0;
251 static int savestderr = 0;
252 void PerlSilence(void)
256 /* Save the descriptors */
257 if ( (savestdout = dup(1)) < 0) {
258 syslog(L_ERROR,"SERVER perl silence cant redirect stdout: %m");
262 if ( (savestderr = dup(2)) < 0) {
263 syslog(L_ERROR,"SERVER perl silence cant redirect stderr: %m");
270 if ((newfd = open("/dev/null",O_WRONLY)) < 0) {
271 syslog(L_ERROR,"SERVER perl silence cant open /dev/null: %m");
277 /* Redirect descriptors */
278 if (dup2(newfd,1) < 0) {
279 syslog(L_ERROR,"SERVER perl silence cant redirect stdout: %m");
284 if (dup2(newfd,2) < 0) {
285 syslog(L_ERROR,"SERVER perl silence cant redirect stderr: %m");
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");
301 if (savestderr != 0) {
302 if (dup2(savestderr,2) < 0) {
303 syslog(L_ERROR,"SERVER perl silence cant restore stderr: %m");
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.
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.
325 const char *loglevel;
330 croak("Usage: INN::syslog(level, message)");
332 loglevel = (const char *) SvPV(ST(0), PL_na);
333 logmsg = (const char *) SvPV(ST(1), PL_na);
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;
345 syslog(priority, "filter: %s", logmsg);
353 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, "perl.c");
354 newXS("INN::syslog", XS_INN_syslog, "perl.c");
357 #endif /* defined(DO_PERL) */