1 /* $Id: perl.c 7815 2008-05-05 08:43:58Z 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, Andrew Gierth, and
8 ** Russ Allbery among others.
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.
19 #include "inn/innconf.h"
26 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
36 extern HEADER Table[], *EndOfTable;
37 extern char LogName[];
38 extern char PERMuser[];
40 extern char **OtherHeaders;
41 extern int OtherCount;
42 extern bool HeadersModified;
44 extern bool PerlLoaded;
46 /* #define DEBUG_MODIFY only if you want to see verbose outout */
49 void dumpTable(char *msg);
50 #endif /* DEBUG_MODIFY */
52 char *HandleHeaders(char *article)
66 char *argv[] = { NULL };
72 if (!PerlFilterActive)
73 return NULL; /* not really necessary */
76 if ((flog = fopen("/var/news/log/nnrpdperlerrror","a+")) == NULL) {
77 syslog(L_ERROR,"Whoops. Can't open error log: %m");
79 #endif /* DEBUG_MODIFY */
84 /* Create the Perl Hash */
85 hdr = perl_get_hv("hdr", true);
86 for (hp = Table; hp < EndOfTable; hp++) {
88 hv_store(hdr, (char *) hp->Name, strlen(hp->Name), newSVpv(hp->Body, 0), 0);
91 /* Also store other headers */
92 OtherSize = OtherCount;
93 for (i = 0; i < OtherCount; i++) {
96 syslog (L_ERROR,"Null header number %d copying headers for Perl",i);
101 syslog (L_ERROR,"Bad header copying headers for Perl: '%s'",p);
105 t = (*s == ' ' ? s + 1 : s);
106 hv_store(hdr, p, (s - p) - 1, newSVpv(t, 0), 0);
109 sv_setpv(perl_get_sv("user",true), PERMuser);
112 body = perl_get_sv("body", true);
113 sv_setpv(body, article);
115 /* Call the filtering function */
116 rc = perl_call_argv("filter_post", G_EVAL|G_SCALAR, argv);
120 /* Restore headers */
121 modswitch = perl_get_sv("modify_headers",false);
122 HeadersModified = false;
123 if (SvTRUE(modswitch)) {
124 HeadersModified = true;
128 dumpTable("Before mod");
129 #endif /* DEBUG_MODIFY */
132 while ((scan = hv_iternext(hdr)) != NULL) {
134 p = HePV(scan, PL_na);
135 s = SvPV(HeVAL(scan), PL_na);
137 fprintf(flog,"Hash iter: '%s','%s'\n",p,s);
138 #endif /* DEBUG_MODIFY */
140 /* See if it's a table header */
141 for (hp = Table; hp < EndOfTable; hp++) {
142 if (strncasecmp(p, hp->Name, hp->Size) == 0) {
143 char *copy = xstrdup(s);
144 HDR_SET(hp - Table, copy);
145 hp->Len = TrimSpaces(hp->Value);
146 for (q = hp->Value ; ISWHITE(*q) || *q == '\n' ; q++)
151 hp->Value = hp->Body = NULL;
156 if (hp != EndOfTable) continue;
158 /* Add to other headers */
159 if (i >= OtherSize - 1) {
161 OtherHeaders = xrealloc(OtherHeaders, OtherSize * sizeof(char *));
163 t = concat(p, ": ", s, (char *) 0);
164 OtherHeaders[i++] = t;
168 dumpTable("After Mod");
169 #endif /* DEBUG_MODIFY */
173 sv_setsv (body, &PL_sv_undef);
177 if (SvTRUE(ERRSV)) /* check $@ */ {
178 syslog (L_ERROR,"Perl function filter_post died: %s",
179 SvPV(ERRSV, PL_na)) ;
182 } else if (rc == 1) {
184 if (p != NULL && *p != '\0')
185 strlcpy(buf, p, sizeof(buf));
196 void loadPerl(void) {
199 path = concatpath(innconf->pathfilter, _PATH_PERL_FILTER_NNRPD);
200 PERLsetup(NULL, path, "filter_post");
206 void perlAccess(char *user, struct vector *access_vec) {
211 char *key, *val, *buffer;
213 if (!PerlFilterActive)
219 attribs = perl_get_hv("attributes", true);
220 hv_store(attribs, "hostname", 8, newSVpv(ClientHost, 0), 0);
221 hv_store(attribs, "ipaddress", 9, newSVpv(ClientIpString, 0), 0);
222 hv_store(attribs, "port", 4, newSViv(ClientPort), 0);
223 hv_store(attribs, "interface", 9, newSVpv(ServerHost, 0), 0);
224 hv_store(attribs, "intipaddr", 9, newSVpv(ServerIpString, 0), 0);
225 hv_store(attribs, "intport", 7, newSViv(ServerPort), 0);
226 hv_store(attribs, "username", 8, newSVpv(user, 0), 0);
230 if (perl_get_cv("access", 0) == NULL) {
231 syslog(L_ERROR, "Perl function access not defined");
232 Reply("%d Internal Error (3). Goodbye\r\n", NNTP_ACCESS_VAL);
233 ExitWithStats(1, true);
236 rc = perl_call_pv("access", G_EVAL|G_ARRAY);
240 if (rc == 0 ) { /* Error occured, same as checking $@ */
241 syslog(L_ERROR, "Perl function access died: %s",
243 Reply("%d Internal Error (1). Goodbye\r\n", NNTP_ACCESS_VAL);
244 ExitWithStats(1, true);
248 syslog(L_ERROR, "Perl function access returned an odd number of arguments: %i", rc);
249 Reply("%d Internal Error (2). Goodbye\r\n", NNTP_ACCESS_VAL);
250 ExitWithStats(1, true);
253 vector_resize(access_vec, (rc / 2));
255 buffer = xmalloc(BIG_BUFFER);
257 for (i = (rc / 2); i >= 1; i--) {
259 val = SvPV(sv, PL_na);
261 key = SvPV(sv, PL_na);
263 strlcpy(buffer, key, BIG_BUFFER);
264 strlcat(buffer, ": \"", BIG_BUFFER);
265 strlcat(buffer, val, BIG_BUFFER);
266 strlcat(buffer, "\"\n", BIG_BUFFER);
268 vector_add(access_vec, xstrdup(buffer));
279 void perlAuthInit(void) {
283 if (!PerlFilterActive)
290 if (perl_get_cv("auth_init", 0) == NULL) {
291 syslog(L_ERROR, "Perl function auth_init not defined");
292 Reply("%d Internal Error (3). Goodbye\r\n", NNTP_ACCESS_VAL);
293 ExitWithStats(1, true);
296 rc = perl_call_pv("auth_init", G_EVAL|G_DISCARD);
301 if (SvTRUE(ERRSV)) /* check $@ */ {
302 syslog(L_ERROR, "Perl function authenticate died: %s",
304 Reply("%d Internal Error (1). Goodbye\r\n", NNTP_ACCESS_VAL);
305 ExitWithStats(1, true);
318 int perlAuthenticate(char *user, char *passwd, char *errorstring, char *newUser) {
325 if (!PerlFilterActive)
326 return NNTP_ACCESS_VAL;
328 if (perl_get_cv("authenticate", 0) == NULL) {
329 syslog(L_ERROR, "Perl function authenticate not defined");
330 Reply("%d Internal Error (3). Goodbye\r\n", NNTP_ACCESS_VAL);
331 ExitWithStats(1, true);
336 attribs = perl_get_hv("attributes", true);
337 hv_store(attribs, "hostname", 8, newSVpv(ClientHost, 0), 0);
338 hv_store(attribs, "ipaddress", 9, newSVpv(ClientIpString, 0), 0);
339 hv_store(attribs, "port", 4, newSViv(ClientPort), 0);
340 hv_store(attribs, "interface", 9, newSVpv(ServerHost, 0), 0);
341 hv_store(attribs, "intipaddr", 9, newSVpv(ServerIpString, 0), 0);
342 hv_store(attribs, "intport", 7, newSViv(ServerPort), 0);
343 hv_store(attribs, "username", 8, newSVpv(user, 0), 0);
344 hv_store(attribs, "password", 8, newSVpv(passwd, 0), 0);
347 rc = perl_call_pv("authenticate", G_EVAL|G_ARRAY);
351 if (rc == 0 ) { /* Error occured, same as checking $@ */
352 syslog(L_ERROR, "Perl function authenticate died: %s",
354 Reply("%d Internal Error (1). Goodbye\r\n", NNTP_ACCESS_VAL);
355 ExitWithStats(1, false);
358 if ((rc != 3) && (rc != 2)) {
359 syslog(L_ERROR, "Perl function authenticate returned wrong number of results: %d", rc);
360 Reply("%d Internal Error (2). Goodbye\r\n", NNTP_ACCESS_VAL);
361 ExitWithStats(1, false);
370 strcpy(errorstring, p);
374 if ((code == NNTP_POSTOK_VAL) || (code == NNTP_NOPOSTOK_VAL))
375 code = PERMcanpost ? NNTP_POSTOK_VAL : NNTP_NOPOSTOK_VAL;
377 if (code == NNTP_AUTH_NEEDED_VAL)
397 fprintf(flog,"===BEGIN TABLE DUMP: %s\n",msg);
399 for (hp = Table; hp < EndOfTable; hp++) {
400 fprintf(flog," Name: '%s'",hp->Name); fflush(flog);
401 fprintf(flog," Size: '%d'",hp->Size); fflush(flog);
402 fprintf(flog," Value: '%s'\n",((hp->Value == NULL) ? "(NULL)" : hp->Value)); fflush(flog);
405 for (i=0; i<OtherCount; i++) {
406 fprintf(flog,"Extra[%02d]: %s\n",i,OtherHeaders[i]);
408 fprintf(flog,"===END TABLE DUMP: %s\n",msg);
410 #endif /* DEBUG_MODIFY */