1 /*****************************************************************************
2 * HPT --- FTN NetMail/EchoMail Tosser
3 *****************************************************************************
4 *
5 * hpt perl hooks interface by val khokhlov, 2:550/180@fidonet
6 *
7 * This file is part of HPT.
8 *
9 * HPT is free software; you can redistribute it and/or modify it
10 * under the terms of the GNU General Public License as published by the
11 * Free Software Foundation; either version 2, or (at your option) any
12 * later version.
13 *
14 * HPT is distributed in the hope that it will be useful, but
15 * WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * General Public License for more details.
18 *
19 * You should have received a copy of the GNU General Public License
20 * along with HPT; see the file COPYING. If not, write to the Free
21 * Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22 *****************************************************************************/
23 /* $Id$ */
24
25 #include <stdio.h>
26 #include <stdlib.h>
27 #include <string.h>
28 #include <time.h>
29 #ifndef _MSC_VER
30 #include <sys/wait.h>
31 #endif
32 #ifdef __OS2__
33 #define INCL_DOSPROCESS
34 #include <os2.h>
35 #endif
36
37 #ifdef _MSC_VER
38 #undef __STDC__
39 #include <sys/types.h>
40 #endif
41
42 #include <huskylib/compiler.h>
43 #include <huskylib/huskylib.h>
44
45 #if defined(__NT__) && !defined(WIN32) /* WIN32 needed for perl-core include files */
46 # define WIN32
47 #endif
48
49 #ifdef _MSC_VER
50 #pragma warning(disable: 4127)
51 #endif
52
53 #include <fidoconf/common.h>
54 #include <huskylib/xstr.h>
55 #include <huskylib/crc.h>
56 #include <fidoconf/afixcmd.h>
57 #include <fidoconf/arealist.h>
58 #include <areafix/areafix.h>
getPause(s_link * link)59 int getPause(s_link* link) { return link->Pause & ECHOAREA; }
60
61 #include <fcommon.h>
62 #include <pkt.h>
63 #include <global.h>
64 #include <version.h>
65 #include <toss.h>
66 #include <hptperl.h>
67
68 #if defined(__cplusplus)
69 extern "C" {
70 #endif
71
72 #include <EXTERN.h>
73 #include <perl.h>
74 #ifdef _MSC_VER
75 # define NO_XSLOCKS
76 #endif
77 #ifndef _MSC_VER
78 # include <unistd.h>
79 #endif
80 #include <XSUB.h>
81 #ifdef _MSC_VER
82 # include "win32iop.h"
83 #endif
84 #if defined(__cplusplus)
85 } /* extern "C" closed */
86 # ifndef EXTERN_C
87 # define EXTERN_C extern "C"
88 # endif
89 #else
90 # ifndef EXTERN_C
91 # define EXTERN_C extern
92 # endif
93 #endif
94
95 /* perl prior to 5.6 support */
96 #ifndef get_sv
97 #define get_sv perl_get_sv
98 #endif
99
100 #ifndef newSVuv
101 #define newSVuv newSViv
102 #endif
103
104 #ifndef sv_undef
105 # define sv_undef PL_sv_undef
106 #endif
107
108 #ifndef min
109 # define min(a, b) ((a) < (b) ? (a) : (b))
110 #endif
111
112 #if 0
113 #ifdef __GNUC__
114 # ifdef _OLDPERL_
115 # define Perl___notused Perl___notused __attribute__ ((unused))
116 # endif
117 #endif
118 #endif
119
120 #ifndef LL_PERL
121 # define LL_PERL LL_EXEC
122 #endif
123
124 /* for alike */
125 #define MAX_LDIST_LEN 40 /* max word len to compair */
126 #define ADDITION 1 /* penality for needing to add a character */
127 #define CHANGE 1 /* penality for needing to modify a character */
128 #define DELETION 1 /* penality for needing to delete a character */
129 #define ALIKE 1
130 #define NOT_ALIKE 0
131 #define LENGTH_MISMATCH 32767
132 /*static int l_dist_list(char *key, char **list, char **match, int dist[], int match_limit, int *threshold);*/
133 static int l_dist_raw(char *str1, char *str2, int len1, int len2);
134
135 static PerlInterpreter *perl = NULL;
136 static int do_perl=1;
137
138 /* val: to update perl vars */
139 static int perl_vars_invalid = PERL_CONF_MAIN|PERL_CONF_LINKS|PERL_CONF_AREAS;
140
141 int skip_addvia = 0; /* val: skip via adding */
142 int perl_setattr= 0; /* val: perl manages msg attr */
143 int perl_subs = -1; /* val: defined subs */
144 #ifdef _MSC_VER
145 EXTERN_C void xs_init (pTHXo);
146 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
147 EXTERN_C void perl_putMsgInArea(pTHXo_ CV* cv);
148 EXTERN_C void perl_log(pTHXo_ CV* cv);
149 EXTERN_C void perl_str2attr(pTHXo_ CV* cv);
150 EXTERN_C void perl_myaddr(pTHXo_ CV* cv);
151 EXTERN_C void perl_nodelistDir(pTHXo_ CV* cv);
152 EXTERN_C void perl_crc32(pTHXo_ CV* cv);
153 EXTERN_C void perl_alike(pTHXo_ CV* cv);
154 #endif
155
156 /* ----- val: some utility functions */
157 /* const for kludge processing */
158 typedef enum { MODE_NOADD=0, MODE_REPLACE=1, MODE_SMART=2, MODE_UPDATE=3 } mmode_t;
159 /* flag names */
160 char *flag_name[] = { "PVT", "CRA", "RCV", "SNT", "ATT", "TRS", "ORP", "K/S",
161 "LOC", "HLD", "RSV", "FRQ", "RRQ", "RRC", "ARQ", "URQ",
162 /* flags in ^aFLAGS */
163 "A/S", "DIR", "ZON", "HUB", "IMM", "XMA", "KFS", "TFS",
164 "LOK", "CFM", "HIR", "COV", "SIG", "LET" };
165 int reuse_line(char **ptext, char *pos, mmode_t mode);
166
167 /* fts1 date to unixtime, 0 on failure */
fts2unix(const char * s,int * ret)168 static time_t fts2unix(const char *s, int *ret) {
169 struct tm tm;
170 int flags;
171 char ss[32];
172 strncpy(ss, s, sizeof(ss)-1); ss[sizeof(ss)-1] = '\0';
173 flags = parse_ftsc_date(&tm, ss);
174 tm.tm_isdst = -1;
175 /* free(ss); */
176 if (ret != NULL) *ret = flags;
177 return (flags & FTSC_BROKEN) ? 0 : mktime(&tm);
178 }
179 /* parse ^aflags into corresponding mask */
parse_flags(const char * s)180 static unsigned long parse_flags(const char *s) {
181 register unsigned char i;
182 register char *flgs;
183 register unsigned long attr = 0UL;
184 flgs = strstr(s, "\001FLAGS ");
185 if (flgs == NULL || (flgs != s && *(flgs-1) != '\r')) return 0;
186 flgs += 7;
187 while (*flgs && *flgs != '\r') {
188 while (*flgs == ' ' || *flgs == '\t') flgs++;
189 for (i = 16; i < sizeof(flag_name)/sizeof(flag_name[0]); i++)
190 if (memcmp(flgs, flag_name[i], 3) == 0) attr |= (1UL<<i);
191 while (*flgs && *flgs != '\r' && *flgs != ' ' && *flgs != '\t') flgs++;
192 }
193 return attr;
194 }
195 /* make ^aflags value from flags */
make_flags(const unsigned long attr)196 static char* make_flags(const unsigned long attr) {
197 register unsigned char i;
198 char *flgs = NULL;
199 for (i = 16; i < sizeof(flag_name)/sizeof(flag_name[0]); i++)
200 if (attr & (1<<i)) xscatprintf(&flgs, " %s", flag_name[i]);
201 return flgs;
202 }
203 /* update ^aflags only if binary flags differ from kludge, return new text
204 if mode == MODE_SMART then it's ok when (kludge=>attr) == 1 */
update_flags(char * s,const unsigned long a,mmode_t mode)205 static char* update_flags(char *s, const unsigned long a,
206 mmode_t mode) {
207 register unsigned long klattr, attr;
208 char *news = NULL, *flags, *pos, ch;
209 klattr = parse_flags(s) & 0xffff0000UL;
210 attr = a & 0xffff0000UL;
211 if ((mode == MODE_REPLACE && klattr != attr) ||
212 (mode == MODE_SMART && ((klattr ^ attr) & ~klattr))) {
213 reuse_line(&s, pos = strstr(s, "\001FLAGS "), MODE_REPLACE);
214 if (!attr) return s;
215 flags = make_flags(mode == MODE_REPLACE ? attr : attr | klattr);
216 if (flags == NULL) return s;
217 /* try to insert ^aflags to the same place or to the end of kludges */
218 if (pos == NULL) {
219 pos = s;
220 if (strncmp(pos, "AREA:", 5) == 0) while (*pos && *(pos++) != '\r');
221 while (*pos)
222 if (*pos == '\001') while (*pos && *(pos++) != '\r'); else break;
223 }
224 ch = *pos; *pos = '\0';
225
226 /* xscatprintf(&news, "\001FLAGS%s\r%s", flags, s); */
227 if (pos != s) xscatprintf(&news, "%s\r\001FLAGS%s\r", s, flags);
228 else xscatprintf(&news, "\001FLAGS%s\r", flags);
229 if (ch != '\0') { *pos = ch; xscatprintf(&news, "%s", pos); }
230 free(flags);
231 return news;
232 }
233 else return NULL;
234 }
235 /* insert a line into message to the specified place */
insert_line(char ** s,char * sub,char * pos)236 static void insert_line(char **s, char *sub, char *pos) {
237 char ch, *news = NULL;
238 if (pos == NULL) {
239 pos = *s;
240 if (strncmp(pos, "AREA:", 5) == 0) while (*pos && *(pos++) != '\r');
241 }
242 ch = *pos; *pos = '\0';
243 xscatprintf(&news, "%s%s", *s, sub);
244 if (ch != '\0') { *pos = ch; xscatprintf(&news, "%s", pos); }
245 free(*s); *s = news;
246 }
247 /* update addresses: ^aintl, ^afmpt, ^atopot */
update_addr(s_message * msg)248 static void update_addr(s_message *msg) {
249 char *intl = NULL, *topt = NULL, *fmpt = NULL, *pos = NULL;
250 xscatprintf(&intl, "\001INTL %u:%u/%u %u:%u/%u\r",
251 msg->destAddr.zone, msg->destAddr.net, msg->destAddr.node,
252 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node);
253 if (msg->destAddr.point) {
254 xscatprintf(&topt, "\001TOPT %d\r", msg->destAddr.point);
255 if (strstr(msg->text, topt) == NULL) {
256 reuse_line(&(msg->text), pos = strstr(msg->text, "\001TOPT "), MODE_REPLACE);
257 insert_line(&(msg->text), topt, pos);
258 }
259 }
260 if (msg->origAddr.point) {
261 xscatprintf(&fmpt, "\001FMPT %d\r", msg->origAddr.point);
262 if (strstr(msg->text, fmpt) == NULL) {
263 reuse_line(&(msg->text), pos = strstr(msg->text, "\001FMPT "), MODE_REPLACE);
264 insert_line(&(msg->text), fmpt, pos);
265 }
266 }
267 pos = strstr(msg->text, "\001INTL ");
268 if (strstr(msg->text, intl) == NULL && pos != NULL) {
269 reuse_line(&(msg->text), pos, MODE_REPLACE);
270 insert_line(&(msg->text), intl, pos);
271 }
272 msg->textLength = strlen(msg->text);
273 }
274 /* ---- /val */
275
276 #ifdef _MSC_VER
perl_log(pTHXo_ CV * cv)277 EXTERN_C void perl_log(pTHXo_ CV* cv)
278 #else
279 static XS(perl_log)
280 #endif
281 {
282 dXSARGS;
283 char *level, *str, lvl;
284 STRLEN n_a;
285
286 unused(cv);
287 unused(perl);
288
289 if (items != 1 && items != 2)
290 { w_log(LL_ERR, "wrong params number to log (need 1 or 2, exist %d)", items);
291 XSRETURN_EMPTY;
292 }
293 if (items == 2) {
294 level = (char *)SvPV(ST(0), n_a); if (n_a == 0) level = "";
295 lvl = *level;
296 str = (char *)SvPV(ST(1), n_a); if (n_a == 0) str = "";
297 } else {
298 lvl = LL_PERL;
299 str = (char *)SvPV(ST(0), n_a); if (n_a == 0) str = "";
300 }
301 w_log(lvl, "%s", str);
302 XSRETURN_EMPTY;
303 }
304
305 #if 0 /* isn't used static function*/
306 static int l_dist_list(char *key,
307 char **list,
308 char **match,
309 int dist[],
310 int match_limit,
311 int *threshold)
312 {
313 int i, j, k, key_len, l_dist, len, num;
314 key_len = strlen(key);
315 key_len = min(key_len, MAX_LDIST_LEN);
316 *threshold = 1 + ((key_len + 2) / 4);
317 num = 0;
318 for (k=0; list[k][0]; k++)
319 {
320 len = strlen(list[k]);
321 len = min(len, MAX_LDIST_LEN);
322 if (abs(key_len-len) <= *threshold)
323 {
324 /* calculate the distance */
325 l_dist = l_dist_raw(key, list[k], key_len, len);
326 /* is this acceptable? */
327 if (l_dist <= *threshold) /* is it in range to consider */
328 {
329 /* search the list to see where we should insert this result */
330 for (i=j=0; i<num && !j; )
331 if (l_dist < dist[i])
332 j = 1;
333 else
334 i++; /* do not increment when we find a match */
335 /* i points to the next higher valued result if j=1, otherwise */
336 /* i points to the end of the list, insert at i if in range */
337 /* found a higher valued (worse) result or list not full */
338 if (j || i < match_limit-1)
339 { /* insert in front of higher results */
340 for (j=min(match_limit-2,num-1); j>=i; j--)
341 {
342 match[j+1] = match[j];
343 dist[j+1] = dist[j];
344 }
345 match[i] = list[k];
346 dist[i] = l_dist;
347 if (num < match_limit) num++;
348 }
349 } /* if l_dist <= threshold */
350 } /* if len diff <= threshold */
351 } /* for k */
352 return(num);
353 }
354 #endif
355
356 #define SMALLEST_OF(x,y,z) ( (x<y) ? min(x,z) : min(y,z) )
357 #define ZERO_IF_EQUAL(ch1,ch2) ( (ch1==ch2) ? 0 : CHANGE )
l_dist_raw(char * str1,char * str2,int len1,int len2)358 static int l_dist_raw(char *str1, char *str2, int len1, int len2)
359 {
360 register int i, j;
361 unsigned int dist_im1[MAX_LDIST_LEN+1];
362 unsigned int dist_i_j=0, dist_i_jm1, dist_j0;
363 char *p1, *p2;
364 for (i=1, dist_im1[0]=0; i<=MAX_LDIST_LEN; i++)
365 dist_im1[i] = dist_im1[i-1] + ADDITION;
366 dist_j0 = 0;
367
368 for (i=1, p1=str1; i<=len1; i++, p1++)
369 {
370 dist_i_jm1 = dist_j0 += DELETION;
371 for (j=1, p2=str2; j<=len2; j++, p2++)
372 {
373 dist_i_j = SMALLEST_OF(dist_im1[j-1] + ZERO_IF_EQUAL(*p1, *p2),
374 dist_i_jm1 + ADDITION,
375 dist_im1[j] + DELETION );
376 dist_im1[j-1] = dist_i_jm1;
377 dist_i_jm1 = dist_i_j;
378 }
379 dist_im1[j] = dist_i_j;
380 }
381 return(dist_i_j);
382 }
383
384 #ifdef _MSC_VER
perl_alike(pTHXo_ CV * cv)385 EXTERN_C void perl_alike(pTHXo_ CV* cv)
386 #else
387 static XS(perl_alike)
388 #endif
389 {
390 /* calculate length from word to word by Levenshtein algorythm
391 0 - words matching
392 */
393 dXSARGS;
394 char * str1;
395 char * str2;
396 int len1,len2,ldist;
397 STRLEN n_a;
398
399 unused(cv);
400 unused(perl);
401
402 if (items!=2)
403 {
404 w_log(LL_ERR,"wrong number of params to alike(need 2, exist %d)", items);
405 XSRETURN_EMPTY;
406 }
407 str1=(char *)SvPV(ST(0),n_a);if (n_a==0) str1="";
408 str2=(char *)SvPV(ST(1),n_a);if (n_a==0) str2="";
409 len1 = strlen(str1);
410 len2 = strlen(str2);
411 ldist = LENGTH_MISMATCH;
412 len1 = min(len1, MAX_LDIST_LEN);
413 len2 = min(len2, MAX_LDIST_LEN);
414 ldist = l_dist_raw(str1, str2, len1, len2);
415 XSRETURN_IV(ldist);
416 }
417 /* val: better create_kludges :) */
copy_line(char ** dest,char * s)418 void copy_line(char **dest, char *s) {
419 char *pos;
420 pos = strchr(s, '\r');
421 if (pos != NULL) *pos = 0;
422 xscatprintf(dest, "%s\r", s);
423 if (pos != NULL) *pos = '\r';
424 }
425
reuse_line(char ** ptext,char * pos,mmode_t mode)426 int reuse_line(char **ptext, char *pos, mmode_t mode) {
427 char *pos2;
428 /* not found - add */
429 if (pos == NULL) return 0;
430 /* found, but not at the line start - add */
431 else if (pos != *ptext && *(pos-1) != '\r') return 0;
432 /* found and keep - don't add */
433 if (mode != MODE_REPLACE) return 1;
434 /* found and replace - delete, then add */
435 pos2 = strchr(pos, '\r');
436 if (pos2 != NULL) {
437 int len;
438 ++pos2; len = strlen(pos2);
439 memcpy(pos, pos2, len+1);
440 }
441 else *pos = 0;
442 return 0;
443 }
444
create_kludges(s_message * msg,char ** ptext,char * area,long attr,mmode_t mode)445 char *create_kludges(s_message *msg, char **ptext, char *area, long attr,
446 mmode_t mode)
447 {
448 char *buff = NULL;
449 char *flgs = NULL;
450 char *pos, *text = *ptext, *pos2;
451 unsigned int i;
452 unsigned long msgid;
453 /* echomail */
454 if (area) {
455 pos = strstr(text, "AREA:");
456 if (reuse_line(ptext, pos, mode)) {} /*copy_line(&buff, pos);*/
457 else xscatprintf(&buff, "AREA:%s\r", area);
458 }
459 /* netmail */
460 else {
461 pos = strstr(text, "\001INTL ");
462 if (reuse_line(ptext, pos, mode)) {} /*copy_line(&buff, pos);*/
463 else
464 xscatprintf(&buff, "\001INTL %u:%u/%u %u:%u/%u\r",
465 msg->destAddr.zone, msg->destAddr.net, msg->destAddr.node,
466 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node);
467
468 pos = strstr(text, "\001FMPT ");
469 if (reuse_line(ptext, pos, mode)) {} /*copy_line(&buff, pos);*/
470 else if (msg->origAddr.point) xscatprintf(&buff, "\001FMPT %d\r", msg->origAddr.point);
471
472 pos = strstr(text, "\001TOPT ");
473 if (reuse_line(ptext, pos, mode)) {} /*copy_line(&buff, pos);*/
474 else if (msg->destAddr.point) xscatprintf(&buff, "\001TOPT %d\r", msg->destAddr.point);
475
476 pos = strstr(text, "\001FLAGS ");
477 if (reuse_line(ptext, pos, mode)) {
478 copy_line(&flgs, pos+6); *(pos2 = strchr(flgs, '\r')) = 0;
479 reuse_line(ptext, pos, MODE_REPLACE);
480 }
481 if (attr & 0xffff0000UL) {
482 for (i = 16; i < sizeof(flag_name)/sizeof(flag_name[0]); i++) {
483 if ((attr & (1<<i)) && (flgs == NULL || strstr(flgs, flag_name[i]) == NULL))
484 xscatprintf(&flgs, " %s", flag_name[i]);
485 }
486 }
487 if (flgs != NULL) { xscatprintf(&buff, "\001FLAGS%s\r", flgs); free(flgs); }
488 }
489 /* msgid */
490 pos = strstr(text, "\001MSGID: ");
491 if (reuse_line(ptext, pos, mode)) ;/*copy_line(&buff, pos);*/
492 else {
493 msgid = GenMsgId(config->seqDir, config->seqOutrun);
494 if (msg->origAddr.point)
495 xscatprintf(&buff, "\001MSGID: %u:%u/%u.%u %08lx\r",
496 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node,
497 msg->origAddr.point, msgid);
498 else
499 xscatprintf(&buff, "\001MSGID: %u:%u/%u %08lx\r",
500 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node,
501 msgid);
502 }
503 /* tid */
504 pos = strstr(text, "\001TID: ");
505 if (reuse_line(ptext, pos, mode)) {} /*copy_line(&buff, pos);*/
506 else if (!config->disableTID) xscatprintf(&buff, "\001TID: %s\r", versionStr);
507
508 return buff;
509 }
510
511 /* val: end */
512 #ifdef _MSC_VER
perl_putMsgInArea(pTHXo_ CV * cv)513 EXTERN_C void perl_putMsgInArea(pTHXo_ CV* cv)
514 #else
515 static XS(perl_putMsgInArea)
516 #endif
517 {
518 dXSARGS;
519 char *area, *fromname, *toname, *fromaddr, *toaddr;
520 char *subject, *sdate = NULL, *sattr = NULL, *text;
521 long attr = -1L, date = 0;
522 int addkludges;
523 char *p;
524 STRLEN n_a;
525 UINT narea, rc;
526 s_area *echo;
527 s_message msg;
528
529 unused(cv);
530 unused(perl);
531
532 if (items != 9 && items != 10)
533 { w_log(LL_ERR, "wrong params number to putMsgInArea (need 9 or 10, exist %d)", items);
534 XSRETURN_PV("Invalid arguments");
535 }
536 area = (char *)SvPV(ST(0), n_a); if (n_a == 0) area = "";
537 fromname = (char *)SvPV(ST(1), n_a); if (n_a == 0) fromname = "";
538 toname = (char *)SvPV(ST(2), n_a); if (n_a == 0) toname = "";
539 fromaddr = (char *)SvPV(ST(3), n_a); if (n_a == 0) fromaddr = "";
540 toaddr = (char *)SvPV(ST(4), n_a); if (n_a == 0) toaddr = "";
541 subject = (char *)SvPV(ST(5), n_a); if (n_a == 0) subject = "";
542 if (SvTYPE(ST(6)) == SVt_PV) {
543 sdate = (char *)SvPV(ST(6), n_a); if (n_a == 0) sdate = "";
544 } else date = SvUV(ST(6));
545 if (SvTYPE(ST(7)) == SVt_PV) {
546 sattr = (char *)SvPV(ST(7), n_a); if (n_a == 0) sattr = "";
547 } else attr = SvUV(ST(7));
548 text = (char *)SvPV(ST(8), n_a); if (n_a == 0) text = "";
549 /*addkludges = SvTRUE(ST(9));*/
550 addkludges = (items > 9) ? SvIV(ST(9)) : MODE_SMART;
551
552 memset(&msg, '\0', sizeof(msg));
553 #if 0
554 echo = getArea(config, area);
555 if (echo == NULL)
556 XSRETURN_PV("Unknown area");
557 #else
558 echo = NULL;
559 if (!area || !*area)
560 { echo=&(config->netMailAreas[0]);
561 msg.netMail = 1;
562 }
563 for (narea=0; narea < config->echoAreaCount && !echo; narea++) {
564 if (stricmp(area, config->echoAreas[narea].areaName)==0) {
565 echo = &(config->echoAreas[narea]);
566 }
567 }
568 for (narea=0; narea < config->localAreaCount && !echo; narea++) {
569 if (stricmp(area, config->localAreas[narea].areaName)==0) {
570 echo = &(config->localAreas[narea]);
571 if (toaddr && *toaddr)
572 msg.netMail = 1;
573 }
574 }
575 for (narea=0; narea < config->netMailAreaCount && !echo; narea++) {
576 if (stricmp(area, config->netMailAreas[narea].areaName)==0) {
577 echo = &(config->netMailAreas[narea]);
578 msg.netMail = 1;
579 }
580 }
581 if (echo == NULL)
582 XSRETURN_PV("Unknown area");
583 #endif
584 if (fromaddr && *fromaddr)
585 parseFtnAddrZS(fromaddr, &(msg.origAddr));
586 else
587 memcpy(&msg.origAddr, echo->useAka, sizeof(msg.origAddr));
588 if (msg.netMail)
589 parseFtnAddrZS(toaddr, &(msg.destAddr));
590
591 if (!sdate || !*sdate)
592 { time_t t = (date != 0) ? (time_t)date : time(NULL);
593 fts_time((char *)msg.datetime, localtime(&t));
594 }
595 else
596 { strncpy((char*)msg.datetime, sdate, sizeof(msg.datetime));
597 msg.datetime[sizeof(msg.datetime)-1] = '\0';
598 }
599
600 msg.subjectLine = safe_strdup(subject);
601 msg.toUserName = safe_strdup(toname);
602 msg.fromUserName= safe_strdup(fromname);
603 text = safe_strdup(text);
604
605 if (attr != -1) msg.attributes = (dword) (attr & 0xffff);
606 else if (sattr && *sattr) {
607 sattr=safe_strdup(sattr);
608 for (p=strtok(sattr, " "); p; p=strtok(NULL, " "))
609 { dword _attr;
610 if ((_attr = str2attr(p)) != (dword)-1)
611 msg.attributes |= _attr;
612 }
613 free(sattr);
614 }
615
616 if ( !strstr(text, "\r\n") ) for (p = text; (p = strchr(p, '\n')) != NULL; *p = '\r');
617 else {
618 int len = strlen(p = text);
619 while ( (p = strchr(p, '\n')) != NULL)
620 if (p > text && *(p-1) == '\r') memmove(p, p+1, (len--)-(p-text));
621 else *p = '\r';
622 }
623 if (addkludges == MODE_UPDATE) {
624 char *text2 = (attr != -1) ? update_flags(text, attr, MODE_REPLACE) : NULL;
625 msg.text = (text2 != NULL) ? text2 : text;
626 if (msg.text != text) nfree(text);
627 update_addr(&msg);
628 }
629 else if (addkludges != MODE_NOADD) {
630 msg.text = create_kludges(&msg, &text, msg.netMail ? NULL : area, attr, addkludges);
631 xstrcat((char **)(&(msg.text)), text);
632 nfree(text);
633 }
634 else msg.text = text;
635
636 msg.textLength = strlen(msg.text);
637 rc = putMsgInArea(echo, &msg, 1, msg.attributes);
638 freeMsgBuffers(&msg);
639 if (rc)
640 XSRETURN_UNDEF;
641 else
642 XSRETURN_PV("Unable to post message");
643 }
644
645 #ifdef _MSC_VER
perl_str2attr(pTHXo_ CV * cv)646 EXTERN_C void perl_str2attr(pTHXo_ CV* cv)
647 #else
648 static XS(perl_str2attr)
649 #endif
650 {
651 dXSARGS;
652 char *attr;
653 STRLEN n_a;
654
655 unused(cv);
656 unused(perl);
657
658 w_log(LL_WARN, "str2attr() deprecated, use numeric attributes instead");
659 if (items != 1)
660 { w_log(LL_ERR, "wrong params number to str2attr (need 1, exist %d)", items);
661 XSRETURN_IV(-1);
662 }
663 attr = (char *)SvPV(ST(0), n_a); if (n_a == 0) attr = "";
664 XSRETURN_IV(str2attr(attr));
665 }
666 #ifdef _MSC_VER
perl_attr2str(pTHXo_ CV * cv)667 EXTERN_C void perl_attr2str(pTHXo_ CV* cv)
668 #else
669 static XS(perl_attr2str)
670 #endif
671 {
672 dXSARGS;
673 char *s = NULL, buf[4];
674 register unsigned char i = 0;
675 register unsigned long attr;
676
677 unused(cv);
678 unused(perl);
679
680 if (items != 1)
681 { w_log(LL_ERR, "wrong params number to attr2str (need 1, exist %d)", items);
682 XSRETURN_UNDEF;
683 }
684 attr = SvUV(ST(0));
685 for (i = 0; i < sizeof(flag_name)/sizeof(flag_name[0]); i++)
686 if (attr & (1UL<<i)) {
687 memcpy(buf, flag_name[i], 4); strLower(buf+1);
688 xstrscat(&s, " ", buf, NULLP);
689 }
690 XSRETURN_PV(s == NULL ? "" : s+1);
691 }
692 #ifdef _MSC_VER
perl_flv2str(pTHXo_ CV * cv)693 EXTERN_C void perl_flv2str(pTHXo_ CV* cv)
694 #else
695 static XS(perl_flv2str)
696 #endif
697 {
698 dXSARGS;
699
700 unused(cv);
701 unused(perl);
702
703 if (items != 1)
704 { w_log(LL_ERR, "wrong params number to flv2str (need 1, exist %d)", items);
705 XSRETURN_UNDEF;
706 }
707 XSRETURN_PV( flv2str( flag2flv(SvUV(ST(0))) ) );
708 }
709
710 #ifdef _MSC_VER
perl_fts_date(pTHXo_ CV * cv)711 EXTERN_C void perl_fts_date(pTHXo_ CV* cv)
712 #else
713 static XS(perl_fts_date)
714 #endif
715 {
716 dXSARGS;
717 char *date;
718 time_t t;
719 STRLEN n_a;
720
721 unused(cv);
722 unused(perl);
723
724 w_log(LL_WARN, "fts_date() deprecated, use numeric unixtime instead");
725 if (items != 1)
726 { w_log(LL_ERR, "wrong params number to fts_date (need 1, exist %d)", items);
727 XSRETURN_UNDEF;
728 }
729 date = (char *)SvPV(ST(0), n_a);
730 if (!n_a || (t = fts2unix(date, NULL)) == 0) XSRETURN_UNDEF;
731 else XSRETURN_IV( (unsigned long)t );
732 }
733
734 #ifdef _MSC_VER
perl_date_fts(pTHXo_ CV * cv)735 EXTERN_C void perl_date_fts(pTHXo_ CV* cv)
736 #else
737 static XS(perl_date_fts)
738 #endif
739 {
740 dXSARGS;
741 time_t t;
742 char date[21];
743 struct tm *tm;
744
745 unused(cv);
746 unused(perl);
747
748 w_log(LL_WARN, "date_fts() deprecated, use numeric unixtime instead");
749 if (items != 1)
750 { w_log(LL_ERR, "wrong params number to date_fts (need 1, exist %d)", items);
751 XSRETURN_UNDEF;
752 }
753 t = (time_t)SvUV(ST(0));
754 tm = localtime(&t);
755 make_ftsc_date(date, tm);
756 XSRETURN_PV(date);
757 }
758
759 #ifdef _MSC_VER
perl_myaddr(pTHXo_ CV * cv)760 EXTERN_C void perl_myaddr(pTHXo_ CV* cv)
761 #else
762 static XS(perl_myaddr)
763 #endif
764 {
765 UINT naddr;
766 dXSARGS;
767
768 unused(cv);
769 unused(perl);
770
771 w_log(LL_WARN, "myaddr() deprecated, use @{$config{addr}} instead");
772 if (items != 0)
773 { w_log(LL_ERR, "wrong params number to myaddr (need 0, exist %d)", items);
774 XSRETURN_UNDEF;
775 }
776 EXTEND(SP, (int)config->addrCount);
777 for (naddr=0; naddr<config->addrCount; naddr++)
778 {
779 ST(naddr) = sv_newmortal();
780 sv_setpv((SV*)ST(naddr), aka2str(config->addr[naddr]));
781 }
782 XSRETURN(naddr);
783 }
784 #ifdef _MSC_VER
perl_nodelistDir(pTHXo_ CV * cv)785 EXTERN_C void perl_nodelistDir(pTHXo_ CV* cv)
786 #else
787 static XS(perl_nodelistDir)
788 #endif
789 {
790 dXSARGS;
791
792 unused(cv);
793 unused(perl);
794
795 w_log(LL_WARN, "nodelistDir() deprecated, use $config{nodelistDir} instead");
796 if (items != 0)
797 { w_log(LL_ERR, "wrong params number to nodelistDir (need 0, exist %d)", items);
798 XSRETURN_UNDEF;
799 }
800 EXTEND(SP, 1);
801 XSRETURN_PV(config->nodelistDir ? config->nodelistDir : "");
802 }
803
804
805 #ifdef _MSC_VER
perl_crc32(pTHXo_ CV * cv)806 EXTERN_C void perl_crc32(pTHXo_ CV* cv)
807 #else
808 static XS(perl_crc32)
809 #endif
810 {
811 dXSARGS;
812 STRLEN n_a;
813 char *str;
814
815 unused(cv);
816 unused(perl);
817
818 if (items != 1)
819 { w_log(LL_ERR, "wrong params number to crc32 (need 1, exist %d)", items);
820 XSRETURN_IV(0);
821 }
822 str = (char *)SvPV(ST(0), n_a);
823 XSRETURN_IV(memcrc32(str, n_a, 0xFFFFFFFFul));
824 }
825
826 #ifdef _MSC_VER
perl_mktime(pTHXo_ CV * cv)827 EXTERN_C void perl_mktime(pTHXo_ CV* cv)
828 #else
829 static XS(perl_mktime)
830 #endif
831 {
832 dXSARGS;
833 struct tm tm;
834
835 unused(cv);
836 unused(perl);
837
838 if (items < 6 || items > 9)
839 { w_log(LL_ERR, "wrong params number to mktime (need 6 to 9, exist %d)", items);
840 XSRETURN_UNDEF;
841 }
842 tm.tm_sec = SvUV(ST(0));
843 tm.tm_min = SvUV(ST(1));
844 tm.tm_hour = SvUV(ST(2));
845 tm.tm_mday = SvUV(ST(3));
846 tm.tm_mon = SvUV(ST(4));
847 tm.tm_year = SvUV(ST(5));
848 if (tm.tm_year < 70) tm.tm_year += 100;
849 else if (tm.tm_year > 1900) tm.tm_year -= 1900;
850 tm.tm_wday = (items > 6) ? SvIV(ST(6)) : -1;
851 tm.tm_yday = (items > 7) ? SvIV(ST(7)) : -1;
852 tm.tm_isdst = -1/*(items > 8) ? SvIV(ST(8)) : -1*/;
853 XSRETURN_IV( mktime(&tm) );
854 }
855
856 #ifdef _MSC_VER
perl_strftime(pTHXo_ CV * cv)857 EXTERN_C void perl_strftime(pTHXo_ CV* cv)
858 #else
859 static XS(perl_strftime)
860 #endif
861 {
862 dXSARGS;
863 struct tm tm;
864 char buf[64];
865 STRLEN n_a;
866
867 unused(cv);
868 unused(perl);
869
870 if (items != 1 && items != 2 && (items < 7 || items > 10))
871 { w_log(LL_ERR, "wrong params number to strftime (need 1, 2, 7..10, exist %d)", items);
872 XSRETURN_UNDEF;
873 }
874 if (items > 2) {
875 tm.tm_sec = SvUV(ST(1));
876 tm.tm_min = SvUV(ST(2));
877 tm.tm_hour = SvUV(ST(3));
878 tm.tm_mday = SvUV(ST(4));
879 tm.tm_mon = SvUV(ST(5));
880 tm.tm_year = SvUV(ST(6));
881 if (tm.tm_year < 70) tm.tm_year += 100;
882 else if (tm.tm_year > 1900) tm.tm_year -= 1900;
883 tm.tm_wday = (items > 7) ? SvIV(ST(8)) : -1;
884 tm.tm_yday = (items > 8) ? SvIV(ST(9)) : -1;
885 tm.tm_isdst = -1 /*(items > 9) ? -1 SvIV(ST(10)) : -1*/;
886 mktime(&tm); /* make it valid */
887 strftime(buf, sizeof(buf), SvPV(ST(0), n_a), &tm);
888 } else {
889 time_t t = (items == 2) ? (time_t)SvUV(ST(1)) : time(NULL);
890 strftime(buf, sizeof(buf), SvPV(ST(0), n_a), localtime(&t));
891 }
892 XSRETURN_PV(buf);
893 }
894
895 #ifdef _MSC_VER
perl_gmtoff(pTHXo_ CV * cv)896 EXTERN_C void perl_gmtoff(pTHXo_ CV* cv)
897 #else
898 static XS(perl_gmtoff)
899 #endif
900 {
901 dXSARGS;
902 struct tm loc, gmt;
903 double offs;
904 time_t t;
905
906 unused(cv);
907 unused(perl);
908
909 if (items > 1)
910 { w_log(LL_ERR, "wrong params number to gmtoff (need 0 or 1, exist %d)", items);
911 XSRETURN_UNDEF;
912 }
913 if (items) t = (time_t)SvUV(ST(0)); else t = time(NULL);
914 memcpy(&loc, localtime(&t), sizeof(loc));
915 memcpy(&gmt, gmtime(&t), sizeof(gmt));
916 offs = loc.tm_hour-gmt.tm_hour;
917 if (offs > 12) offs -= 24; else if (offs < -12) offs += 24;
918 if (loc.tm_min != gmt.tm_min) offs = offs + (double)(loc.tm_min-gmt.tm_min)/60;
919 XSRETURN_NV(offs);
920 }
921
perl_warn_str(char * str)922 void perl_warn_str (char* str) {
923 while (str && *str) {
924 char* cp = strchr (str, '\n');
925 char c = 0;
926 if (cp) { c = *cp; *cp = 0; }
927 w_log (LL_PERL, "PERL: %s", str);
928 if (cp) *cp = c;
929 else break;
930 str = cp + 1;
931 }
932 }
perl_warn_sv(SV * sv)933 void perl_warn_sv (SV* sv) {
934 STRLEN n_a;
935 char * str = (char *) SvPV (sv, n_a);
936 perl_warn_str (str);
937 }
938 #ifdef _MSC_VER
perl_warn(pTHXo_ CV * cv)939 EXTERN_C void perl_warn(pTHXo_ CV* cv)
940 #else
941 static XS(perl_warn)
942 #endif
943 {
944 dXSARGS;
945
946 unused(cv);
947 unused(perl);
948
949 if (items == 1) perl_warn_sv (ST(0));
950 XSRETURN_EMPTY;
951 }
952
953 #ifdef _MSC_VER
954 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
955 #else
956 XS(boot_DynaLoader);
957 void boot_DB_File(CV *cv);
958 void boot_Fcntl(CV *cv);
959 void boot_POSIX(CV *cv);
960 void boot_SDBM_File(CV *cv);
961 void boot_IO(CV *cv);
962 void boot_OS2__Process(CV *cv);
963 void boot_OS2__ExtAttr(CV *cv);
964 void boot_OS2__REXX(CV *cv);
965 #endif
966
967 #ifdef _MSC_VER
xs_init(pTHXo)968 EXTERN_C void xs_init (pTHXo)
969 #else
970 #ifdef pTHXo
971 static void xs_init(pTHXo)
972 #else
973 static void xs_init(void)
974 #endif
975 #endif
976 {
977 static char *file = __FILE__;
978
979 unused(perl);
980
981 #ifndef DO_HPM
982 #if defined(__OS2__)
983 newXS("DB_File::bootstrap", boot_DB_File, file);
984 newXS("Fcntl::bootstrap", boot_Fcntl, file);
985 newXS("POSIX::bootstrap", boot_POSIX, file);
986 newXS("SDBM_File::bootstrap", boot_SDBM_File, file);
987 newXS("IO::bootstrap", boot_IO, file);
988 newXS("OS2::Process::bootstrap", boot_OS2__Process, file);
989 newXS("OS2::ExtAttr::bootstrap", boot_OS2__ExtAttr, file);
990 newXS("OS2::REXX::bootstrap", boot_OS2__REXX, file);
991 #else
992 dXSUB_SYS;
993 #endif
994 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
995 #endif /* !DO_HPM */
996 newXS("w_log", perl_log, file);
997 newXS("putMsgInArea", perl_putMsgInArea, file);
998 newXS("str2attr", perl_str2attr, file);
999 newXS("myaddr", perl_myaddr, file);
1000 newXS("nodelistDir", perl_nodelistDir, file);
1001 newXS("crc32", perl_crc32, file);
1002 newXS("alike", perl_alike, file);
1003 newXS("date_fts", perl_date_fts, file);
1004 newXS("fts_date", perl_fts_date, file);
1005 newXS("mktime", perl_mktime, file);
1006 newXS("strftime", perl_strftime, file);
1007 newXS("gmtoff", perl_gmtoff, file);
1008 newXS("flv2str", perl_flv2str, file);
1009 newXS("attr2str", perl_attr2str, file);
1010 newXS("hpt_warn", perl_warn, file);
1011 }
1012
1013 /* mark a part of current config as invalid in order to update it */
perl_invalidate(e_perlconftype confType)1014 void perl_invalidate(e_perlconftype confType) { perl_vars_invalid |= confType; }
1015 /* set %config, %links */
perl_setvars(void)1016 void perl_setvars(void) {
1017 UINT i, j;
1018 struct sv *sv;
1019 struct hv *hv, *hv2, *hv3;
1020 struct av *av;
1021
1022 if (!do_perl || perl == NULL) return;
1023 w_log( LL_FUNC, "perl.c::perl_setvars()" );
1024
1025 #define VK_ADD_HASH_sv(_hv,_sv,_name) \
1026 if (_sv != NULL) { \
1027 SvREADONLY_on(_sv); \
1028 (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \
1029 }
1030 #define VK_ADD_HASH_str(_hv,_sv,_name,_value) \
1031 if ( (_value != NULL) && (_sv = newSVpv(_value, 0)) != NULL ) { \
1032 SvREADONLY_on(_sv); \
1033 (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \
1034 }
1035 #define VK_ADD_HASH_intz(_hv,_sv,_name,_value) \
1036 if ( (_sv = newSViv(_value)) != NULL ) { \
1037 SvREADONLY_on(_sv); \
1038 (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \
1039 }
1040 #define VK_ADD_HASH_int(_hv,_sv,_name,_value) \
1041 if (_value) { \
1042 VK_ADD_HASH_intz(_hv,_sv,_name,_value) \
1043 } else { \
1044 VK_ADD_HASH_intz(_hv,_sv,_name,0) \
1045 }
1046
1047 /* set main config */
1048 if (perl_vars_invalid & PERL_CONF_MAIN) {
1049
1050 w_log( LL_SRCLINE, "%s:%d setting Perl variables (main)", __FILE__, __LINE__);
1051
1052 if ((sv = get_sv("hpt_ver", TRUE)) != NULL) {
1053 char *vers = NULL;
1054 xscatprintf(&vers, "hpt %u.%u.%u", VER_MAJOR, VER_MINOR, VER_PATCH);
1055 #ifdef __linux__
1056 xstrcat(&vers, "/lnx");
1057 #elif defined(__FreeBSD__) || defined(__NetBSD__)
1058 xstrcat(&vers, "/bsd");
1059 #elif defined(__OS2__) || defined(OS2)
1060 xstrcat(&vers, "/os2");
1061 #elif defined(__NT__)
1062 xstrcat(&vers, "/w32");
1063 #elif defined(__sun__)
1064 xstrcat(&vers, "/sun");
1065 #elif defined(MSDOS)
1066 xstrcat(&vers, "/dos");
1067 #elif defined(__BEOS__)
1068 xstrcat(&vers, "/beos");
1069 #endif
1070 SvREADONLY_off(sv); sv_setpv(sv, vers); SvREADONLY_on(sv);
1071 }
1072 if ((sv = get_sv("hpt_version", TRUE)) != NULL) {
1073 SvREADONLY_off(sv); sv_setpv(sv, versionStr); SvREADONLY_on(sv);
1074 }
1075 hv = perl_get_hv("config", TRUE);
1076 SvREADONLY_off(hv); hv_clear(hv);
1077 VK_ADD_HASH_str(hv, sv, "inbound", config->inbound);
1078 VK_ADD_HASH_str(hv, sv, "protInbound", config->protInbound);
1079 VK_ADD_HASH_str(hv, sv, "localInbound", config->localInbound);
1080 VK_ADD_HASH_str(hv, sv, "outbound", config->outbound);
1081 VK_ADD_HASH_str(hv, sv, "name", config->name);
1082 VK_ADD_HASH_str(hv, sv, "sysop", config->sysop);
1083 VK_ADD_HASH_str(hv, sv, "origin", config->origin);
1084 VK_ADD_HASH_str(hv, sv, "logDir", config->logFileDir);
1085 VK_ADD_HASH_str(hv, sv, "dupeHistoryDir", config->dupeHistoryDir);
1086 VK_ADD_HASH_str(hv, sv, "nodelistDir", config->nodelistDir);
1087 VK_ADD_HASH_str(hv, sv, "tempDir", config->tempDir);
1088 VK_ADD_HASH_int(hv, sv, "sortEchoList", config->listEcho);
1089 VK_ADD_HASH_int(hv, sv, "areafixFromPkt", config->areafixFromPkt);
1090 {
1091 char *tmp_robot_names = StrArray2String(robot->names);
1092 VK_ADD_HASH_str(hv, sv, "areafixNames", tmp_robot_names);
1093 nfree(tmp_robot_names);
1094 }
1095 VK_ADD_HASH_str(hv, sv, "robotsArea", config->robotsArea);
1096 VK_ADD_HASH_str(hv, sv, "reportTo", config->ReportTo);
1097 VK_ADD_HASH_int(hv, sv, "keepTrsMail", config->keepTrsMail);
1098 VK_ADD_HASH_int(hv, sv, "keepTrsFiles", config->keepTrsFiles);
1099 VK_ADD_HASH_str(hv, sv, "fileBoxesDir", config->fileBoxesDir);
1100 VK_ADD_HASH_str(hv, sv, "rulesDir", robot->rulesDir);
1101 if (config->packCount) {
1102 char *packlist = NULL;
1103 for (j = 0; j < config->packCount; j++)
1104 xstrscat(&packlist, " ", config->pack[j].packer, NULLP);
1105 VK_ADD_HASH_str(hv, sv, "packers", packlist+1);
1106 nfree(packlist);
1107 }
1108 av = newAV();
1109 for (i = 0; i < config->addrCount; i++)
1110 if ( (sv = newSVpv(aka2str(config->addr[i]), 0)) != NULL ) {
1111 SvREADONLY_on(sv); av_push(av, sv);
1112 }
1113 SvREADONLY_on(av);
1114 sv = newRV_noinc((struct sv*)av);
1115 /*SvPOK_on(sv); sv_setpv(aka2str(config->addr[0]), 0); SvREADONLY_on(sv);*/
1116 VK_ADD_HASH_sv(hv, sv, "addr");
1117 SvREADONLY_on(hv);
1118
1119 hv = perl_get_hv("groups", TRUE);
1120 SvREADONLY_off(hv); hv_clear(hv);
1121 for (i = 0; i < config->groupCount; i++) {
1122 VK_ADD_HASH_str(hv, sv, config->group[i].name, config->group[i].desc);
1123 }
1124 SvREADONLY_on(hv);
1125 }
1126
1127 /* set links config */
1128 if (perl_vars_invalid & PERL_CONF_LINKS) {
1129
1130 w_log( LL_SRCLINE, "%s:%d setting Perl variables (links)", __FILE__, __LINE__);
1131
1132 hv = perl_get_hv("links", TRUE);
1133 SvREADONLY_off(hv); hv_clear(hv);
1134 for (i = 0; i < config->linkCount; i++) {
1135 hv2 = newHV();
1136 VK_ADD_HASH_str(hv2, sv, "name", config->links[i]->name);
1137 VK_ADD_HASH_str(hv2, sv, "aka", aka2str(*config->links[i]->ourAka));
1138 VK_ADD_HASH_str(hv2, sv, "password", config->links[i]->defaultPwd);
1139 VK_ADD_HASH_str(hv2, sv, "filebox", config->links[i]->fileBox);
1140 VK_ADD_HASH_str(hv2, sv, "robot", config->links[i]->areafix.name);
1141 VK_ADD_HASH_int(hv2, sv, "flavour", flv2flag(config->links[i]->netMailFlavour));
1142 VK_ADD_HASH_int(hv2, sv, "eflavour", flv2flag(config->links[i]->echoMailFlavour));
1143 VK_ADD_HASH_int(hv2, sv, "pause", getPause( config->links[i] ));
1144 VK_ADD_HASH_int(hv2, sv, "level", config->links[i]->level);
1145 VK_ADD_HASH_int(hv2, sv, "advAfix", config->links[i]->advancedAreafix);
1146 VK_ADD_HASH_int(hv2, sv, "echoLimit", config->links[i]->areafix.echoLimit);
1147 VK_ADD_HASH_int(hv2, sv, "forwreqs", config->links[i]->areafix.forwardRequests);
1148 VK_ADD_HASH_str(hv2, sv, "forwreqsFile", config->links[i]->areafix.fwdFile);
1149 VK_ADD_HASH_int(hv2, sv, "forwreqsPrio", config->links[i]->areafix.forwardPriority);
1150 VK_ADD_HASH_int(hv2, sv, "reducedSeenBy", config->links[i]->reducedSeenBy);
1151 VK_ADD_HASH_int(hv2, sv, "noRules", config->links[i]->areafix.noRules);
1152 VK_ADD_HASH_int(hv2, sv, "pktSize", config->links[i]->pktSize);
1153 VK_ADD_HASH_int(hv2, sv, "arcmailSize", (config->links[i]->arcmailSize ?
1154 config->links[i]->arcmailSize :
1155 (config->defarcmailSize ? config->defarcmailSize : 500) ));
1156 if (config->links[i]->packerDef) VK_ADD_HASH_str(hv2, sv, "packer", config->links[i]->packerDef->packer);
1157 if (config->links[i]->AccessGrp) {
1158 char *grplist = NULL;
1159 for (j = 0; j < config->links[i]->numAccessGrp; j++)
1160 if (config->links[i]->AccessGrp[j])
1161 xstrscat(&grplist, " ", config->links[i]->AccessGrp[j], NULLP);
1162 if (grplist) VK_ADD_HASH_str(hv2, sv, "groups", grplist+1);
1163 nfree(grplist);
1164 }
1165 /* val r/o: SvREADONLY_on(hv2); */
1166 sv = newRV_noinc((struct sv*)hv2);
1167 VK_ADD_HASH_sv(hv, sv, aka2str(config->links[i]->hisAka));
1168 }
1169 /* val: seems to cause problems: SvREADONLY_on(hv); */
1170 }
1171
1172 /* set areas config */
1173 if (perl_vars_invalid & PERL_CONF_AREAS) {
1174
1175 w_log( LL_SRCLINE, "%s:%d setting Perl variables (areas)", __FILE__, __LINE__);
1176
1177 hv = perl_get_hv("areas", TRUE);
1178 SvREADONLY_off(hv); hv_clear(hv);
1179 for (i = 0; i < config->echoAreaCount; i++) {
1180 hv2 = newHV();
1181 VK_ADD_HASH_str(hv2, sv, "desc", config->echoAreas[i].description);
1182 VK_ADD_HASH_str(hv2, sv, "aka", aka2str(*config->echoAreas[i].useAka));
1183 VK_ADD_HASH_str(hv2, sv, "group", config->echoAreas[i].group);
1184 VK_ADD_HASH_int(hv2, sv, "hide", config->echoAreas[i].hide);
1185 VK_ADD_HASH_int(hv2, sv, "passthrough", config->echoAreas[i].msgbType == MSGTYPE_PASSTHROUGH);
1186 VK_ADD_HASH_int(hv2, sv, "mandatory", config->echoAreas[i].mandatory);
1187 VK_ADD_HASH_int(hv2, sv, "manual", config->echoAreas[i].manual);
1188 VK_ADD_HASH_int(hv2, sv, "lvl_r", config->echoAreas[i].levelread);
1189 VK_ADD_HASH_int(hv2, sv, "lvl_w", config->echoAreas[i].levelwrite);
1190 VK_ADD_HASH_int(hv2, sv, "paused", config->echoAreas[i].paused);
1191 if (config->echoAreas[i].downlinks) {
1192 hv3 = newHV();
1193 for (j = 0; j < config->echoAreas[i].downlinkCount; j++) {
1194 VK_ADD_HASH_int(hv3, sv,
1195 aka2str(config->echoAreas[i].downlinks[j]->link->hisAka),
1196 1 | config->echoAreas[i].downlinks[j]->defLink << 1
1197 | config->echoAreas[i].downlinks[j]->manual << 2
1198 | config->echoAreas[i].downlinks[j]->mandatory << 3
1199 | config->echoAreas[i].downlinks[j]->import << 4
1200 | config->echoAreas[i].downlinks[j]->aexport << 5
1201 );
1202 }
1203 /* val r/o: SvREADONLY_on(hv3); */
1204 sv = newRV_noinc((struct sv*)hv3);
1205 VK_ADD_HASH_sv(hv2, sv, "links");
1206 }
1207 /* val r/o: SvREADONLY_on(hv2); */
1208 sv = newRV_noinc((struct sv*)hv2);
1209 VK_ADD_HASH_sv(hv, sv, config->echoAreas[i].areaName);
1210 }
1211 SvREADONLY_on(hv);
1212 }
1213
1214 perl_vars_invalid = 0;
1215 }
1216
PerlStart(void)1217 int PerlStart(void)
1218 {
1219 int rc;
1220 int i;
1221 char *perlfile;
1222 char *perlargs[]={"", NULL, NULL, NULL, NULL};
1223 char **perlargv = (char **)perlargs;
1224 char *cfgfile, *cfgpath=NULL, *patharg=NULL;
1225 STRLEN n_a;
1226
1227 if (config->hptPerlFile != NULL)
1228 perlfile = config->hptPerlFile;
1229 else
1230 {
1231 do_perl=0;
1232 return 1;
1233 }
1234 i = 1;
1235 /* val: try to find out the actual path to perl script and set dir to -I */
1236 cfgfile = (cfgFile) ? cfgFile : getConfigFileName();
1237 if ( strchr(perlfile, PATH_DELIM) ) {
1238 cfgpath = GetDirnameFromPathname(perlfile);
1239 xstrscat(&patharg, "-I", cfgpath, NULLP);
1240 nfree(cfgpath);
1241 }
1242 else if ( strchr(cfgfile, PATH_DELIM) ) {
1243 cfgpath = GetDirnameFromPathname(cfgfile);
1244 xstrscat(&patharg, "-I", cfgpath, NULLP);
1245 nfree(cfgpath);
1246 }
1247 if (patharg) perlargs[i++] = patharg;
1248 perlargs[i++] = "-e";
1249 perlargs[i++] = "0";
1250 #ifdef _MSC_VER
1251 if (_access(perlfile, R_OK))
1252 #else
1253 if (access(perlfile, R_OK))
1254 #endif
1255 { w_log(LL_ERR, "Can't read %s: %s, perl filtering disabled",
1256 perlfile, strerror(errno));
1257 do_perl=0;
1258 nfree(patharg);
1259 return 1;
1260 }
1261
1262 /* Start perl interpreter */
1263 #ifdef DO_HPM
1264 #ifndef aTHXo
1265 #define aTHXo
1266 #endif /*!aTHXo*/
1267 xs_init (aTHXo);
1268 perl = (void*) -1;
1269 rc = 0;
1270 #else /* !DO_HPM */
1271 #ifdef PERL_SYS_INIT3
1272 PERL_SYS_INIT3(&i, &perlargv, &hpt_environ);
1273 #endif
1274 perl = perl_alloc();
1275 perl_construct(perl);
1276 #if defined(PERL_EXIT_DESTRUCT_END) && defined(PL_exit_flags)
1277 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1278 #endif
1279 rc = perl_parse (perl, xs_init, i, perlargv, hpt_environ);
1280 #endif /* !DO_HPM */
1281 if (!rc) {
1282 char* cmd = NULL;
1283 SV* sv;
1284
1285 /* val: start constants definition */
1286 #define VK_MAKE_CONST(_name,_value) \
1287 newCONSTSUB(PL_defstash, _name, newSVuv(_value)); \
1288 sv_setuv( get_sv(_name, TRUE), _value );
1289 for (i = 0; i < sizeof(flag_name)/sizeof(flag_name[0]); i++) {
1290 char ss[4];
1291 strcpy(ss, flag_name[i]); if (ss[1] == '/') ss[1] = '_'; ss[3]=0;
1292 VK_MAKE_CONST(ss, (unsigned long)1<<i);
1293 }
1294
1295 /* val: start config importing */
1296 perl_setvars();
1297
1298 /* Set warn and die hook */
1299 if (PL_warnhook) SvREFCNT_dec (PL_warnhook);
1300 if (PL_diehook ) SvREFCNT_dec (PL_diehook );
1301 PL_warnhook = newRV_inc ((SV*) perl_get_cv ("hpt_warn", TRUE));
1302 PL_diehook = newRV_inc ((SV*) perl_get_cv ("hpt_warn", TRUE));
1303
1304 /* Parse and execute hptPerlFile */
1305 xstrscat (&cmd, "do '", perlfile, "'; $@ ? $@ : '';", NULLP);
1306 sv = perl_eval_pv (cmd, TRUE);
1307 if (!SvPOK(sv)) {
1308 w_log(LL_PERL,"Syntax error in internal perl expression: %s",cmd);
1309 rc = 1;
1310 } else if (SvTRUE (sv)) {
1311 perl_warn_sv (sv);
1312 rc = 1;
1313 }
1314 nfree (cmd);
1315 }
1316 if (rc)
1317 { w_log(LL_ERR, "Can't parse %s, perl filtering disabled",
1318 perlfile);
1319 #ifndef DO_HPM
1320 perl_destruct(perl);
1321 perl_free(perl);
1322 #endif /* !DO_HPM */
1323 perl=NULL;
1324 do_perl=0;
1325 nfree(patharg);
1326 return 1;
1327 }
1328 /* val: look which subs present */
1329 if (perl_get_cv(PERLFILT , FALSE) == NULL)
1330 perl_subs &= ~SUB_FILTER;
1331 if (perl_get_cv(PERLFILT2 , FALSE) == NULL)
1332 perl_subs &= ~SUB_FILTER2;
1333 if (perl_get_cv(PERLPKT , FALSE) == NULL)
1334 perl_subs &= ~SUB_PROCESS_PKT;
1335 if (perl_get_cv(PERLPKTDONE , FALSE) == NULL)
1336 perl_subs &= ~SUB_PKT_DONE;
1337 if (perl_get_cv(PERLAFTERUNP , FALSE) == NULL)
1338 perl_subs &= ~SUB_AFTER_UNPACK;
1339 if (perl_get_cv(PERLBEFOREPACK, FALSE) == NULL)
1340 perl_subs &= ~SUB_BEFORE_PACK;
1341 if (perl_get_cv(PERLSTART , FALSE) == NULL)
1342 perl_subs &= ~SUB_HPT_START;
1343 if (perl_get_cv(PERLEXIT , FALSE) == NULL)
1344 perl_subs &= ~SUB_HPT_EXIT;
1345 if (perl_get_cv(PERLROUTE , FALSE) == NULL)
1346 perl_subs &= ~SUB_ROUTE;
1347 if (perl_get_cv(PERLSCAN , FALSE) == NULL)
1348 perl_subs &= ~SUB_SCAN;
1349 if (perl_get_cv(PERLTOSSBAD , FALSE) == NULL)
1350 perl_subs &= ~SUB_TOSSBAD;
1351 if (perl_get_cv(PERLONECHOLIST, FALSE) == NULL)
1352 perl_subs &= ~SUB_ON_ECHOLIST;
1353 if (perl_get_cv(PERLONAFIXCMD , FALSE) == NULL)
1354 perl_subs &= ~SUB_ON_AFIXCMD;
1355 if (perl_get_cv(PERLONAFIXREQ , FALSE) == NULL)
1356 perl_subs &= ~SUB_ON_AFIXREQ;
1357 if (perl_get_cv(PERLPUTMSG , FALSE) == NULL)
1358 perl_subs &= ~SUB_PUTMSG;
1359 if (perl_get_cv(PERLEXPORT , FALSE) == NULL)
1360 perl_subs &= ~SUB_EXPORT;
1361 if (perl_get_cv(PERLROBOTMSG , FALSE) == NULL)
1362 perl_subs &= ~SUB_ON_ROBOTMSG;
1363 /* val: run hpt_start() */
1364 if (perl_subs & SUB_HPT_START) {
1365 { dSP;
1366 ENTER;
1367 SAVETMPS;
1368 PUSHMARK(SP);
1369 PUTBACK;
1370 perl_call_pv(PERLSTART, G_EVAL|G_VOID);
1371 SPAGAIN;
1372 PUTBACK;
1373 FREETMPS;
1374 LEAVE;
1375 }
1376 if (SvTRUE(ERRSV))
1377 {
1378 w_log(LL_ERR, "Perl hpt_start() eval error: %s\n", SvPV(ERRSV, n_a));
1379 }
1380 }
1381 /* val: end config importing */
1382 nfree(patharg);
1383 return 0;
1384 }
1385
1386 #define VK_START_HOOK(name, code, ret) \
1387 if (do_perl && perl == NULL) \
1388 if (PerlStart()) return ret; \
1389 if (!perl || !do_##name || (perl_subs & code) == 0) \
1390 return ret; \
1391 w_log(LL_SRCLINE, "%s:%d starting Perl hook "#name, __FILE__, __LINE__); \
1392 if (perl_vars_invalid) perl_setvars();
1393
perldone(void)1394 void perldone(void)
1395 {
1396 static int do_perldone=1;
1397
1398 VK_START_HOOK(perldone, SUB_HPT_EXIT, )
1399
1400 { dSP;
1401 ENTER;
1402 SAVETMPS;
1403 PUSHMARK(SP);
1404 PUTBACK;
1405 perl_call_pv(PERLEXIT, G_EVAL|G_SCALAR);
1406 SPAGAIN;
1407 PUTBACK;
1408 FREETMPS;
1409 LEAVE;
1410 #ifndef DO_HPM
1411 perl_destruct(perl);
1412 perl_free(perl);
1413 #endif /* !DO_HPM */
1414 perl=NULL;
1415 }
1416 }
1417
perlscanmsg(char * area,s_message * msg)1418 int perlscanmsg(char *area, s_message *msg)
1419 {
1420 static int do_perlscan = 1;
1421 char *prc, *ptr;
1422 unsigned long attr;
1423 time_t date;
1424 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr, *svattr;
1425 SV *svdate, *svtext, *svarea, *svsubj, *svret, *svchange;
1426 SV *svaddvia, *svkill;
1427 STRLEN n_a;
1428 int result = 0;
1429
1430 VK_START_HOOK(perlscan, SUB_SCAN, 0)
1431
1432 { dSP;
1433 svfromname = perl_get_sv("fromname", TRUE);
1434 svfromaddr = perl_get_sv("fromaddr", TRUE);
1435 svtoname = perl_get_sv("toname", TRUE);
1436 svdate = perl_get_sv("date", TRUE);
1437 svsubj = perl_get_sv("subject", TRUE);
1438 svtext = perl_get_sv("text", TRUE);
1439 svchange = perl_get_sv("change", TRUE);
1440 svkill = perl_get_sv("kill", TRUE);
1441 svarea = perl_get_sv("area", TRUE);
1442 svtoaddr = perl_get_sv("toaddr", TRUE);
1443 svattr = perl_get_sv("attr", TRUE);
1444 svaddvia = perl_get_sv("addvia", TRUE);
1445 sv_setpv(svfromname, msg->fromUserName);
1446 sv_setpv(svfromaddr, aka2str(msg->origAddr));
1447 sv_setpv(svtoname, msg->toUserName);
1448
1449 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
1450 sv_setpv(svdate, (char*)msg->datetime);
1451 SvIOK_on(svdate);
1452
1453 sv_setpv(svsubj, msg->subjectLine);
1454 sv_setpv(svtext, msg->text);
1455 sv_setsv(svchange, &sv_undef);
1456 sv_setsv(svkill, &sv_undef);
1457 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
1458 sv_setiv(svaddvia, 1);
1459
1460 if (area)
1461 sv_setpv(svarea, area);
1462 else
1463 sv_setsv(svarea, &sv_undef);
1464 if (msg->netMail)
1465 sv_setpv(svtoaddr, aka2str(msg->destAddr));
1466 else
1467 sv_setsv(svtoaddr, &sv_undef);
1468 ENTER;
1469 SAVETMPS;
1470 PUSHMARK(SP);
1471 PUTBACK;
1472 perl_call_pv(PERLSCAN, G_EVAL|G_SCALAR);
1473 SPAGAIN;
1474 svret=POPs;
1475 if (SvTRUE(svret))
1476 prc = safe_strdup(SvPV(svret, n_a));
1477 else
1478 prc = NULL;
1479 PUTBACK;
1480 FREETMPS;
1481 LEAVE;
1482 if (SvTRUE(ERRSV))
1483 {
1484 w_log(LL_ERR, "Perl scan eval error: %s\n", SvPV(ERRSV, n_a));
1485 do_perlscan = 0;
1486 return 0;
1487 }
1488 svchange = perl_get_sv("change", FALSE);
1489 if (svchange && SvTRUE(svchange))
1490 { /* change */
1491 freeMsgBuffers(msg);
1492 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
1493 if (n_a == 0) ptr = "";
1494 msg->text = safe_strdup(ptr);
1495 msg->textLength = strlen(msg->text);
1496 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
1497 if (n_a == 0) ptr = "";
1498 msg->toUserName = safe_strdup(ptr);
1499 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
1500 if (n_a == 0) ptr = "";
1501 msg->fromUserName = safe_strdup(ptr);
1502 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
1503 if (n_a == 0) ptr = "";
1504 msg->subjectLine = safe_strdup(ptr);
1505 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
1506 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
1507 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
1508 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
1509 /* update message kludges, if needed */
1510 update_addr(msg);
1511 /* process flags, update message if needed */
1512 attr = SvUV(perl_get_sv("attr", FALSE));
1513 msg->attributes = attr & 0xffff;
1514 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
1515 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
1516 msg->textLength = strlen(msg->text);
1517 }
1518 /* process date */
1519 svdate = perl_get_sv("date", FALSE);
1520 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
1521 date = SvUV(svdate);
1522 make_ftsc_date((char*)msg->datetime, localtime(&date));
1523 }
1524 else if ( SvPOK(svdate) ) {
1525 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
1526 if (fts2unix(ptr, NULL) > 0) {
1527 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
1528 msg->datetime[sizeof(msg->datetime)-1] = '\0';
1529 }
1530 }
1531 }
1532
1533 skip_addvia = 0;
1534 svaddvia = get_sv("addvia", FALSE);
1535 if (svaddvia != NULL) skip_addvia = (SvIV(svaddvia) == 0);
1536 /* kill after processing */
1537 if (msg->netMail && svkill && SvTRUE(svkill)) result |= 0x80;
1538 /* change route and flavour */
1539 if (prc)
1540 {
1541 if (msg->netMail)
1542 w_log(LL_PERL, "PerlScan: NetMail from %s %u:%u/%u.%u to %s %u:%u/%u.%u: %s",
1543 msg->fromUserName,
1544 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node, msg->origAddr.point,
1545 msg->toUserName,
1546 msg->destAddr.zone, msg->destAddr.net, msg->destAddr.node, msg->destAddr.point,
1547 prc);
1548 else
1549 w_log(LL_PERL, "PerlScan: Area %s from %s %u:%u/%u.%u: %s",
1550 area, msg->fromUserName,
1551 msg->origAddr.zone, msg->origAddr.net, msg->origAddr.node, msg->origAddr.point,
1552 prc);
1553 nfree(prc);
1554 return result | 1;
1555 }
1556 }
1557 return result | 0;
1558 }
1559
perlroute(s_message * msg,s_route * defroute)1560 s_route *perlroute(s_message *msg, s_route *defroute)
1561 {
1562 static int do_perlroute = 1;
1563
1564 VK_START_HOOK(perlroute, SUB_ROUTE, NULL)
1565
1566 { SV *svaddr, *svattr, *svflv, *svfrom, *svret, *svroute;
1567 SV *svfromname, *svtoname, *svsubj, *svtext, *svdate;
1568 SV *svaddvia, *svchange;
1569 char *routeaddr, *prc, *ptr;
1570 unsigned long attr;
1571 time_t date;
1572 STRLEN n_a;
1573 static s_route route;
1574 dSP;
1575 svaddr = perl_get_sv("addr", TRUE);
1576 svfrom = perl_get_sv("from", TRUE);
1577 svroute = perl_get_sv("route", TRUE);
1578 svflv = perl_get_sv("flavour", TRUE);
1579 svattr = perl_get_sv("attr", TRUE);
1580 svsubj = perl_get_sv("subj", TRUE);
1581 svtext = perl_get_sv("text", TRUE);
1582 svdate = perl_get_sv("date", TRUE);
1583 svtoname= perl_get_sv("toname", TRUE);
1584 svfromname = perl_get_sv("fromname", TRUE);
1585 svchange = perl_get_sv("change", TRUE);
1586 sv_setpv(svaddr, aka2str(msg->destAddr));
1587 sv_setpv(svfrom, aka2str(msg->origAddr));
1588 sv_setpv(svfromname, msg->fromUserName);
1589 sv_setpv(svtoname, msg->toUserName);
1590
1591 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
1592 sv_setpv(svdate, (char*)msg->datetime);
1593 SvIOK_on(svdate);
1594
1595 sv_setpv(svsubj, msg->subjectLine);
1596 sv_setpv(svtext, msg->text);
1597 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
1598 sv_setsv(svchange, &sv_undef);
1599 if (defroute)
1600 {
1601 if (defroute->target)
1602 sv_setpv(svroute, aka2str(defroute->target->hisAka));
1603 else /* noroute */
1604 sv_setpv(svroute, aka2str(msg->destAddr));
1605 if (defroute->flavour==flNormal)
1606 sv_setpv(svflv, "normal");
1607 else if (defroute->flavour==flHold)
1608 sv_setpv(svflv, "hold");
1609 else if (defroute->flavour==flDirect)
1610 sv_setpv(svflv, "direct");
1611 else if (defroute->flavour==flCrash)
1612 sv_setpv(svflv, "crash");
1613 else if (defroute->flavour==flImmediate)
1614 sv_setpv(svflv, "immediate");
1615 }
1616 ENTER;
1617 SAVETMPS;
1618 PUSHMARK(SP);
1619 PUTBACK;
1620 perl_call_pv(PERLROUTE, G_EVAL|G_SCALAR);
1621 SPAGAIN;
1622 svret=POPs;
1623 if (SvTRUE(svret))
1624 routeaddr = safe_strdup(SvPV(svret, n_a));
1625 else
1626 routeaddr = NULL;
1627 PUTBACK;
1628 FREETMPS;
1629 LEAVE;
1630
1631 svaddvia = get_sv("addvia", FALSE);
1632 if (svaddvia != NULL) skip_addvia = (SvIV(svaddvia) == 0);
1633
1634 if (SvTRUE(ERRSV))
1635 {
1636 w_log(LL_ERR, "Perl route eval error: %s\n", SvPV(ERRSV, n_a));
1637 do_perlroute = 0;
1638 }
1639 else {
1640 svchange = perl_get_sv("change", FALSE);
1641 if (svchange && SvTRUE(svchange)) {
1642 /* change */
1643 freeMsgBuffers(msg);
1644 prc = SvPV(perl_get_sv("text", FALSE), n_a);
1645 if (n_a == 0) prc = "";
1646 msg->text = safe_strdup(prc);
1647 msg->textLength = strlen(msg->text);
1648 prc = SvPV(perl_get_sv("toname", FALSE), n_a);
1649 if (n_a == 0) prc = "";
1650 msg->toUserName = safe_strdup(prc);
1651 prc = SvPV(perl_get_sv("fromname", FALSE), n_a);
1652 if (n_a == 0) prc = "";
1653 msg->fromUserName = safe_strdup(prc);
1654 prc = SvPV(perl_get_sv("subj", FALSE), n_a);
1655 if (n_a == 0) prc = "";
1656 msg->subjectLine = safe_strdup(prc);
1657 prc = SvPV(perl_get_sv("addr", FALSE), n_a);
1658 if (n_a > 0) parseFtnAddrZS(prc, &(msg->destAddr));
1659 prc = SvPV(perl_get_sv("from", FALSE), n_a);
1660 if (n_a > 0) parseFtnAddrZS(prc, &(msg->origAddr));
1661 /* update message kludges, if needed */
1662 update_addr(msg);
1663 /* process flags, update message if needed */
1664 attr = SvUV(perl_get_sv("attr", FALSE));
1665 msg->attributes = attr & 0xffff;
1666 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
1667 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
1668 msg->textLength = strlen(msg->text);
1669 }
1670 /* process date */
1671 svdate = perl_get_sv("date", FALSE);
1672 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
1673 date = SvUV(svdate);
1674 make_ftsc_date((char*)msg->datetime, localtime(&date));
1675 }
1676 else if ( SvPOK(svdate) ) {
1677 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
1678 if (fts2unix(ptr, NULL) > 0) {
1679 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
1680 msg->datetime[sizeof(msg->datetime)-1] = '\0';
1681 }
1682 }
1683 }
1684
1685 if (routeaddr)
1686 {
1687 char *flv;
1688 static char srouteaddr[32];
1689 svflv = perl_get_sv("flavour", FALSE);
1690
1691 memset(&route, 0, sizeof(route));
1692 if ((route.target = getLink(config, routeaddr)) == NULL) {
1693 route.routeVia = route_extern;
1694 route.viaStr = srouteaddr;
1695 strncpy(srouteaddr, routeaddr, sizeof(srouteaddr));
1696 srouteaddr[sizeof(srouteaddr)-1] = '\0';
1697 }
1698
1699 if ((SvIOK(svflv)) && (SvUV(svflv) > 0)) route.flavour = flag2flv(SvUV(svflv));
1700 else {
1701 flv = SvPV(svflv, n_a); if (n_a == 0) flv = "";
1702 if (flv == NULL || *flv == '\0')
1703 {
1704 if (route.target)
1705 route.flavour = route.target->echoMailFlavour;
1706 else
1707 route.flavour = flHold;
1708 }
1709 #if 1
1710 else if ( (int)(route.flavour = str2flv(flv)) != -1 ) {}
1711 #else
1712 else if (stricmp(flv, "normal") == 0)
1713 route.flavour = flNormal;
1714 else if (stricmp(flv, "hold") == 0)
1715 route.flavour = flHold;
1716 else if (stricmp(flv, "crash") == 0)
1717 route.flavour = flCrash;
1718 else if (stricmp(flv, "direct") == 0)
1719 route.flavour = flDirect;
1720 else if (stricmp(flv, "immediate") == 0)
1721 route.flavour = flImmediate;
1722 #endif
1723 else {
1724 w_log(LL_PERL, "Perl route unknown flavour %s, set to hold", flv);
1725 route.flavour = flHold;
1726 }
1727 }
1728 free(routeaddr);
1729 return &route;
1730 }
1731
1732 }
1733 }
1734 return NULL;
1735 }
1736
perlfilter(s_message * msg,hs_addr pktOrigAddr,int secure)1737 int perlfilter(s_message *msg, hs_addr pktOrigAddr, int secure)
1738 {
1739 char *area = NULL, *prc;
1740 int rc = 0;
1741 unsigned long attr;
1742 time_t date;
1743 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr, *svpktfrom, *svkill;
1744 SV *svdate, *svtext, *svarea, *svsubj, *svsecure, *svret;
1745 SV *svchange, *svattr;
1746 STRLEN n_a;
1747 static int do_perlfilter=1, do_perlfilter2=1;
1748 char *sorig;
1749 char _cur[2] = {0, 0};
1750
1751 if (secure < 0) { VK_START_HOOK(perlfilter2, SUB_FILTER2, 0) }
1752 else { VK_START_HOOK(perlfilter, SUB_FILTER, 0) }
1753
1754 _cur[0] = secure < 0 ? '2' : 0;
1755
1756 perl_setattr = 0;
1757 if (msg->netMail != 1) {
1758 char *p, *p1;
1759 p = msg->text+5;
1760 while (*p == ' ') p++;
1761 p1=strchr(p, '\r');
1762 if (p1 == NULL) p1=p+strlen(p);
1763 area = safe_malloc(p1-p+1);
1764 memcpy(area, p, p1-p);
1765 area[p1-p] = '\0';
1766 }
1767 { dSP;
1768 svfromname = perl_get_sv("fromname", TRUE);
1769 svfromaddr = perl_get_sv("fromaddr", TRUE);
1770 svtoname = perl_get_sv("toname", TRUE);
1771 svdate = perl_get_sv("date", TRUE);
1772 svsubj = perl_get_sv("subject", TRUE);
1773 svtext = perl_get_sv("text", TRUE);
1774 svpktfrom = perl_get_sv("pktfrom", TRUE);
1775 svkill = perl_get_sv("kill", TRUE);
1776 svchange = perl_get_sv("change", TRUE);
1777 svarea = perl_get_sv("area", TRUE);
1778 svtoaddr = perl_get_sv("toaddr", TRUE);
1779 svsecure = perl_get_sv("secure", TRUE);
1780 svattr = perl_get_sv("attr", TRUE);
1781 sv_setpv(svfromname, msg->fromUserName);
1782 sv_setpv(svfromaddr, aka2str(msg->origAddr));
1783 sv_setpv(svtoname, msg->toUserName);
1784
1785 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
1786 sv_setpv(svdate, (char*)msg->datetime);
1787 SvIOK_on(svdate);
1788
1789 sv_setpv(svsubj, msg->subjectLine);
1790 sv_setpv(svtext, msg->text);
1791 sv_setpv(svpktfrom, aka2str(pktOrigAddr));
1792 sv_setsv(svkill, &sv_undef);
1793 sv_setsv(svchange, &sv_undef);
1794 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
1795 if (secure > 0)
1796 sv_setiv(svsecure, 1);
1797 else
1798 sv_setsv(svsecure, &sv_undef);
1799 if (area)
1800 { sv_setpv(svarea, area);
1801 sv_setsv(svtoaddr, &sv_undef);
1802 }
1803 else
1804 { sv_setsv(svarea, &sv_undef);
1805 sv_setpv(svtoaddr, aka2str(msg->destAddr));
1806 }
1807 ENTER;
1808 SAVETMPS;
1809 PUSHMARK(SP);
1810 PUTBACK;
1811 perl_call_pv(secure >= 0 ? PERLFILT : PERLFILT2, G_EVAL|G_SCALAR);
1812 SPAGAIN;
1813 svret=POPs;
1814 if (SvTRUE(svret))
1815 prc = safe_strdup(SvPV(svret, n_a));
1816 else
1817 prc = NULL;
1818 PUTBACK;
1819 FREETMPS;
1820 LEAVE;
1821 if (SvTRUE(ERRSV))
1822 {
1823 w_log(LL_ERR, "Perl filter%s eval error: %s\n", _cur, SvPV(ERRSV, n_a));
1824 if (secure < 0) do_perlfilter2 = 0; else do_perlfilter = 0;
1825 nfree(area);
1826 return 0;
1827 }
1828 svkill = perl_get_sv("kill", FALSE);
1829 if (svkill && SvTRUE(svkill))
1830 { /* kill */
1831 sorig = aka2str5d(msg->origAddr);
1832 if (area)
1833 w_log(LL_PERL, "PerlFilter%s: Area %s from %s %s killed%s%s", _cur,
1834 area, msg->fromUserName, sorig,
1835 prc ? ": " : "", prc ? prc : "");
1836 else
1837 w_log(LL_PERL, "PerlFilter%s: NetMail from %s %s to %s %s killed%s%s", _cur,
1838 msg->fromUserName, sorig,
1839 msg->toUserName, aka2str(msg->destAddr),
1840 prc ? ": " : "", prc ? prc : "");
1841 nfree(sorig);
1842 nfree(prc);
1843 nfree(area);
1844 return 2;
1845 }
1846 svchange = perl_get_sv("change", FALSE);
1847 if (svchange && SvTRUE(svchange))
1848 { /* change */
1849 char *ptr;
1850 freeMsgBuffers(msg);
1851 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
1852 if (n_a == 0) ptr = "";
1853 msg->text = safe_strdup(ptr);
1854 msg->textLength = strlen(msg->text);
1855 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
1856 if (n_a == 0) ptr = "";
1857 msg->toUserName = safe_strdup(ptr);
1858 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
1859 if (n_a == 0) ptr = "";
1860 msg->fromUserName = safe_strdup(ptr);
1861 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
1862 if (n_a == 0) ptr = "";
1863 msg->subjectLine = safe_strdup(ptr);
1864 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
1865 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
1866 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
1867 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
1868 /* update message kludges, if needed */
1869 update_addr(msg);
1870 /* process flags, update message if needed */
1871 attr = SvUV(perl_get_sv("attr", FALSE));
1872 msg->attributes = attr & 0xffff; perl_setattr = 1;
1873 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
1874 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
1875 msg->textLength = strlen(msg->text);
1876 }
1877 /* process date */
1878 svdate = perl_get_sv("date", FALSE);
1879 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
1880 date = SvUV(svdate);
1881 make_ftsc_date((char*)msg->datetime, localtime(&date));
1882 }
1883 else if ( SvPOK(svdate) ) {
1884 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
1885 if (fts2unix(ptr, NULL) > 0) {
1886 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
1887 msg->datetime[sizeof(msg->datetime)-1] = '\0';
1888 }
1889 }
1890 }
1891 if (prc)
1892 {
1893 sorig = aka2str5d(msg->origAddr);
1894 if (area)
1895 w_log(LL_PERL, "PerlFilter%s: Area %s from %s %s: %s", _cur,
1896 area, msg->fromUserName, sorig, prc);
1897 else
1898 w_log(LL_PERL, "PerlFilter%s: NetMail from %s %s to %s %s: %s", _cur,
1899 msg->fromUserName, sorig,
1900 msg->toUserName, aka2str(msg->destAddr), prc);
1901 rc = 1;
1902 nfree(sorig);
1903 nfree(prc);
1904 }
1905 }
1906 nfree(area);
1907 return rc;
1908 }
1909
perlpkt(const char * fname,int secure)1910 int perlpkt(const char *fname, int secure)
1911 {
1912 static int do_perlpkt = 1;
1913 char *prc = NULL;
1914 STRLEN n_a;
1915 SV *svpktname, *svsecure, *svret;
1916
1917 VK_START_HOOK(perlpkt, SUB_PROCESS_PKT, 0)
1918
1919 svpktname = perl_get_sv("pktname", TRUE);
1920 svsecure = perl_get_sv("secure", TRUE);
1921 { dSP;
1922 sv_setpv(svpktname, fname);
1923 if (secure) sv_setiv(svsecure, 1);
1924 else sv_setsv(svsecure, &sv_undef);
1925 ENTER;
1926 SAVETMPS;
1927 PUSHMARK(SP);
1928 PUTBACK;
1929 perl_call_pv(PERLPKT, G_EVAL|G_SCALAR);
1930 SPAGAIN;
1931 svret=POPs;
1932 if (SvTRUE(svret))
1933 prc = safe_strdup(SvPV(svret, n_a));
1934 else
1935 prc = NULL;
1936 PUTBACK;
1937 FREETMPS;
1938 LEAVE;
1939 if (SvTRUE(ERRSV))
1940 {
1941 w_log(LL_ERR, "Perl pkt eval error: %s\n", SvPV(ERRSV, n_a));
1942 do_perlpkt = 0;
1943 }
1944 else if (prc)
1945 {
1946 w_log(LL_PERL, "Packet %s rejected by perl filter: %s", fname, prc);
1947 nfree(prc);
1948 return 1;
1949 }
1950 }
1951 return 0;
1952 }
1953
perlpktdone(const char * fname,int rc)1954 void perlpktdone(const char *fname, int rc)
1955 {
1956 const char *res[] = {NULL, "Security violation", "Can't open pkt",
1957 "Bad pkt format", "Not to us", "Msg tossing problem",
1958 "Unknown error", "Unknown error (pkt already removed)"};
1959 static int do_perlpktdone = 1;
1960 STRLEN n_a;
1961 SV *svpktname, *svrc, *svres;
1962
1963 VK_START_HOOK(perlpktdone, SUB_PKT_DONE, )
1964
1965 { dSP;
1966 svpktname = perl_get_sv("pktname", TRUE);
1967 svrc = perl_get_sv("rc", TRUE);
1968 svres = perl_get_sv("res", TRUE);
1969 sv_setpv(svpktname, fname);
1970 sv_setiv(svrc, rc);
1971 if (rc)
1972 sv_setpv(svres, res[rc]);
1973 else
1974 sv_setsv(svres, &sv_undef);
1975 ENTER;
1976 SAVETMPS;
1977 PUSHMARK(SP);
1978 PUTBACK;
1979 perl_call_pv(PERLPKTDONE, G_EVAL|G_SCALAR);
1980 SPAGAIN;
1981 PUTBACK;
1982 FREETMPS;
1983 LEAVE;
1984 if (SvTRUE(ERRSV))
1985 {
1986 w_log(LL_ERR, "Perl pktdone eval error: %s\n", SvPV(ERRSV, n_a));
1987 do_perlpktdone = 0;
1988 }
1989 }
1990 }
1991
perlafterunp(void)1992 void perlafterunp(void)
1993 {
1994 static int do_perlafterunp = 1;
1995 STRLEN n_a;
1996
1997 VK_START_HOOK(perlafterunp, SUB_AFTER_UNPACK, )
1998
1999 { dSP;
2000 ENTER;
2001 SAVETMPS;
2002 PUSHMARK(SP);
2003 PUTBACK;
2004 perl_call_pv(PERLAFTERUNP, G_EVAL|G_SCALAR);
2005 SPAGAIN;
2006 PUTBACK;
2007 FREETMPS;
2008 LEAVE;
2009 if (SvTRUE(ERRSV))
2010 {
2011 w_log(LL_ERR, "Perl afterunp eval error: %s\n", SvPV(ERRSV, n_a));
2012 do_perlafterunp = 0;
2013 }
2014 }
2015 }
2016
perlbeforepack(void)2017 void perlbeforepack(void)
2018 {
2019 static int do_perlbeforepack = 1;
2020 STRLEN n_a;
2021
2022 VK_START_HOOK(perlbeforepack, SUB_BEFORE_PACK, )
2023
2024 { dSP;
2025 ENTER;
2026 SAVETMPS;
2027 PUSHMARK(SP);
2028 PUTBACK;
2029 perl_call_pv(PERLBEFOREPACK, G_EVAL|G_SCALAR);
2030 SPAGAIN;
2031 PUTBACK;
2032 FREETMPS;
2033 LEAVE;
2034 if (SvTRUE(ERRSV))
2035 {
2036 w_log(LL_ERR, "Perl beforepack eval error: %s\n", SvPV(ERRSV, n_a));
2037 do_perlbeforepack = 0;
2038 }
2039 }
2040 }
2041
perltossbad(s_message * msg,char * areaName,hs_addr pktOrigAddr,char * reason)2042 int perltossbad(s_message *msg, char *areaName, hs_addr pktOrigAddr, char *reason)
2043 {
2044 char *prc, *sorig;
2045 unsigned long attr;
2046 time_t date;
2047 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr, *svpktfrom;
2048 SV *svdate, *svtext, *svarea, *svsubj, *svret, *svchange, *svattr;
2049 SV *svreason;
2050 STRLEN n_a;
2051 static int do_perltossbad=1;
2052
2053 VK_START_HOOK(perltossbad, SUB_TOSSBAD, 0)
2054
2055 { dSP;
2056 svfromname = perl_get_sv("fromname", TRUE);
2057 svfromaddr = perl_get_sv("fromaddr", TRUE);
2058 svtoname = perl_get_sv("toname", TRUE);
2059 svdate = perl_get_sv("date", TRUE);
2060 svsubj = perl_get_sv("subject", TRUE);
2061 svtext = perl_get_sv("text", TRUE);
2062 svpktfrom = perl_get_sv("pktfrom", TRUE);
2063 svchange = perl_get_sv("change", TRUE);
2064 svarea = perl_get_sv("area", TRUE);
2065 svtoaddr = perl_get_sv("toaddr", TRUE);
2066 svattr = perl_get_sv("attr", TRUE);
2067 svreason = perl_get_sv("reason", TRUE);
2068 sv_setpv(svfromname, msg->fromUserName);
2069 sv_setpv(svfromaddr, aka2str(msg->origAddr));
2070 sv_setpv(svtoname, msg->toUserName);
2071
2072 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
2073 sv_setpv(svdate, (char*)msg->datetime);
2074 SvIOK_on(svdate);
2075
2076 sv_setpv(svsubj, msg->subjectLine);
2077 sv_setpv(svtext, msg->text);
2078 sv_setpv(svpktfrom, aka2str(pktOrigAddr));
2079 sv_setsv(svchange, &sv_undef);
2080 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
2081 sv_setpv(svreason, reason);
2082 if (areaName)
2083 { sv_setpv(svarea, areaName);
2084 sv_setsv(svtoaddr, &sv_undef);
2085 }
2086 else
2087 { sv_setsv(svarea, &sv_undef);
2088 sv_setpv(svtoaddr, aka2str(msg->destAddr));
2089 }
2090 ENTER;
2091 SAVETMPS;
2092 PUSHMARK(SP);
2093 PUTBACK;
2094 perl_call_pv(PERLTOSSBAD, G_EVAL|G_SCALAR);
2095 SPAGAIN;
2096 svret=POPs;
2097 if (SvTRUE(svret))
2098 prc = safe_strdup(SvPV(svret, n_a));
2099 else
2100 prc = NULL;
2101 PUTBACK;
2102 FREETMPS;
2103 LEAVE;
2104 if (SvTRUE(ERRSV))
2105 {
2106 w_log(LL_ERR, "Perl tossbad eval error: %s\n", SvPV(ERRSV, n_a));
2107 do_perltossbad = 0;
2108 return 0;
2109 }
2110 if (prc)
2111 { /* kill */
2112 sorig = aka2str5d(msg->origAddr);
2113 if (areaName)
2114 w_log(LL_PERL, "PerlFilter: Area %s from %s %s killed: %s",
2115 areaName, msg->fromUserName, sorig, prc);
2116 else
2117 w_log(LL_PERL, "PerlFilter: NetMail from %s %s to %s %s killed: %s",
2118 msg->fromUserName, sorig,
2119 msg->toUserName, aka2str(msg->destAddr), prc);
2120 nfree(sorig);
2121 nfree(prc);
2122 return 1;
2123 }
2124 svchange = perl_get_sv("change", FALSE);
2125 if (svchange && SvTRUE(svchange))
2126 { /* change */
2127 char *ptr;
2128 freeMsgBuffers(msg);
2129 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
2130 if (n_a == 0) ptr = "";
2131 msg->text = safe_strdup(ptr);
2132 msg->textLength = strlen(msg->text);
2133 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
2134 if (n_a == 0) ptr = "";
2135 msg->toUserName = safe_strdup(ptr);
2136 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
2137 if (n_a == 0) ptr = "";
2138 msg->fromUserName = safe_strdup(ptr);
2139 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
2140 if (n_a == 0) ptr = "";
2141 msg->subjectLine = safe_strdup(ptr);
2142 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
2143 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
2144 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
2145 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
2146 /* update message kludges, if needed */
2147 update_addr(msg);
2148 /* process flags, update message if needed */
2149 attr = SvUV(perl_get_sv("attr", FALSE));
2150 msg->attributes = attr & 0xffff;
2151 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
2152 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
2153 msg->textLength = strlen(msg->text);
2154 }
2155 /* process date */
2156 svdate = perl_get_sv("date", FALSE);
2157 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
2158 date = SvUV(svdate);
2159 make_ftsc_date((char*)msg->datetime, localtime(&date));
2160 }
2161 else if ( SvPOK(svdate) ) {
2162 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
2163 if (fts2unix(ptr, NULL) > 0) {
2164 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
2165 msg->datetime[sizeof(msg->datetime)-1] = '\0';
2166 }
2167 }
2168 }
2169 }
2170 return 0;
2171
2172 }
2173
perl_echolist(char ** report,s_listype type,ps_arealist al,char * aka)2174 int perl_echolist(char **report, s_listype type, ps_arealist al, char *aka)
2175 {
2176 int i, rc, len, max;
2177 char *s;
2178 AV *av;
2179 SV *svreport, *svlist, *svret;
2180 STRLEN n_a;
2181 static int do_perlecholist = 1;
2182
2183 VK_START_HOOK(perlecholist, SUB_ON_ECHOLIST, 0)
2184
2185 { dSP;
2186 svreport = perl_get_sv("report", TRUE);
2187 sv_setpv(svreport, *report);
2188 av = newAV();
2189 for (max = i = 0; i < al->count; i++) {
2190 len = strlen(al->areas[i].tag);
2191 if (len > max) max = len;
2192 av_push(av, newSVpvn(al->areas[i].tag, len));
2193 }
2194 svlist = newRV_inc((struct sv*)av);
2195
2196 ENTER;
2197 SAVETMPS;
2198 PUSHMARK(SP);
2199 XPUSHs(sv_2mortal(newSViv(type))); /* $_[0]: type (0:all,1:lnk,2:unl) */
2200 XPUSHs(sv_2mortal(svlist)); /* $_[1]: pointer to array of tags */
2201 XPUSHs(sv_2mortal(newSVpv(aka, 0))); /* $_[2]: address of client */
2202 XPUSHs(sv_2mortal(newSViv(max))); /* $_[3]: max echotag length */
2203 PUTBACK;
2204 perl_call_pv(PERLONECHOLIST, G_EVAL|G_SCALAR);
2205 SPAGAIN;
2206 svret = POPs;
2207 if (!SvOK(svret)) rc = 0; else rc = SvIV(svret);
2208 PUTBACK;
2209 FREETMPS;
2210 LEAVE;
2211 av_clear(av); av_undef(av);
2212 if (SvTRUE(ERRSV))
2213 {
2214 w_log(LL_ERR, "Perl on_echolist eval error: %s\n", SvPV(ERRSV, n_a));
2215 do_perlecholist = 0;
2216 return 0;
2217 }
2218 switch (rc) {
2219 case 1: /* set report to $report only */
2220 case 2: /* set report to $report, append footer */
2221 s = SvPV(perl_get_sv("report", FALSE), n_a);
2222 if (n_a == 0) s = "";
2223 *report = sstrdup(s);
2224 return (rc == 1);
2225 default: /* don't change report */
2226 return 0;
2227 }
2228 }
2229 return 0;
2230 }
2231
perl_afixcmd(char ** report,int cmd,char * aka,char * line)2232 int perl_afixcmd(char **report, int cmd, char *aka, char *line)
2233 {
2234 int rc;
2235 SV *svreport, *svret;
2236 STRLEN n_a;
2237 static int do_perlafixcmd = 1;
2238
2239 VK_START_HOOK(perlafixcmd, SUB_ON_AFIXCMD, 0)
2240
2241 { dSP;
2242 svreport = perl_get_sv("report", TRUE);
2243 if (*report) sv_setpv(svreport, *report);
2244
2245 ENTER;
2246 SAVETMPS;
2247 PUSHMARK(SP);
2248 XPUSHs(sv_2mortal(newSViv(cmd))); /* $_[0]: command */
2249 XPUSHs(sv_2mortal(newSVpv(aka, 0))); /* $_[1]: aka */
2250 XPUSHs(sv_2mortal(newSVpv(line, 0))); /* $_[2]: request line */
2251 PUTBACK;
2252 perl_call_pv(PERLONAFIXCMD, G_EVAL|G_SCALAR);
2253 SPAGAIN;
2254 svret = POPs;
2255 if (!SvOK(svret)) rc = 0; else rc = SvIV(svret);
2256 PUTBACK;
2257 FREETMPS;
2258 LEAVE;
2259 if (SvTRUE(ERRSV))
2260 {
2261 w_log(LL_ERR, "Perl on_afixcmd eval error: %s\n", SvPV(ERRSV, n_a));
2262 do_perlafixcmd = 0;
2263 return 0;
2264 }
2265 if (rc) {
2266 char *s = SvPV(perl_get_sv("report", FALSE), n_a);
2267 if (n_a == 0 || s == NULL) s = "";
2268 *report = sstrdup(s);
2269 return 1;
2270 }
2271 else return 0;
2272 }
2273 return 0;
2274 }
2275
perl_afixreq(s_message * msg,hs_addr pktOrigAddr)2276 int perl_afixreq(s_message *msg, hs_addr pktOrigAddr)
2277 {
2278 int rc = 0;
2279 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr, *svpktfrom;
2280 SV *svtext, *svsubj, *svret;
2281 STRLEN n_a;
2282 static int do_perlafixreq=1;
2283
2284 VK_START_HOOK(perlafixreq, SUB_ON_AFIXREQ, 0)
2285
2286 { dSP;
2287 svfromname = perl_get_sv("fromname", TRUE);
2288 svfromaddr = perl_get_sv("fromaddr", TRUE);
2289 svtoname = perl_get_sv("toname", TRUE);
2290 svtoaddr = perl_get_sv("toaddr", TRUE);
2291 svsubj = perl_get_sv("subject", TRUE);
2292 svtext = perl_get_sv("text", TRUE);
2293 svpktfrom = perl_get_sv("pktfrom", TRUE);
2294 sv_setpv(svfromname, msg->fromUserName);
2295 sv_setpv(svfromaddr, aka2str(msg->origAddr));
2296 sv_setpv(svtoname, msg->toUserName);
2297 sv_setpv(svtoaddr, aka2str(msg->destAddr));
2298 sv_setpv(svsubj, msg->subjectLine);
2299 sv_setpv(svtext, msg->text);
2300 sv_setpv(svpktfrom, aka2str(pktOrigAddr));
2301
2302 ENTER;
2303 SAVETMPS;
2304 PUSHMARK(SP);
2305 PUTBACK;
2306 perl_call_pv(PERLONAFIXREQ, G_EVAL|G_SCALAR);
2307 SPAGAIN;
2308 svret=POPs;
2309 if (!SvOK(svret)) rc = 0; else rc = SvIV(svret);
2310 PUTBACK;
2311 FREETMPS;
2312 LEAVE;
2313 if (SvTRUE(ERRSV))
2314 {
2315 w_log(LL_ERR, "Perl on_afixreq eval error: %s\n", SvPV(ERRSV, n_a));
2316 do_perlafixreq = 0;
2317 return 0;
2318 }
2319 if (rc)
2320 { /* change */
2321 char *ptr;
2322 freeMsgBuffers(msg);
2323 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
2324 if (n_a == 0) ptr = "";
2325 msg->text = safe_strdup(ptr);
2326 msg->textLength = strlen(msg->text);
2327 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
2328 if (n_a == 0) ptr = "";
2329 msg->toUserName = safe_strdup(ptr);
2330 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
2331 if (n_a == 0) ptr = "";
2332 msg->fromUserName = safe_strdup(ptr);
2333 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
2334 if (n_a == 0) ptr = "";
2335 msg->subjectLine = safe_strdup(ptr);
2336 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
2337 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
2338 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
2339 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
2340 return 1;
2341 }
2342 }
2343 return 0;
2344 }
2345
perl_putmsg(s_area * echo,s_message * msg)2346 int perl_putmsg(s_area *echo, s_message *msg)
2347 {
2348 int rc = 1;
2349 unsigned long attr;
2350 time_t date;
2351 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr;
2352 SV *svdate, *svtext, *svarea, *svnetmail, *svsubj, *svret;
2353 SV *svchange, *svattr;
2354 STRLEN n_a;
2355 static int do_perlputmsg=1;
2356
2357 VK_START_HOOK(perlputmsg, SUB_PUTMSG, 1)
2358
2359 { dSP;
2360 svfromname = perl_get_sv("fromname", TRUE);
2361 svfromaddr = perl_get_sv("fromaddr", TRUE);
2362 svtoname = perl_get_sv("toname", TRUE);
2363 svdate = perl_get_sv("date", TRUE);
2364 svsubj = perl_get_sv("subject", TRUE);
2365 svtext = perl_get_sv("text", TRUE);
2366 svchange = perl_get_sv("change", TRUE);
2367 svarea = perl_get_sv("area", TRUE);
2368 svtoaddr = perl_get_sv("toaddr", TRUE);
2369 svattr = perl_get_sv("attr", TRUE);
2370 svnetmail = perl_get_sv("netmail", TRUE);
2371 sv_setpv(svfromname, msg->fromUserName);
2372 sv_setpv(svfromaddr, aka2str(msg->origAddr));
2373 sv_setpv(svtoname, msg->toUserName);
2374 sv_setpv(svtoaddr, aka2str(msg->destAddr));
2375
2376 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
2377 sv_setpv(svdate, (char*)msg->datetime);
2378 SvIOK_on(svdate);
2379
2380 sv_setpv(svsubj, msg->subjectLine);
2381 sv_setpv(svtext, msg->text);
2382 sv_setsv(svchange, &sv_undef);
2383 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
2384 sv_setpv(svarea, echo->areaName);
2385 /* todo: maybe replace to better criteria */
2386 sv_setiv(svnetmail, msg->netMail);
2387
2388 ENTER;
2389 SAVETMPS;
2390 PUSHMARK(SP);
2391 PUTBACK;
2392 perl_call_pv(PERLPUTMSG, G_EVAL|G_SCALAR);
2393 SPAGAIN;
2394 svret=POPs;
2395 if (!SvOK(svret)) rc = 1; else rc = SvIV(svret);
2396 PUTBACK;
2397 FREETMPS;
2398 LEAVE;
2399 if (SvTRUE(ERRSV))
2400 {
2401 w_log(LL_ERR, "Perl putmsg eval error: %s\n", SvPV(ERRSV, n_a));
2402 do_perlputmsg = 0;
2403 return 1;
2404 }
2405 svchange = perl_get_sv("change", FALSE);
2406 if (rc && svchange && SvTRUE(svchange))
2407 { /* change */
2408 char *ptr;
2409 freeMsgBuffers(msg);
2410 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
2411 if (n_a == 0) ptr = "";
2412 msg->text = safe_strdup(ptr);
2413 msg->textLength = strlen(msg->text);
2414 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
2415 if (n_a == 0) ptr = "";
2416 msg->toUserName = safe_strdup(ptr);
2417 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
2418 if (n_a == 0) ptr = "";
2419 msg->fromUserName = safe_strdup(ptr);
2420 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
2421 if (n_a == 0) ptr = "";
2422 msg->subjectLine = safe_strdup(ptr);
2423 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
2424 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
2425 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
2426 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
2427 /* update message kludges, if needed */
2428 if (msg->netMail) update_addr(msg);
2429 /* process flags, update message if needed */
2430 attr = SvUV(perl_get_sv("attr", FALSE));
2431 msg->attributes = attr & 0xffff;
2432 if (msg->netMail)
2433 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
2434 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
2435 msg->textLength = strlen(msg->text);
2436 }
2437 /* process date */
2438 svdate = perl_get_sv("date", FALSE);
2439 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
2440 date = SvUV(svdate);
2441 make_ftsc_date((char*)msg->datetime, localtime(&date));
2442 }
2443 else if ( SvPOK(svdate) ) {
2444 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
2445 if (fts2unix(ptr, NULL) > 0) {
2446 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
2447 msg->datetime[sizeof(msg->datetime)-1] = '\0';
2448 }
2449 }
2450 }
2451 }
2452 return rc;
2453 }
2454
perl_export(s_area * echo,s_link * link,s_message * msg)2455 int perl_export(s_area *echo, s_link *link, s_message *msg)
2456 {
2457 char *prc;
2458 unsigned long attr;
2459 time_t date;
2460 SV *svfromname, *svtoname, *svtoaddr, *svsubj, *svattr, *svdate, *svtext;
2461 SV *svarea, *svchange, *svret;
2462 STRLEN n_a;
2463 static int do_perlexport=1;
2464
2465 VK_START_HOOK(perlexport, SUB_EXPORT, 1)
2466
2467 { dSP;
2468 svtoaddr = perl_get_sv("toaddr", TRUE);
2469 svfromname = perl_get_sv("fromname", TRUE);
2470 svtoname = perl_get_sv("toname", TRUE);
2471 svdate = perl_get_sv("date", TRUE);
2472 svsubj = perl_get_sv("subject", TRUE);
2473 svtext = perl_get_sv("text", TRUE);
2474 svchange = perl_get_sv("change", TRUE);
2475 svarea = perl_get_sv("area", TRUE);
2476 svattr = perl_get_sv("attr", TRUE);
2477 sv_setpv(svtoaddr, aka2str(link->hisAka));
2478 sv_setpv(svfromname, msg->fromUserName);
2479 sv_setpv(svtoname, msg->toUserName);
2480
2481 sv_setuv(svdate, (unsigned long)fts2unix((char*)msg->datetime, NULL) );
2482 sv_setpv(svdate, (char*)msg->datetime);
2483 SvIOK_on(svdate);
2484
2485 sv_setpv(svsubj, msg->subjectLine);
2486 sv_setpv(svtext, msg->text);
2487 sv_setsv(svchange, &sv_undef);
2488 sv_setpv(svarea, echo->areaName);
2489 sv_setuv(svattr, msg->attributes | parse_flags(msg->text));
2490
2491 ENTER;
2492 SAVETMPS;
2493 PUSHMARK(SP);
2494 PUTBACK;
2495 perl_call_pv(PERLEXPORT, G_EVAL|G_SCALAR);
2496 SPAGAIN;
2497 svret=POPs;
2498 if (SvTRUE(svret))
2499 prc = safe_strdup(SvPV(svret, n_a));
2500 else
2501 prc = NULL;
2502 PUTBACK;
2503 FREETMPS;
2504 LEAVE;
2505 if (SvTRUE(ERRSV))
2506 {
2507 w_log(LL_ERR, "Perl export eval error: %s\n", SvPV(ERRSV, n_a));
2508 do_perlexport = 0;
2509 return 1;
2510 }
2511
2512 if (prc)
2513 {
2514 w_log(LL_PERL, "PerlExport: Area %s, link %s: %s",
2515 echo->areaName, aka2str(link->hisAka), prc);
2516 return 0;
2517 }
2518
2519 svchange = perl_get_sv("change", FALSE);
2520 if (svchange && SvTRUE(svchange))
2521 { /* change */
2522 char *ptr;
2523 freeMsgBuffers(msg);
2524 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
2525 if (n_a == 0) ptr = "";
2526 msg->text = safe_strdup(ptr);
2527 msg->textLength = strlen(msg->text);
2528 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
2529 if (n_a == 0) ptr = "";
2530 msg->toUserName = safe_strdup(ptr);
2531 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
2532 if (n_a == 0) ptr = "";
2533 msg->fromUserName = safe_strdup(ptr);
2534 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
2535 if (n_a == 0) ptr = "";
2536 msg->subjectLine = safe_strdup(ptr);
2537 /* process flags, update message if needed */
2538 attr = SvUV(perl_get_sv("attr", FALSE));
2539 msg->attributes = attr & 0xffff;
2540 if (msg->netMail)
2541 if ((ptr = update_flags(msg->text, attr, MODE_REPLACE)) != NULL) {
2542 if (ptr != msg->text) { free(msg->text); msg->text = ptr; }
2543 msg->textLength = strlen(msg->text);
2544 }
2545 /* process date */
2546 svdate = perl_get_sv("date", FALSE);
2547 if ( (SvIOK(svdate)) && (SvUV(svdate) > 0) ) {
2548 date = SvUV(svdate);
2549 make_ftsc_date((char*)msg->datetime, localtime(&date));
2550 }
2551 else if ( SvPOK(svdate) ) {
2552 ptr = SvPV(svdate, n_a); if (n_a == 0) ptr = "";
2553 if (fts2unix(ptr, NULL) > 0) {
2554 strncpy((char*)msg->datetime, ptr, sizeof(msg->datetime));
2555 msg->datetime[sizeof(msg->datetime)-1] = '\0';
2556 }
2557 }
2558 }
2559 }
2560 return 1;
2561 }
2562
perl_robotmsg(s_message * msg,char * type)2563 int perl_robotmsg(s_message *msg, char *type)
2564 {
2565 int rc = 0;
2566 SV *svfromname, *svfromaddr, *svtoname, *svtoaddr;
2567 SV *svtext, *svsubj, *svret, *svtyp;
2568 STRLEN n_a;
2569 static int do_perlrobotmsg = 1;
2570
2571 VK_START_HOOK(perlrobotmsg, SUB_ON_ROBOTMSG, 0)
2572
2573 { dSP;
2574 svtyp = perl_get_sv("type", TRUE);
2575 svfromname = perl_get_sv("fromname", TRUE);
2576 svfromaddr = perl_get_sv("fromaddr", TRUE);
2577 svtoname = perl_get_sv("toname", TRUE);
2578 svtoaddr = perl_get_sv("toaddr", TRUE);
2579 svsubj = perl_get_sv("subject", TRUE);
2580 svtext = perl_get_sv("text", TRUE);
2581
2582 if (type) sv_setpv(svtyp, type); else sv_setsv(svtyp, &sv_undef);
2583 sv_setpv(svfromname, msg->fromUserName);
2584 sv_setpv(svfromaddr, aka2str(msg->origAddr));
2585 sv_setpv(svtoname, msg->toUserName);
2586 sv_setpv(svtoaddr, aka2str(msg->destAddr));
2587 sv_setpv(svsubj, msg->subjectLine);
2588 sv_setpv(svtext, msg->text);
2589
2590 ENTER;
2591 SAVETMPS;
2592 PUSHMARK(SP);
2593 PUTBACK;
2594 perl_call_pv(PERLROBOTMSG, G_EVAL|G_SCALAR);
2595 SPAGAIN;
2596 svret=POPs;
2597 if (!SvOK(svret)) rc = 0; else rc = SvIV(svret);
2598 PUTBACK;
2599 FREETMPS;
2600 LEAVE;
2601 if (SvTRUE(ERRSV))
2602 {
2603 w_log(LL_ERR, "Perl on_robotmsg eval error: %s\n", SvPV(ERRSV, n_a));
2604 do_perlrobotmsg = 0;
2605 return 0;
2606 }
2607 if (rc)
2608 { /* change */
2609 char *ptr;
2610 freeMsgBuffers(msg);
2611 ptr = SvPV(perl_get_sv("text", FALSE), n_a);
2612 if (n_a == 0) ptr = "";
2613 msg->text = safe_strdup(ptr);
2614 msg->textLength = strlen(msg->text);
2615 ptr = SvPV(perl_get_sv("toname", FALSE), n_a);
2616 if (n_a == 0) ptr = "";
2617 msg->toUserName = safe_strdup(ptr);
2618 ptr = SvPV(perl_get_sv("fromname", FALSE), n_a);
2619 if (n_a == 0) ptr = "";
2620 msg->fromUserName = safe_strdup(ptr);
2621 ptr = SvPV(perl_get_sv("subject", FALSE), n_a);
2622 if (n_a == 0) ptr = "";
2623 msg->subjectLine = safe_strdup(ptr);
2624 ptr = SvPV(perl_get_sv("toaddr", FALSE), n_a);
2625 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->destAddr));
2626 ptr = SvPV(perl_get_sv("fromaddr", FALSE), n_a);
2627 if (n_a > 0) parseFtnAddrZS(ptr, &(msg->origAddr));
2628 return 1;
2629 }
2630 }
2631 return 0;
2632 }
2633
2634 #ifdef __OS2__
strdup(const char * src)2635 char *strdup(const char *src)
2636 {
2637 char *dest = malloc(strlen(src)+1);
2638 if (dest) strcpy(dest, src);
2639 return dest;
2640 }
2641 #endif
2642