1 /**********************************************************
2 * perl support
3 **********************************************************/
4 /*
5 * $Id: perl.c,v 1.8 2005/08/22 17:17:18 mitry Exp $
6 *
7 * $Log: perl.c,v $
8 * Revision 1.8 2005/08/22 17:17:18 mitry
9 * Removed useless static function
10 *
11 * Revision 1.7 2005/08/16 15:17:22 mitry
12 * Removed unused ninfo_t.haswtime field
13 *
14 * Revision 1.6 2005/05/16 11:17:30 mitry
15 * Updated function prototypes. Changed code a bit.
16 *
17 * Revision 1.5 2005/04/08 18:11:12 mitry
18 * Insignificant changes
19 *
20 * Revision 1.4 2005/02/12 19:01:10 mitry
21 * Minor cosmetic changes.
22 *
23 */
24
25 #include "config.h"
26
27 #ifdef WITH_PERL
28
29 #include "have.h"
30 #include "types.h"
31
32 #undef WORD
33 #undef PACKAGE
34
35 #include <EXTERN.h>
36 #include <perl.h>
37 #include <XSUB.h>
38
39 #undef keyword
40 #undef DEBUG
41
42 #include "defs.h"
43 #include "qslib.h"
44 #include "ftn.h"
45 #include "tools.h"
46 #include "mailer.h"
47 #include "globals.h"
48 #include "qconf.h"
49 #include "qipc.h"
50
51
52 #ifndef sv_undef
53 # define sv_undef PL_sv_undef
54 #endif
55 #define pladd_int(_sv,_name,_v) if((_sv=perl_get_sv(_name,TRUE))) { \
56 sv_setiv(_sv,(_v));SvREADONLY_on(_sv);}
57 #define pladd_str(_sv,_name,_v) if((_sv=perl_get_sv(_name,TRUE))) { \
58 if(_v)sv_setpv(_sv,(_v));else sv_setsv(_sv,&sv_undef);SvREADONLY_on(_sv);}
59 #define pladd_strz(_sv,_name,_v) if((_sv=perl_get_sv(_name,TRUE))) { \
60 sv_setpv(_sv,SS(_v));SvREADONLY_on(_sv);}
61 #define plhadd_sv(_hv,_sv,_name) if(_sv) { \
62 SvREADONLY_on(_sv);hv_store(_hv,_name,strlen(_name),_sv,0);}
63 #define plhadd_str(_hv,_sv,_name,_v) if((_v)&&(_sv=newSVpv((_v),0))) \
64 { SvREADONLY_on(_sv);hv_store(_hv,_name,strlen(_name),_sv,0); \
65 } else hv_store(_hv,_name,strlen(_name),&sv_undef,0);
66 #define plhadd_int(_hv,_sv,_name,_v) if((_sv=newSViv((_v)))) { \
67 SvREADONLY_on(_sv);hv_store(_hv,_name,strlen(_name),_sv,0);}
68 #define ploffRO(_sv) if(_sv) {SvREADONLY_off(_sv);}
69 #define PerlHave(_t) (perl&&(perl_nc&(1<<(_t))))
70
71 typedef enum {
72 PERL_ON_INIT,
73 PERL_ON_EXIT,
74 PERL_ON_LOG,
75 PERL_ON_CALL,
76 PERL_ON_SESSION,
77 PERL_END_SESSION,
78 PERL_ON_RECV,
79 PERL_END_RECV,
80 PERL_ON_SEND,
81 PERL_END_SEND
82 } perl_subs;
83
84 static char *perl_subnames[]={
85 "on_init",
86 "on_exit",
87 "on_log",
88 "on_call",
89 "on_session",
90 "end_session",
91 "on_recv",
92 "end_recv",
93 "on_send",
94 "end_send"
95 };
96
97 static struct {char *name;int val;} perl_const[]={
98 {"S_OK",S_OK},
99 {"S_NODIAL",S_NODIAL},
100 {"S_REDIAL",S_REDIAL},
101 {"S_BUSY",S_BUSY},
102 {"S_FAILURE",S_FAILURE},
103 {"S_HOLDR",S_HOLDR},
104 {"S_HOLDX",S_HOLDX},
105 {"S_HOLDA",S_HOLDA},
106 {"S_ADDTRY",S_ADDTRY},
107 {"F_OK",FOP_OK},
108 {"F_CONT",FOP_CONT},
109 {"F_SKIP",FOP_SKIP},
110 {"F_ERR",FOP_ERROR},
111 {"F_SUSPEND",FOP_SUSPEND}
112 };
113
114 static PerlInterpreter *perl=NULL;
115 static unsigned perl_nc=0;
116 unsigned short perl_flg=0;
117
sub_err(int sub)118 static void sub_err(int sub)
119 {
120 STRLEN len;
121 char *s=SvPV(ERRSV,len);
122 if(!s||!len)s="(null message)";
123 write_log("perl %s error:%s%s",perl_subnames[sub],strchr(s,'\n')?"\n":" ",s);
124 }
125
XS(perl_wlog)126 static XS(perl_wlog)
127 {
128 dXSARGS;
129 int lvl=0;
130 char *str;
131 STRLEN len;
132 if(items==1||items==2) {
133 if(items==2)lvl=SvIV(ST(0));
134 str=(char*)SvPV(ST((items-1)),len);
135 if(!lvl)write_log("%s",len?str:"(empty perl log)");
136 else DEBUG(('P',lvl,"%s",len?str:NULL));
137 } else write_log("perl wlog() error: wrong number of args");
138 XSRETURN_EMPTY;
139 }
140
XS(perl_setflag)141 static XS(perl_setflag)
142 {
143 dXSARGS;
144 int num,arg;
145 if(items==2) {
146 num=SvIV(ST(0));
147 arg=SvTRUE(ST(1));
148 DEBUG(('P',3,"perl setflag(%d,%d)",num,arg));
149 if(num<0||num>9)write_log("perl setflags() error: illegal argument");
150 else {
151 if(arg)perl_flg|=1<<num;
152 else perl_flg&=~(1<<num);
153 }
154
155 } else write_log("perl setflags() error: wrong number of args");
156 XSRETURN_EMPTY;
157 }
158
XS(perl_qexpr)159 static XS(perl_qexpr)
160 {
161 dXSARGS;
162 int rc=0;
163 char *str;
164 STRLEN len;
165 slist_t *sl=NULL;
166 if(items==1) {
167 str=(char*)SvPV(ST(0),len);
168 if(str&&len) {
169 slist_add(&sl,str);
170 rc=flagexp(sl,2);
171 slist_kill(&sl);
172 }
173 DEBUG(('P',3,"perl qexpr(%s), rc=%d",str,rc));
174 } else write_log("perl qexpr() error: wrong number of args");
175 XSRETURN_IV(rc);
176 }
177
perl_xs_init(void)178 static void perl_xs_init(void)
179 {
180 static char *file=__FILE__;
181 newXS("wlog",perl_wlog,file);
182 newXS("setflag",perl_setflag,file);
183 newXS("qexpr",perl_qexpr,file);
184 }
185
perl_setup(int daemon,int init)186 static void perl_setup(int daemon, int init)
187 {
188 int i;
189 SV *sv;
190 AV *av,*ava;
191 HV *hv,*hva;
192 cfgitem_t *c;
193 slist_t *sl;
194 falist_t *al;
195 faslist_t *fasl;
196 pladd_int(sv,"init",init);
197 pladd_int(sv,"daemon",daemon);
198 pladd_str(sv,"conf",configname);
199 hv=perl_get_hv("conf",TRUE);
200 hv_clear(hv);
201 for(i=0;i<CFG_NNN;i++)
202 for(c=configtab[i].items;c;c=c->next) {
203 if(c->condition)continue;
204 switch(configtab[i].type) {
205 case C_PATH: case C_STR: /* $conf{kw} */
206 plhadd_str(hv,sv,configtab[i].keyword,c->value.v_char);
207 break;
208 case C_INT: case C_OCT: case C_YESNO: /* $conf{kw} */
209 plhadd_int(hv,sv,configtab[i].keyword,c->value.v_int);
210 break;
211 case C_STRL: /* @conf{kw} */
212 av=newAV();
213 for(sl=c->value.v_sl;sl;sl=sl->next) {
214 sv=newSVpv(sl->str,0);
215 SvREADONLY_on(sv);
216 av_push(av,sv);
217 }
218 sv=newRV_noinc((SV*)av);
219 plhadd_sv(hv,sv,configtab[i].keyword);
220 break;
221 case C_ADDRL: /* @conf{kw} */
222 av=newAV();
223 for(al=c->value.v_al;al;al=al->next) {
224 sv=newSVpv(al->addr.d?ftnaddrtoda(&al->addr):ftnaddrtoa(&al->addr),0);
225 SvREADONLY_on(sv);
226 av_push(av,sv);
227 }
228 sv=newRV_noinc((SV*)av);
229 plhadd_sv(hv,sv,configtab[i].keyword);
230 break;
231 case C_ADRSTRL: /* @conf{kw}{adr|str} */
232 av=newAV();ava=newAV();
233 for(fasl=c->value.v_fasl;fasl;fasl=fasl->next) {
234 sv=newSVpv(fasl->addr.d?ftnaddrtoda(&fasl->addr):ftnaddrtoa(&fasl->addr),0);
235 SvREADONLY_on(sv);
236 av_push(ava,sv);
237 sv=newSVpv(fasl->str,0);
238 SvREADONLY_on(sv);
239 av_push(av,sv);
240 }
241 hva=newHV();
242 sv=newRV_noinc((SV*)ava);
243 plhadd_sv(hva,sv,"adr");
244 sv=newRV_noinc((SV*)av);
245 plhadd_sv(hva,sv,"str");
246 sv=newRV_noinc((SV*)hva);
247 plhadd_sv(hv,sv,configtab[i].keyword);
248 break;
249 }
250 }
251 perl_flg=0;
252 }
253
perl_init(const char * script,int mode)254 int perl_init(const char *script, int mode)
255 {
256 int rc;
257 SV *sv;
258 char *perlargs[]={"",NULL,NULL};
259 if(!script||!*script)return 0;
260 DEBUG(('P',2,"perl_init(%s, %d)",script,mode));
261 if(!fexist(script)||access(script,R_OK)) {
262 perl=NULL;
263 write_log("can't access perlfile %s: %s",script,strerror(errno));
264 return 0;
265 }
266 perl=perl_alloc();
267 if(perl) {
268 perlargs[1] = (char *) script;
269 perl_construct(perl);
270 rc=perl_parse(perl,perl_xs_init,2,perlargs,NULL);
271 } else {
272 write_log("perl allocation error");
273 return 0;
274 }
275 #ifdef PERL_EXIT_DESTRUCT_END
276 PL_exit_flags|=PERL_EXIT_DESTRUCT_END;
277 #endif
278 if(rc) {
279 perl_destruct(perl);
280 perl_free(perl);
281 perl=NULL;
282 write_log("can't parse perlfile %s",script);
283 return 0;
284 }
285 perl_run(perl);
286 for(rc=0,perl_nc=0;rc<sizeof(perl_subnames)/sizeof(*perl_subnames);rc++)
287 if(perl_get_cv(perl_subnames[rc],FALSE))perl_nc|=1<<rc;
288 if(!perl_nc) {
289 perl_done(0);
290 return 0;
291 }
292 pladd_strz(sv,"version",version);
293 perl_setup(mode,1);
294 for(rc=0;rc<sizeof(perl_const)/sizeof(*perl_const);rc++)
295 pladd_int(sv,perl_const[rc].name,perl_const[rc].val);
296 perl_on_std(PERL_ON_INIT);
297 return 1;
298 }
299
perl_done(int rc)300 void perl_done(int rc)
301 {
302 if(perl) {
303 SV *sv;
304 DEBUG(('P',2,"perl_done(%d)",rc));
305 pladd_int(sv,"emerg",rc);
306 perl_on_std(PERL_ON_EXIT);
307 perl_destruct(perl);
308 perl_free(perl);
309 perl=NULL;
310 perl_nc=0;
311 }
312 }
313
perl_on_reload(int mode)314 void perl_on_reload(int mode)
315 {
316 if(perl) {
317 DEBUG(('P',4,"perl_reload(%d)",mode));
318 perl_setup(!mode,0);
319 perl_on_std(PERL_ON_INIT);
320 }
321 }
322
perl_on_std(int sub)323 void perl_on_std(int sub)
324 {
325 if(PerlHave(sub)) {
326 dSP;
327 DEBUG(('P',4,"perl_on_std(%s)",perl_subnames[sub]));
328 ENTER;
329 SAVETMPS;
330 PUSHMARK(SP);
331 PUTBACK;
332 perl_call_pv(perl_subnames[sub],G_EVAL|G_VOID|G_NOARGS);
333 SPAGAIN;
334 PUTBACK;
335 FREETMPS;
336 LEAVE;
337 if(SvTRUE(ERRSV))sub_err(sub);
338 }
339 }
340
perl_on_log(char * str)341 void perl_on_log(char *str)
342 {
343 static int Lock=0;
344 if(!Lock&&PerlHave(PERL_ON_LOG)) {
345 SV *svret,*sv;
346 STRLEN len;
347 int rc=0;
348 dSP;
349 Lock=1;
350 DEBUG(('P',5,"perl_on_log(%s)",str));
351 pladd_strz(sv,"_",str);ploffRO(sv);
352 ENTER;
353 SAVETMPS;
354 PUSHMARK(SP);
355 PUTBACK;
356 perl_call_pv(perl_subnames[PERL_ON_LOG],G_EVAL|G_SCALAR|G_NOARGS);
357 SPAGAIN;
358 svret=POPs;
359 if(SvOK(svret))rc=SvTRUE(svret);
360 PUTBACK;
361 FREETMPS;
362 LEAVE;
363 if(SvTRUE(ERRSV)) {
364 sub_err(PERL_ON_LOG);
365 rc=1;
366 } else if(rc&&sv) {
367 char *p=SvPV(sv,len);
368 if(p&&len)
369 xstrcpy(str,p,MIN(len+1,LARGE_STRING-1));
370 }
371 Lock=0;
372 }
373 }
374
perl_on_call(const ftnaddr_t * fa,const char * site,const char * port)375 int perl_on_call(const ftnaddr_t *fa, const char *site, const char *port)
376 {
377 if(PerlHave(PERL_ON_CALL)) {
378 SV *sv,*svret;
379 int rc=S_OK;
380 dSP;
381 DEBUG(('P',4,"perl_on_call(%s, %s, %s)",ftnaddrtoa(fa),site,port));
382 pladd_strz(sv,"addr",ftnaddrtoa(fa));
383 pladd_int(sv,"tcpip",port?0:1);
384 pladd_int(sv,"binkp",bink);
385 pladd_str(sv,"port",port?port:"ip");
386 pladd_str(sv,"site",site);
387 ENTER;
388 SAVETMPS;
389 PUSHMARK(SP);
390 PUTBACK;
391 perl_call_pv(perl_subnames[PERL_ON_CALL],G_EVAL|G_SCALAR|G_NOARGS);
392 SPAGAIN;
393 svret=POPs;
394 if(SvOK(svret))rc=SvIV(svret);
395 PUTBACK;
396 FREETMPS;
397 LEAVE;
398 if(SvTRUE(ERRSV)) {
399 sub_err(PERL_ON_CALL);
400 rc=S_OK;
401 }
402 DEBUG(('P',5,"perl_on_call() returns %d",rc));
403 return rc;
404 }
405 return S_OK;
406 }
407
perl_on_session(char * sysflags)408 int perl_on_session(char *sysflags)
409 {
410 if(PerlHave(PERL_ON_SESSION)) {
411 SV *sv,*svret;
412 falist_t *fa;
413 flist_t *lst;
414 int rc=S_OK;
415 char *p;
416 AV *av;
417 HV *hv;
418 dSP;
419 DEBUG(('P',4,"perl_on_session(%s)",sysflags));
420 pladd_int(sv,"start",rnode->starttime);
421 strtr(sysflags,'/',' ');
422 pladd_strz(sv,"flags",sysflags);
423 av=perl_get_av("addrs",TRUE);
424 av_clear(av);
425 for(fa=cfgal(CFG_ADDRESS);fa;fa=fa->next) {
426 p=ftnaddrtoa(&fa->addr);
427 sv=newSVpv(p,0);
428 SvREADONLY_on(sv);
429 av_push(av,sv);
430 }
431 av=perl_get_av("akas",TRUE);
432 av_clear(av);
433 for(fa=rnode->addrs;fa;fa=fa->next) {
434 p=ftnaddrtoa(&fa->addr);
435 sv=newSVpv(p,0);
436 SvREADONLY_on(sv);
437 av_push(av,sv);
438 }
439 hv=perl_get_hv("info",TRUE);
440 hv_clear(hv);
441 plhadd_str(hv,sv,"sysop",rnode->sysop);
442 plhadd_str(hv,sv,"mailer",rnode->mailer);
443 plhadd_str(hv,sv,"station",rnode->name);
444 plhadd_str(hv,sv,"place",rnode->place);
445 plhadd_str(hv,sv,"flags",rnode->flags);
446 plhadd_str(hv,sv,"wtime",rnode->wtime);
447 plhadd_str(hv,sv,"password",rnode->pwd);
448 plhadd_int(hv,sv,"time",rnode->time);
449 plhadd_int(hv,sv,"speed",rnode->speed);
450 plhadd_int(hv,sv,"connect",rnode->realspeed);
451 hv=perl_get_hv("flags",TRUE);
452 hv_clear(hv);
453 plhadd_int(hv,sv,"in",(rnode->options&O_INB)?1:0);
454 plhadd_int(hv,sv,"out",(rnode->options&O_INB)?0:1);
455 plhadd_int(hv,sv,"tcp",(rnode->options&O_TCP)?1:0);
456 plhadd_int(hv,sv,"secure",(rnode->options&O_PWD)?1:0);
457 plhadd_int(hv,sv,"listed",(rnode->options&O_LST)?1:0);
458 hv=perl_get_hv("queue",TRUE);
459 hv_clear(hv);
460 plhadd_int(hv,sv,"mail",totalm);
461 plhadd_int(hv,sv,"files",totalf);
462 plhadd_int(hv,sv,"num",totaln);
463 av=perl_get_av("queue",TRUE);
464 av_clear(av);
465 for(lst=fl;lst;lst=lst->next) {
466 sv=newSVpv(lst->tosend,0);
467 SvREADONLY_on(sv);
468 av_push(av,sv);
469 }
470 ENTER;
471 SAVETMPS;
472 PUSHMARK(SP);
473 PUTBACK;
474 perl_call_pv(perl_subnames[PERL_ON_SESSION],G_EVAL|G_SCALAR|G_NOARGS);
475 SPAGAIN;
476 svret=POPs;
477 if(SvOK(svret))rc=SvIV(svret);
478 PUTBACK;
479 FREETMPS;
480 LEAVE;
481 if(SvTRUE(ERRSV)) {
482 sub_err(PERL_ON_SESSION);
483 rc=S_OK;
484 }
485 DEBUG(('P',5,"perl_on_session() returns %d",rc));
486 return rc;
487 }
488 return S_OK;
489 }
490
perl_end_session(long sest,int result)491 void perl_end_session(long sest, int result)
492 {
493 if(PerlHave(PERL_END_SESSION)) {
494 SV *sv;
495 dSP;
496 DEBUG(('P',4,"perl_end_session(%ld, %d)",sest,result));
497 pladd_int(sv,"r_bytes",recvf.toff-recvf.soff);
498 pladd_int(sv,"r_files",recvf.nf);
499 pladd_int(sv,"s_bytes",sendf.toff-sendf.soff);
500 pladd_int(sv,"s_files",sendf.nf);
501 pladd_int(sv,"sesstime",sest);
502 pladd_int(sv,"result",result);
503 ENTER;
504 SAVETMPS;
505 PUSHMARK(SP);
506 PUTBACK;
507 perl_call_pv(perl_subnames[PERL_END_SESSION],G_EVAL|G_VOID|G_NOARGS);
508 SPAGAIN;
509 PUTBACK;
510 FREETMPS;
511 LEAVE;
512 if(SvTRUE(ERRSV))sub_err(PERL_END_SESSION);
513 }
514 }
515
perl_on_recv(void)516 int perl_on_recv(void)
517 {
518 if(PerlHave(PERL_ON_RECV)) {
519 SV *sv,*svret;
520 HV *hv;
521 int rc=FOP_OK;
522 dSP;
523 DEBUG(('P',4,"perl_on_recv()"));
524 hv=perl_get_hv("recv",TRUE);
525 hv_clear(hv);
526 plhadd_str(hv,sv,"name",recvf.fname);
527 plhadd_int(hv,sv,"size",recvf.ftot);
528 plhadd_int(hv,sv,"time",recvf.mtime);
529 ENTER;
530 SAVETMPS;
531 PUSHMARK(SP);
532 PUTBACK;
533 perl_call_pv(perl_subnames[PERL_ON_RECV],G_EVAL|G_SCALAR|G_NOARGS);
534 SPAGAIN;
535 svret=POPs;
536 if(SvOK(svret))rc=SvIV(svret);
537 PUTBACK;
538 FREETMPS;
539 LEAVE;
540 if(SvTRUE(ERRSV)) {
541 sub_err(PERL_ON_RECV);
542 rc=FOP_OK;
543 }
544 DEBUG(('P',5,"perl_on_recv() returns %d",rc));
545 return rc;
546 }
547 return FOP_OK;
548 }
549
perl_end_recv(int state)550 char *perl_end_recv(int state)
551 {
552 if(PerlHave(PERL_END_RECV)) {
553 SV *sv,*svret;
554 char *rc=NULL;
555 STRLEN len;
556 dSP;
557 DEBUG(('P',4,"perl_end_recv(%d)",state));
558 pladd_int(sv,"state",state);
559 ENTER;
560 SAVETMPS;
561 PUSHMARK(SP);
562 PUTBACK;
563 perl_call_pv(perl_subnames[PERL_END_RECV],G_EVAL|G_SCALAR|G_NOARGS);
564 SPAGAIN;
565 svret=POPs;
566 if(SvOK(svret)) {
567 rc=SvPV(svret,len);
568 if(!len)rc=NULL;
569 } else rc="";
570 PUTBACK;
571 FREETMPS;
572 LEAVE;
573 if(SvTRUE(ERRSV)) {
574 sub_err(PERL_END_RECV);
575 rc=NULL;
576 }
577 DEBUG(('P',5,"perl_end_recv() returns '%s'",rc));
578 return rc;
579 }
580 return NULL;
581 }
582
perl_on_send(const char * tosend)583 char *perl_on_send(const char *tosend)
584 {
585 if(PerlHave(PERL_ON_SEND)) {
586 SV *sv,*svret;
587 HV *hv;
588 char *rc=NULL;
589 STRLEN len;
590 dSP;
591 DEBUG(('P',4,"perl_on_send(%s)",tosend));
592 hv=perl_get_hv("send",TRUE);
593 hv_clear(hv);
594 plhadd_str(hv,sv,"file",(char *) tosend);
595 plhadd_str(hv,sv,"name",sendf.fname);
596 plhadd_int(hv,sv,"size",sendf.ftot);
597 plhadd_int(hv,sv,"time",sendf.mtime);
598 ENTER;
599 SAVETMPS;
600 PUSHMARK(SP);
601 PUTBACK;
602 perl_call_pv(perl_subnames[PERL_ON_SEND],G_EVAL|G_SCALAR|G_NOARGS);
603 SPAGAIN;
604 svret=POPs;
605 if(SvOK(svret)) {
606 rc=SvPV(svret,len);
607 if(!len)rc=NULL;
608 } else rc="";
609 PUTBACK;
610 FREETMPS;
611 LEAVE;
612 if(SvTRUE(ERRSV)) {
613 sub_err(PERL_ON_SEND);
614 rc=NULL;
615 }
616 DEBUG(('P',5,"perl_on_send() returns '%s'",rc));
617 return rc;
618 }
619 return NULL;
620 }
621
perl_end_send(int state)622 void perl_end_send(int state)
623 {
624 if(PerlHave(PERL_END_SEND)) {
625 SV *sv;
626 dSP;
627 DEBUG(('P',4,"perl_end_send(%d)",state));
628 pladd_int(sv,"state",state);
629 ENTER;
630 SAVETMPS;
631 PUSHMARK(SP);
632 PUTBACK;
633 perl_call_pv(perl_subnames[PERL_END_SEND],G_EVAL|G_VOID|G_NOARGS);
634 SPAGAIN;
635 PUTBACK;
636 FREETMPS;
637 LEAVE;
638 if(SvTRUE(ERRSV))sub_err(PERL_END_SEND);
639 }
640 }
641
642 #endif
643