/* * perlhooks.c -- perl-hooks interface * * perlhooks.c is a part of binkd project * * Copyright (C) 2003 val khokhlov, FIDONet 2:550/180 * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. See COPYING. */ #include #include #include #include #include #ifdef HAVE_FORK #include #endif #ifdef OS2 #ifdef PERLDL #define INCL_DOSMODULEMGR #endif #define INCL_DOSPROCESS #include #endif #ifdef _MSC_VER #undef __STDC__ #endif #include #include #if defined(__NT__) && !defined(WIN32) /* WIN32 needed for perl-core include files */ # define WIN32 #endif #ifdef WIN32 # define NO_XSLOCKS #endif #ifndef EXTERN_C # define EXTERN_C extern #endif /* ---------------- binkd stuff --------------- */ #include "sys.h" #include "readcfg.h" #include "tools.h" #include "ftnaddr.h" #include "ftnq.h" #include "ftnnode.h" #include "readflo.h" #include "iphdr.h" #include "protoco2.h" #include "sem.h" #include "protocol.h" #include "common.h" #include "perlhooks.h" #include "rfc2553.h" /* ---------------- perl stuff --------------- */ /* dynamic load */ #ifdef PERLDL # define Perl_sv_2pv (hl_Perl_sv_2pv) # define Perl_sv_2pv_flags (hl_Perl_sv_2pv_flags) # define Perl_sv_2uv (hl_Perl_sv_2uv) # define Perl_sv_2uv_flags (hl_Perl_sv_2uv_flags) # define Perl_sv_2iv (hl_Perl_sv_2iv) # define Perl_sv_2iv_flags (hl_Perl_sv_2iv_flags) # define Perl_sv_setsv (hl_Perl_sv_setsv) # define Perl_sv_setsv_flags (hl_Perl_sv_setsv_flags) # define Perl_sv_2mortal (*dl_Perl_sv_2mortal) # define Perl_newSViv (*dl_Perl_newSViv) # define Perl_av_store (*dl_Perl_av_store) # define Perl_av_fetch (*dl_Perl_av_fetch) # define Perl_av_len (*dl_Perl_av_len) # define Perl_newXS (*dl_Perl_newXS) # define Perl_sv_2bool (*dl_Perl_sv_2bool) # define perl_run (*dl_perl_run) # define Perl_sv_setiv (*dl_Perl_sv_setiv) # define perl_free (*dl_perl_free) # define perl_destruct (*dl_perl_destruct) # define perl_parse (*dl_perl_parse) # define perl_construct (*dl_perl_construct) # define perl_alloc (*dl_perl_alloc) # define Perl_newAV (*dl_Perl_newAV) # define Perl_av_push (*dl_Perl_av_push) # define Perl_av_clear (*dl_Perl_av_clear) # define Perl_newRV_noinc (*dl_Perl_newRV_noinc) # define Perl_newHV (*dl_Perl_newHV) # define Perl_hv_store (*dl_Perl_hv_store) # define Perl_newSVpv (*dl_Perl_newSVpv) # define Perl_hv_clear (*dl_Perl_hv_clear) # define Perl_push_scope (*dl_Perl_push_scope) # define Perl_pop_scope (*dl_Perl_pop_scope) # define Perl_free_tmps (*dl_Perl_free_tmps) # define Perl_markstack_grow (*dl_Perl_markstack_grow) # define Perl_save_int (*dl_Perl_save_int) # define Perl_sv_setpv (*dl_Perl_sv_setpv) # define Perl_sv_setpvn (*dl_Perl_sv_setpvn) # define Perl_av_undef (*dl_Perl_av_undef) # define Perl_hv_fetch (*dl_Perl_hv_fetch) # define Perl_eval_pv (*dl_Perl_eval_pv) # define Perl_newRV (*dl_Perl_newRV) # define Perl_sv_free (*dl_Perl_sv_free) # define Perl_sv_free2 (*dl_Perl_sv_free2) # define Perl_hv_common_key_len (*dl_Perl_hv_common_key_len) # define Perl_sys_init3 (*dl_Perl_sys_init3) #ifdef OS2 # define PL_errgv (*dl_PL_errgv) # define PL_stack_sp (*dl_PL_stack_sp) # define PL_markstack_ptr (*dl_PL_markstack_ptr) # define PL_sv_undef (*dl_PL_sv_undef) # define PL_stack_base (*dl_PL_stack_base) # define PL_markstack_max (*dl_PL_markstack_max) # define PL_tmps_ix (*dl_PL_tmps_ix) # define PL_tmps_floor (*dl_PL_tmps_floor) # define PL_diehook (*dl_PL_diehook) # define PL_warnhook (*dl_PL_warnhook) # define Perl_sv_setpvf (*dl_Perl_sv_setpvf) # define perl_get_sv (*dl_perl_get_sv) # define perl_get_av (*dl_perl_get_av) # define perl_get_hv (*dl_perl_get_hv) # define perl_get_cv (*dl_perl_get_cv) # define perl_call_pv (*dl_perl_call_pv) #else # define Perl_Ierrgv_ptr (*dl_Perl_Ierrgv_ptr) # define Perl_Isv_undef_ptr (*dl_Perl_Isv_undef_ptr) # define Perl_Tstack_sp_ptr (*dl_Perl_Tstack_sp_ptr) # define Perl_Tmarkstack_ptr_ptr (*dl_Perl_Tmarkstack_ptr_ptr) # define Perl_Tstack_base_ptr (*dl_Perl_Tstack_base_ptr) # define Perl_Tmarkstack_max_ptr (*dl_Perl_Tmarkstack_max_ptr) # define Perl_Ttmps_ix_ptr (*dl_Perl_Ttmps_ix_ptr) # define Perl_Ttmps_floor_ptr (*dl_Perl_Ttmps_floor_ptr) # define Perl_Tscopestack_ix_ptr (*dl_Perl_Tscopestack_ix_ptr) # define Perl_Tmarkstack_ptr (*dl_Perl_Tmarkstack_ptr) # define Perl_TXpv_ptr (*dl_Perl_TXpv_ptr) # define Perl_Istack_base_ptr (*dl_Perl_Istack_base_ptr) # define Perl_Istack_sp_ptr (*dl_Perl_Istack_sp_ptr) # define Perl_Imarkstack_max_ptr (*dl_Perl_Imarkstack_max_ptr) # define Perl_Imarkstack_ptr_ptr (*dl_Perl_Imarkstack_ptr_ptr) # define Perl_Itmps_floor_ptr (*dl_Perl_Itmps_floor_ptr) # define Perl_Itmps_ix_ptr (*dl_Perl_Itmps_ix_ptr) # define Perl_Iscopestack_ix_ptr (*dl_Perl_Iscopestack_ix_ptr) # define Perl_sv_setpvf_nocontext (*dl_Perl_sv_setpvf_nocontext) # define Perl_get_sv (*dl_Perl_get_sv) # define Perl_get_av (*dl_Perl_get_av) # define Perl_get_hv (*dl_Perl_get_hv) # define Perl_get_cv (*dl_Perl_get_cv) # define Perl_call_pv (*dl_Perl_call_pv) # define Perl_get_context (*dl_Perl_get_context) # define Perl_set_context (*dl_Perl_set_context) # define perl_clone (*dl_perl_clone) # define Perl_Iperl_destruct_level_ptr (*dl_Perl_Iperl_destruct_level_ptr) # define Perl_Idiehook_ptr (*dl_Perl_Idiehook_ptr) # define Perl_Iwarnhook_ptr (*dl_Perl_Iwarnhook_ptr) # define boot_DynaLoader (*dl_boot_DynaLoader) #endif #endif #ifdef DEBUG # undef DEBUG #endif #include #include #include /* perl prior to 5.6 support */ #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef eval_pv # define eval_pv perl_eval_pv #endif #ifndef newSVuv # define newSVuv newSViv #endif #ifndef sv_undef # define sv_undef PL_sv_undef #endif #ifndef aTHX_ # define aTHX_ #endif #ifdef q # undef q #endif #ifdef PERLDL #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<8) # define SV_GMAGIC 2 /* sv.h */ #endif #ifdef OS2 #define pTHX_ #define pTHX void #define pTHXo_ #define pTHXo void #define _Const #define OS2_Perl_data (*dl_OS2_Perl_data) typedef void (*XSUBADDR_t)(CV* cv _CPERLproto); typedef void(*XSINIT_t)(void); #else #define _Const const #endif /* below are the prototypes as they should appear: PERL_CALLCONV char* (*dl_Perl_sv_2pv)(pTHX_ SV* sv, STRLEN *lp); PERL_CALLCONV UV (*dl_Perl_sv_2uv)(pTHX_ SV* sv); PERL_CALLCONV void* (*dl_Perl_get_context)(void); PERL_CALLCONV void (*dl_Perl_set_context)(void *thx); PERL_CALLCONV SV* (*dl_Perl_sv_2mortal)(pTHX_ SV* sv); PERL_CALLCONV SV* (*dl_Perl_newSViv)(pTHX_ IV i); PERL_CALLCONV SV** (*dl_Perl_av_store)(pTHX_ AV* ar, I32 key, SV* val); PERL_CALLCONV SV** (*dl_Perl_av_fetch)(pTHX_ AV* ar, I32 key, I32 lval); PERL_CALLCONV void (*dl_Perl_av_push)(pTHX_ AV* ar, SV* val); PERL_CALLCONV void (*dl_Perl_av_clear)(pTHX_ AV* ar); #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<10) PERL_CALLCONV I32 (*dl_Perl_av_len)(pTHX_ AV* ar); PERL_CALLCONV CV* (*dl_Perl_newXS)(pTHX_ char* name, XSUBADDR_t f, char* filename); #else PERL_CALLCONV I32 (*dl_Perl_av_len)(pTHX_ const AV* ar); PERL_CALLCONV CV* (*dl_Perl_newXS)(pTHX_ const char* name, XSUBADDR_t f, const char* filename); #endif PERL_CALLCONV bool (*dl_Perl_sv_2bool)(pTHX_ SV* sv); PERL_CALLCONV CV* (*dl_Perl_get_cv)(pTHX_ const char* name, I32 create); PERL_CALLCONV SV* (*dl_Perl_get_sv)(pTHX_ const char* name, I32 create); PERL_CALLCONV AV* (*dl_Perl_get_av)(pTHX_ const char* name, I32 create); PERL_CALLCONV HV* (*dl_Perl_get_hv)(pTHX_ const char* name, I32 create); PERL_CALLCONV PerlInterpreter* (*dl_perl_alloc)(void); PERL_CALLCONV void (*dl_perl_construct)(PerlInterpreter* interp); PERL_CALLCONV void (*dl_perl_destruct)(PerlInterpreter* interp); PERL_CALLCONV void (*dl_perl_free)(PerlInterpreter* interp); PERL_CALLCONV int (*dl_perl_run)(PerlInterpreter* interp); PERL_CALLCONV int (*dl_perl_parse)(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env); PERL_CALLCONV PerlInterpreter* (*dl_perl_clone)(PerlInterpreter* interp, UV flags); PERL_CALLCONV void (*dl_Perl_sv_setiv)(pTHX_ SV* sv, IV num); PERL_CALLCONV void (*dl_Perl_sv_setsv)(pTHX_ SV* dsv, SV* ssv); PERL_CALLCONV void (*dl_Perl_sv_setpv)(pTHX_ SV* sv, const char* ptr); PERL_CALLCONV void (*dl_Perl_sv_setpvn)(pTHX_ SV* sv, const char* ptr, STRLEN len); PERL_CALLCONV AV* (*dl_Perl_newAV)(pTHX); PERL_CALLCONV SV* (*dl_Perl_newRV_noinc)(pTHX_ SV *sv); PERL_CALLCONV HV* (*dl_Perl_newHV)(pTHX); PERL_CALLCONV SV* (*dl_Perl_newSVpv)(pTHX_ const char* s, STRLEN len); PERL_CALLCONV SV** (*dl_Perl_hv_store)(pTHX_ HV* tb, _Const char* key, U32 klen, SV* val, U32 hash); PERL_CALLCONV void (*dl_Perl_hv_clear)(pTHX_ HV* tb); PERL_CALLCONV SV** (*dl_Perl_hv_fetch)(pTHX_ HV* tb, _Const char* key, U32 klen, I32 lval); PERL_CALLCONV void (*dl_Perl_push_scope)(pTHX); PERL_CALLCONV void (*dl_Perl_pop_scope)(pTHX); PERL_CALLCONV void (*dl_Perl_free_tmps)(pTHX); PERL_CALLCONV I32 (*dl_Perl_call_pv)(pTHX_ const char* sub_name, I32 flags); PERL_CALLCONV void (*dl_Perl_markstack_grow)(pTHX); PERL_CALLCONV void (*dl_Perl_save_int)(pTHX_ int* intp); PERL_CALLCONV IV (*dl_Perl_sv_2iv)(pTHX_ SV* sv); PERL_CALLCONV void (*dl_Perl_av_undef)(pTHX_ AV* ar); PERL_CALLCONV void (*dl_Perl_sv_setpvf_nocontext)(SV* sv, const char* pat, ...) PERL_CALLCONV SV* (*dl_Perl_eval_pv)(pTHX_ const char* p, I32 croak_on_error); PERL_CALLCONV SV* (*dl_Perl_newRV)(pTHX_ SV* pref); PERL_CALLCONV void (*dl_Perl_sv_free)(pTHX_ SV* sv); PERL_CALLCONV void (*dl_Perl_sv_free2)(pTHX_ SV* sv); PERL_CALLCONV void* (*dl_Perl_hv_common_key_len)(pTHX_ HV* hv, const char *key, I32 klen_i32, const int action, SV *val, const U32 hash); PERL_CALLCONV void (*dl_Perl_sys_init3)(int *argc, char ***argv, char ***env); #ifdef CHECK_FORMAT __attribute__((format(printf,2,3))) #endif ; PERL_CALLCONV int* (*dl_Perl_Iperl_destruct_level_ptr)(pTHXo); PERL_CALLCONV GV** (*dl_Perl_Ierrgv_ptr)(pTHXo); PERL_CALLCONV SV* (*dl_Perl_Isv_undef_ptr)(pTHXo); PERL_CALLCONV SV** (*dl_Perl_Idiehook_ptr)(pTHXo); PERL_CALLCONV SV** (*dl_Perl_Iwarnhook_ptr)(pTHXo); #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<10) PERL_CALLCONV I32* (*dl_Perl_Tscopestack_ix_ptr)(pTHXo); PERL_CALLCONV I32** (*dl_Perl_Tmarkstack_ptr)(pTHXo); PERL_CALLCONV I32** (*dl_Perl_Tmarkstack_max_ptr)(pTHXo); PERL_CALLCONV I32* (*dl_Perl_Ttmps_ix_ptr)(pTHXo); PERL_CALLCONV I32* (*dl_Perl_Ttmps_floor_ptr)(pTHXo); PERL_CALLCONV XPV** (*dl_Perl_TXpv_ptr)(pTHXo); PERL_CALLCONV SV*** (*dl_Perl_Tstack_base_ptr)(pTHXo); PERL_CALLCONV I32** (*dl_Perl_Tmarkstack_ptr_ptr)(pTHXo); PERL_CALLCONV SV*** (*dl_Perl_Tstack_sp_ptr)(pTHXo); #else PERL_CALLCONV SV** (*dl_Perl_Istack_base_ptr)(pTHXo); PERL_CALLCONV SV** (*dl_Perl_Istack_sp_ptr)(pTHXo); PERL_CALLCONV I32* (*dl_Perl_Imarkstack_max_ptr)(pTHXo); PERL_CALLCONV I32* (*dl_Perl_Imarkstack_ptr_ptr)(pTHXo); PERL_CALLCONV I32 (*dl_Perl_Itmps_floor_ptr)(pTHXo); PERL_CALLCONV I32 (*dl_Perl_Itmps_ix_ptr)(pTHXo); PERL_CALLCONV I32 (*dl_Perl_Iscopestack_ix_ptr)(pTHXo); #endif PERL_CALLCONV void (*dl_boot_DynaLoader)(pTHXo_ CV* cv); */ /* below is the prototype with typedef: typedef char* (PERL_CALLCONV *tf_Perl_sv_2pv)(pTHX_ SV* sv, STRLEN* lp); tf_Perl_sv_2pv dl_Perl_sv_2pv; */ /* the currently used way to define prototypes via macro */ #define VK_MAKE_DFL(t,n,a) t (PERL_CALLCONV *n) a VK_MAKE_DFL(char*, dl_Perl_sv_2pv_flags, (pTHX_ SV* sv, STRLEN* lp, I32 flags)); VK_MAKE_DFL(char*, dl_Perl_sv_2pv, (pTHX_ SV* sv, STRLEN* lp)); PERL_CALLCONV char* hl_Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp) { if (dl_Perl_sv_2pv) return dl_Perl_sv_2pv(aTHX_ sv, lp); else return dl_Perl_sv_2pv_flags(aTHX_ sv, lp, SV_GMAGIC); } PERL_CALLCONV char* hl_Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags) { if (dl_Perl_sv_2pv_flags) return dl_Perl_sv_2pv_flags(aTHX_ sv, lp, flags); else return dl_Perl_sv_2pv(aTHX_ sv, lp); } VK_MAKE_DFL(UV, dl_Perl_sv_2uv, (pTHX_ SV* sv)); VK_MAKE_DFL(UV, dl_Perl_sv_2uv_flags, (pTHX_ SV* sv, I32 flags)); PERL_CALLCONV UV hl_Perl_sv_2uv(pTHX_ SV* sv) { if (dl_Perl_sv_2uv) return dl_Perl_sv_2uv(aTHX_ sv); else return dl_Perl_sv_2uv_flags(aTHX_ sv, SV_GMAGIC); } PERL_CALLCONV UV hl_Perl_sv_2uv_flags(pTHX_ SV* sv, I32 flags) { if (dl_Perl_sv_2uv_flags) return dl_Perl_sv_2uv_flags(aTHX_ sv, flags); else return dl_Perl_sv_2uv(aTHX_ sv); } VK_MAKE_DFL(IV, dl_Perl_sv_2iv, (pTHX_ SV* sv)); VK_MAKE_DFL(IV, dl_Perl_sv_2iv_flags, (pTHX_ SV* sv, I32 flags)); PERL_CALLCONV IV hl_Perl_sv_2iv(pTHX_ SV* sv) { if (dl_Perl_sv_2iv) return dl_Perl_sv_2iv(aTHX_ sv); else return dl_Perl_sv_2iv_flags(aTHX_ sv, SV_GMAGIC); } PERL_CALLCONV IV hl_Perl_sv_2iv_flags(pTHX_ SV* sv, I32 flags) { if (dl_Perl_sv_2iv_flags) return dl_Perl_sv_2iv_flags(aTHX_ sv, flags); else return dl_Perl_sv_2iv(aTHX_ sv); } VK_MAKE_DFL(SV*, dl_Perl_sv_2mortal, (pTHX_ SV* sv)); VK_MAKE_DFL(SV*, dl_Perl_newSViv, (pTHX_ IV i)); VK_MAKE_DFL(SV**, dl_Perl_av_store, (pTHX_ AV* ar, I32 key, SV* val)); VK_MAKE_DFL(SV**, dl_Perl_av_fetch, (pTHX_ AV* ar, I32 key, I32 lval)); VK_MAKE_DFL(void, dl_Perl_av_push, (pTHX_ AV* ar, SV* val)); VK_MAKE_DFL(void, dl_Perl_av_clear, (pTHX_ AV* ar)); #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<10) VK_MAKE_DFL(CV*, dl_Perl_newXS, (pTHX_ char* name, XSUBADDR_t f, char* filename)); VK_MAKE_DFL(I32, dl_Perl_av_len, (pTHX_ AV* ar)); #else VK_MAKE_DFL(CV*, dl_Perl_newXS, (pTHX_ const char* name, XSUBADDR_t f, const char* filename)); VK_MAKE_DFL(I32, dl_Perl_av_len, (pTHX_ const AV* ar)); #endif VK_MAKE_DFL(bool, dl_Perl_sv_2bool, (pTHX_ SV* sv)); VK_MAKE_DFL(PerlInterpreter*, dl_perl_alloc, (void)); VK_MAKE_DFL(void, dl_perl_construct, (PerlInterpreter* interp)); #if PERL_REVISION>5 || (PERL_REVISION==5 && PERL_VERSION>=8) VK_MAKE_DFL(int, dl_perl_destruct, (PerlInterpreter* interp)); #else VK_MAKE_DFL(void, dl_perl_destruct, (PerlInterpreter* interp)); #endif VK_MAKE_DFL(void, dl_perl_free, (PerlInterpreter* interp)); VK_MAKE_DFL(int, dl_perl_run, (PerlInterpreter* interp)); VK_MAKE_DFL(int, dl_perl_parse, (PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env)); VK_MAKE_DFL(void, dl_Perl_sv_setiv, (pTHX_ SV* sv, IV num)); VK_MAKE_DFL(void, dl_Perl_sv_setsv_flags, (pTHX_ SV* dsv, SV* ssv, I32 flags)); VK_MAKE_DFL(void, dl_Perl_sv_setsv, (pTHX_ SV* dsv, SV* ssv)); void hl_Perl_sv_setsv(pTHX_ SV* sv, SV* ssv) { if (dl_Perl_sv_setsv) dl_Perl_sv_setsv(aTHX_ sv, ssv); else dl_Perl_sv_setsv_flags(aTHX_ sv, ssv, SV_GMAGIC); } void hl_Perl_sv_setsv_flags(pTHX_ SV* sv, SV* ssv, I32 flags) { if (dl_Perl_sv_setsv) dl_Perl_sv_setsv_flags(aTHX_ sv, ssv, flags); else dl_Perl_sv_setsv(aTHX_ sv, ssv); } VK_MAKE_DFL(void, dl_Perl_sv_setpv, (pTHX_ SV* sv, const char* ptr)); VK_MAKE_DFL(void, dl_Perl_sv_setpvn, (pTHX_ SV* sv, const char* ptr, STRLEN len)); VK_MAKE_DFL(AV*, dl_Perl_newAV, (pTHX)); VK_MAKE_DFL(SV*, dl_Perl_newRV_noinc, (pTHX_ SV *sv)); VK_MAKE_DFL(HV*, dl_Perl_newHV, (pTHX)); VK_MAKE_DFL(SV*, dl_Perl_newSVpv, (pTHX_ _Const char* s, STRLEN len)); VK_MAKE_DFL(void, dl_Perl_hv_clear, (pTHX_ HV* tb)); #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<8) VK_MAKE_DFL(SV**, dl_Perl_hv_store, (pTHX_ HV* tb, _Const char* key, U32 klen, SV* val, U32 hash)); VK_MAKE_DFL(SV**, dl_Perl_hv_fetch, (pTHX_ HV* tb, _Const char* key, U32 klen, I32 lval)); #else VK_MAKE_DFL(SV**, dl_Perl_hv_store, (pTHX_ HV* tb, _Const char* key, I32 klen, SV* val, U32 hash)); VK_MAKE_DFL(SV**, dl_Perl_hv_fetch, (pTHX_ HV* tb, _Const char* key, I32 klen, I32 lval)); #endif VK_MAKE_DFL(void, dl_Perl_push_scope, (pTHX)); VK_MAKE_DFL(void, dl_Perl_pop_scope, (pTHX)); VK_MAKE_DFL(void, dl_Perl_free_tmps, (pTHX)); VK_MAKE_DFL(void, dl_Perl_markstack_grow, (pTHX)); VK_MAKE_DFL(void, dl_Perl_save_int, (pTHX_ int* intp)); VK_MAKE_DFL(void, dl_Perl_av_undef, (pTHX_ AV* ar)); VK_MAKE_DFL(SV*, dl_Perl_eval_pv, (pTHX_ const char* p, I32 croak_on_error)); VK_MAKE_DFL(SV*, dl_Perl_newRV, (pTHX_ SV* pref)); VK_MAKE_DFL(void, dl_Perl_sv_free, (pTHX_ SV* sv)); VK_MAKE_DFL(void, dl_Perl_sv_free2, (pTHX_ SV* sv)); VK_MAKE_DFL(void*, dl_Perl_hv_common_key_len, (pTHX_ HV* hv, const char *key, I32 klen_i32, const int action, SV *val, const U32 hash)); VK_MAKE_DFL(void, dl_Perl_sys_init3, (int *argc, char ***argv, char ***env)); #ifdef OS2 VK_MAKE_DFL(void, dl_Perl_sv_setpvf, (SV* sv, const char* pat, ...)); VK_MAKE_DFL(CV*, dl_perl_get_cv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(SV*, dl_perl_get_sv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(AV*, dl_perl_get_av, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(HV*, dl_perl_get_hv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(I32, dl_perl_call_pv, (pTHX_ _Const char* sub_name, I32 flags)); GV* *dl_PL_errgv; SV** *dl_PL_stack_sp; I32* *dl_PL_markstack_ptr; SV *dl_PL_sv_undef; SV** *dl_PL_stack_base; I32* *dl_PL_markstack_max; I32 *dl_PL_tmps_ix; I32 *dl_PL_tmps_floor; SV* *dl_PL_diehook; SV* *dl_PL_warnhook; OS2_Perl_data_t *dl_OS2_Perl_data; #else VK_MAKE_DFL(CV*, dl_Perl_get_cv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(SV*, dl_Perl_get_sv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(AV*, dl_Perl_get_av, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(HV*, dl_Perl_get_hv, (pTHX_ _Const char* name, I32 create)); VK_MAKE_DFL(I32, dl_Perl_call_pv, (pTHX_ _Const char* sub_name, I32 flags)); VK_MAKE_DFL(GV**, dl_Perl_Ierrgv_ptr, (pTHXo)); VK_MAKE_DFL(SV*, dl_Perl_Isv_undef_ptr, (pTHXo)); VK_MAKE_DFL(SV**, dl_Perl_Idiehook_ptr, (pTHXo)); VK_MAKE_DFL(SV**, dl_Perl_Iwarnhook_ptr, (pTHXo)); #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<10) VK_MAKE_DFL(SV***, dl_Perl_Tstack_sp_ptr, (pTHXo)); VK_MAKE_DFL(I32**, dl_Perl_Tmarkstack_ptr_ptr, (pTHXo)); VK_MAKE_DFL(SV***, dl_Perl_Tstack_base_ptr, (pTHXo)); VK_MAKE_DFL(I32**, dl_Perl_Tmarkstack_max_ptr, (pTHXo)); VK_MAKE_DFL(I32*, dl_Perl_Ttmps_ix_ptr, (pTHXo)); VK_MAKE_DFL(I32*, dl_Perl_Ttmps_floor_ptr, (pTHXo)); VK_MAKE_DFL(I32**, dl_Perl_Tmarkstack_ptr, (pTHXo)); VK_MAKE_DFL(XPV**, dl_Perl_TXpv_ptr, (pTHXo)); VK_MAKE_DFL(int*, dl_Perl_Iperl_destruct_level_ptr, (pTHXo)); #else VK_MAKE_DFL(SV***, dl_Perl_Istack_base_ptr, (pTHXo)); VK_MAKE_DFL(SV***, dl_Perl_Istack_sp_ptr, (pTHXo)); VK_MAKE_DFL(I32**, dl_Perl_Imarkstack_max_ptr, (pTHXo)); VK_MAKE_DFL(I32**, dl_Perl_Imarkstack_ptr_ptr, (pTHXo)); VK_MAKE_DFL(I32*, dl_Perl_Itmps_floor_ptr, (pTHXo)); VK_MAKE_DFL(I32*, dl_Perl_Itmps_ix_ptr, (pTHXo)); VK_MAKE_DFL(I32*, dl_Perl_Iscopestack_ix_ptr, (pTHXo)); VK_MAKE_DFL(signed char*, dl_Perl_Iperl_destruct_level_ptr, (pTHXo)); #endif VK_MAKE_DFL(void, dl_boot_DynaLoader, (pTHXo_ CV* cv)); VK_MAKE_DFL(void*, dl_Perl_get_context, (void)); VK_MAKE_DFL(void, dl_Perl_set_context, (void *thx)); VK_MAKE_DFL(PerlInterpreter*, dl_perl_clone, (PerlInterpreter* interp, UV flags)); VK_MAKE_DFL(I32*, dl_Perl_Tscopestack_ix_ptr, (pTHXo)); #ifdef CHECK_FORMAT VK_MAKE_DFL(void, dl_Perl_sv_setpvf_nocontext, (SV* sv, const char* pat, ...) __attribute__((format(printf,2,3))) ); #else VK_MAKE_DFL(void, dl_Perl_sv_setpvf_nocontext, (SV* sv, const char* pat, ...)); #endif #endif /* the list of functions to import from DLL */ #define VK_MAKE_DLFUNC(n) { (void **)&dl_##n, #n } struct perl_dlfunc { void **f; char *name; } perl_dlfuncs[] = { /*#if PERL_REVISION>5 || (PERL_REVISION==5 && PERL_VERSION>=8) VK_MAKE_DLFUNC(Perl_sv_2pv_flags), #else VK_MAKE_DLFUNC(Perl_sv_2pv), #endif*/ VK_MAKE_DLFUNC(Perl_sv_2mortal), VK_MAKE_DLFUNC(Perl_newSViv), VK_MAKE_DLFUNC(Perl_av_store), VK_MAKE_DLFUNC(Perl_av_fetch), VK_MAKE_DLFUNC(Perl_av_len), VK_MAKE_DLFUNC(Perl_av_push), VK_MAKE_DLFUNC(Perl_av_clear), VK_MAKE_DLFUNC(Perl_newXS), VK_MAKE_DLFUNC(Perl_sv_2bool), VK_MAKE_DLFUNC(perl_alloc), VK_MAKE_DLFUNC(perl_construct), VK_MAKE_DLFUNC(perl_destruct), VK_MAKE_DLFUNC(perl_free), VK_MAKE_DLFUNC(perl_run), VK_MAKE_DLFUNC(perl_parse), VK_MAKE_DLFUNC(Perl_sv_setiv), /*#if PERL_REVISION>5 || (PERL_REVISION==5 && PERL_VERSION>=8) VK_MAKE_DLFUNC(Perl_sv_setsv_flags), #else VK_MAKE_DLFUNC(Perl_sv_setsv), #endif*/ VK_MAKE_DLFUNC(Perl_sv_setpv), VK_MAKE_DLFUNC(Perl_sv_setpvn), VK_MAKE_DLFUNC(Perl_newAV), VK_MAKE_DLFUNC(Perl_newRV_noinc), VK_MAKE_DLFUNC(Perl_newHV), VK_MAKE_DLFUNC(Perl_newSVpv), VK_MAKE_DLFUNC(Perl_hv_store), VK_MAKE_DLFUNC(Perl_hv_clear), VK_MAKE_DLFUNC(Perl_hv_fetch), VK_MAKE_DLFUNC(Perl_push_scope), VK_MAKE_DLFUNC(Perl_pop_scope), VK_MAKE_DLFUNC(Perl_free_tmps), VK_MAKE_DLFUNC(Perl_markstack_grow), VK_MAKE_DLFUNC(Perl_save_int), VK_MAKE_DLFUNC(Perl_av_undef), VK_MAKE_DLFUNC(Perl_eval_pv), VK_MAKE_DLFUNC(Perl_newRV), VK_MAKE_DLFUNC(Perl_sv_free), VK_MAKE_DLFUNC(Perl_sys_init3), #ifdef OS2 VK_MAKE_DLFUNC(perl_get_cv), VK_MAKE_DLFUNC(perl_get_sv), VK_MAKE_DLFUNC(perl_get_av), VK_MAKE_DLFUNC(perl_get_hv), VK_MAKE_DLFUNC(perl_call_pv), VK_MAKE_DLFUNC(PL_errgv), VK_MAKE_DLFUNC(PL_stack_sp), VK_MAKE_DLFUNC(PL_markstack_ptr), VK_MAKE_DLFUNC(PL_sv_undef), VK_MAKE_DLFUNC(PL_stack_base), VK_MAKE_DLFUNC(PL_markstack_max), VK_MAKE_DLFUNC(PL_tmps_ix), VK_MAKE_DLFUNC(PL_tmps_floor), VK_MAKE_DLFUNC(PL_diehook), VK_MAKE_DLFUNC(PL_warnhook), VK_MAKE_DLFUNC(OS2_Perl_data), VK_MAKE_DLFUNC(Perl_sv_setpvf), #else VK_MAKE_DLFUNC(Perl_hv_common_key_len), VK_MAKE_DLFUNC(Perl_get_cv), VK_MAKE_DLFUNC(Perl_get_sv), VK_MAKE_DLFUNC(Perl_get_av), VK_MAKE_DLFUNC(Perl_get_hv), VK_MAKE_DLFUNC(Perl_call_pv), VK_MAKE_DLFUNC(Perl_Ierrgv_ptr), #if PERL_REVISION<5 || (PERL_REVISION==5 && PERL_VERSION<10) VK_MAKE_DLFUNC(Perl_Tstack_sp_ptr), VK_MAKE_DLFUNC(Perl_Tmarkstack_ptr_ptr), VK_MAKE_DLFUNC(Perl_Tmarkstack_ptr), VK_MAKE_DLFUNC(Perl_Tstack_base_ptr), VK_MAKE_DLFUNC(Perl_Tmarkstack_max_ptr), VK_MAKE_DLFUNC(Perl_Ttmps_ix_ptr), VK_MAKE_DLFUNC(Perl_Ttmps_floor_ptr), VK_MAKE_DLFUNC(Perl_Tscopestack_ix_ptr), VK_MAKE_DLFUNC(Perl_TXpv_ptr), #else VK_MAKE_DLFUNC(Perl_Istack_base_ptr), VK_MAKE_DLFUNC(Perl_Istack_sp_ptr), VK_MAKE_DLFUNC(Perl_Imarkstack_max_ptr), VK_MAKE_DLFUNC(Perl_Imarkstack_ptr_ptr), VK_MAKE_DLFUNC(Perl_Itmps_floor_ptr), VK_MAKE_DLFUNC(Perl_Itmps_ix_ptr), VK_MAKE_DLFUNC(Perl_Iscopestack_ix_ptr), VK_MAKE_DLFUNC(Perl_sv_free2), #endif VK_MAKE_DLFUNC(Perl_Isv_undef_ptr), VK_MAKE_DLFUNC(Perl_sv_setpvf_nocontext), VK_MAKE_DLFUNC(Perl_get_context), VK_MAKE_DLFUNC(Perl_set_context), VK_MAKE_DLFUNC(perl_clone), VK_MAKE_DLFUNC(Perl_Iperl_destruct_level_ptr), VK_MAKE_DLFUNC(Perl_Idiehook_ptr), VK_MAKE_DLFUNC(Perl_Iwarnhook_ptr), VK_MAKE_DLFUNC(boot_DynaLoader), #endif { NULL, NULL } }; #endif /* PERLDL */ #if defined(HAVE_FORK) && !defined(HAVE_THREADS) && !defined(Perl_get_context) # define Perl_get_context() cfg->perl #endif #if !defined(PERL_SET_CONTEXT) # if defined(HAVE_THREADS) # error Your perl is not thread-safe! # endif # define PERL_SET_CONTEXT(p) #endif /* =========================== vars ================================== */ #define sv_config_format "__config_%u" /* SV that keeps pointer to config */ #define sv_state_format "__state_%u" /* SV that keeps pointer to state */ #define def_state() sprintf(sv_state, sv_state_format, (unsigned)PID()) #define def_config() sprintf(sv_config, sv_config_format, (unsigned)PID()) #if defined(HAVE_THREADS) && defined(PERL_MULTITHREAD) MUTEXSEM perlsem; #endif #define VK_FIND_CONFIG(cfg) \ { char sv_config[20]; \ SV *sv; \ STRLEN n_a; \ def_config(); \ sv = perl_get_sv(sv_config, FALSE); \ if (sv) { \ cfg = *((BINKD_CONFIG**)SvPV(sv, n_a)); \ if (!cfg || n_a == 0) cfg = current_config; \ } else \ cfg = current_config; \ } #define SET_CONFIG(cfg) \ { SV *svret; \ char sv_config[20]; \ def_config(); \ if ( ( svret = perl_get_sv(sv_config, TRUE)) != NULL ) { \ sv_setpvn(svret, (char *)&cfg, sizeof(&cfg)); \ SvREADONLY_on(svret); \ } \ } #define CLEAR_CONFIG \ { SV *svret; \ char sv_config[20]; \ def_config(); \ if ( ( svret = perl_get_sv(sv_config, FALSE)) != NULL ) { \ SvREFCNT_dec(svret); \ } \ } #define FIND_STATE(state) \ { SV *sv; \ char sv_state[20]; \ def_state(); \ sv = perl_get_sv(sv_state, FALSE); \ if (!sv) { \ Log(LL_ERR, "can't find $%s pointer", sv_state); \ state = NULL; \ } else { \ state = *((STATE**)SvPV(sv, n_a)); \ if (!(state) || !n_a) { \ Log(LL_ERR, "$%s pointer is NULL", sv_state); \ state = NULL; \ } \ } \ } #define SET_STATE(state) \ { SV *svret; \ char sv_state[20]; \ def_state(); \ if ( ( svret = perl_get_sv(sv_state, TRUE)) != NULL ) { \ sv_setpvn(svret, (char *)&state, sizeof(&state)); \ SvREADONLY_on(svret); \ } \ } #define CLEAR_STATE \ { SV *svret; \ char sv_state[20]; \ def_state(); \ if ( ( svret = perl_get_sv(sv_state, FALSE)) != NULL ) { \ SvREFCNT_dec(svret); \ } \ } /* bits for subroutines, must correspond to perl_subnames */ typedef enum { PERL_ON_START, PERL_ON_EXIT, PERL_ON_CALL, PERL_ON_ERROR, PERL_ON_HANDSHAKE, PERL_AFTER_HANDSHAKE, PERL_AFTER_SESSION, PERL_BEFORE_RECV, PERL_AFTER_RECV, PERL_BEFORE_SEND, PERL_AFTER_SENT, PERL_ON_LOG, PERL_ON_SEND, PERL_ON_RECV, PERL_SETUP_RLIMIT, PERL_NEED_RELOAD, PERL_CONFIG_LOADED } perl_subs; /* sub bit to corresponding name */ char *perl_subnames[] = { "on_start", "on_exit", "on_call", "on_error", "on_handshake", "after_handshake", "after_session", "before_recv", "after_recv", "before_send", "after_sent", "on_log", "on_send", "on_recv", "setup_rlimit", "need_reload", "config_loaded" }; /* constants */ struct perl_const { char *name; int value; } perl_consts[] = { { "SECURE", P_SECURE }, { "NONSECURE", P_NONSECURE }, { "WE_NONSECURE", P_WE_NONSECURE }, { "REMOTE_NONSECURE", P_REMOTE_NONSECURE }, { "OK", 1 }, { "FAILED", 0 }, { "BAD_CALL", BAD_CALL }, { "BAD_MERR", BAD_MERR }, { "BAD_MBSY", BAD_MBSY }, { "BAD_IO", BAD_IO }, { "BAD_TIMEOUT", BAD_TIMEOUT }, { "BAD_AKA", BAD_AKA }, { "BAD_AUTH", BAD_AUTH } }; /* log levels */ #define LL_ERR 1 #define LL_WARN 2 #define LL_INFO 3 #define LL_LOG 3 #define LL_DBG 7 #define LL_DBG2 9 /* ---------------------------- defines ------------------------------- */ #define VK_ADD_intz(_sv, _name, _v) \ if ( (_sv = perl_get_sv(_name, TRUE)) != NULL ) { \ SvREADONLY_off(_sv); \ sv_setiv(_sv, _v); \ SvREADONLY_on(_sv); \ } #define VK_ADD_strz(_sv, _name, _v) \ if ( (_sv = perl_get_sv(_name, TRUE)) != NULL ) { \ SvREADONLY_off(_sv); \ sv_setpv(_sv, _v ? _v : ""); \ SvREADONLY_on(_sv); \ } #define VK_ADD_str(_sv, _name, _v) \ if ( (_sv = perl_get_sv(_name, TRUE)) != NULL ) { \ SvREADONLY_off(_sv); \ if (_v) sv_setpv(_sv, _v); else sv_setsv(_sv, &sv_undef); \ SvREADONLY_on(_sv); \ } #define VK_ADD_strs(_sv, _name, _v) \ if ( (_sv = perl_get_sv(_name, TRUE)) != NULL ) { \ SvREADONLY_off(_sv); \ sv_setpv(_sv, (char *)_v); \ SvREADONLY_on(_sv); \ } #define VK_ADD_strn(_sv, _name, _v, len) \ if ( (_sv = perl_get_sv(_name, TRUE)) != NULL ) { \ SvREADONLY_off(_sv); \ sv_setpvn(_sv, (char *)_v, len); \ SvREADONLY_on(_sv); \ } #define VK_ADD_HASH_sv(_hv,_sv,_name) \ if (_sv != NULL) { \ SvREADONLY_on(_sv); \ (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \ } #define VK_ADD_HASH_str(_hv,_sv,_name,_value) \ if ( ((_value) != NULL) && (_sv = newSVpv(_value, 0)) != NULL ) { \ SvREADONLY_on(_sv); \ (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \ } \ else (void) hv_store(_hv, _name, strlen(_name), &sv_undef, 0); #define VK_ADD_HASH_intz(_hv,_sv,_name,_value) \ if ( (_sv = newSViv(_value)) != NULL ) { \ SvREADONLY_on(_sv); \ (void) hv_store(_hv, _name, strlen(_name), _sv, 0); \ } #define VK_ADD_HASH_int(_hv,_sv,_name,_value) \ if (_value) { VK_ADD_HASH_intz(_hv,_sv,_name,_value) } /* =========================== err handling ========================== */ static void perl_warn_str (char* str) { while (str && *str) { char* cp = strchr (str, '\n'); char c = 0; if (cp) { c = *cp; *cp = 0; } Log(LL_ERR, "Perl error: %s", str); if (cp) *cp = c; else break; str = cp + 1; } } static void perl_warn_sv (SV* sv) { STRLEN n_a; char * str = (char *) SvPV (sv, n_a); perl_warn_str (str); } #ifdef _MSC_VER EXTERN_C void perl_warn(pTHXo_ CV* cv) #else static XS(perl_warn) #endif { dXSARGS; if (items == 1) perl_warn_sv (ST(0)); XSRETURN_EMPTY; } /* handle multi-line perl eval error message */ static void sub_err(int sub) { STRLEN len; char *s, *p; p = SvPV(ERRSV, len); if (len) { s = xalloc(len+1); strnzcpy(s, p, len+1); } else s = xstrdup("(empty error message)"); if ( strchr(s, '\n') == NULL ) Log(LL_ERR, "Perl %s error: %s", perl_subnames[sub], s); else { p = s; Log(LL_ERR, "Perl %s error below:", perl_subnames[sub]); while ( *p && (*p != '\n' || *(p+1)) ) { char *r = strchr(p, '\n'); if (r) { *r = 0; Log(LL_ERR, " %s", p); p = r+1; } else { Log(LL_ERR, " %s", p); break; } } } xfree(s); } /* =========================== xs ========================== */ #ifdef _MSC_VER EXTERN_C void xs_init (pTHXo); # ifndef PERLDL EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv); # endif EXTERN_C void perl_Log(pTHXo_ CV* cv); EXTERN_C void perl_aeq(pTHXo_ CV* cv); EXTERN_C void perl_arm(pTHXo_ CV* cv); #else # ifndef PERLDL XS(boot_DynaLoader); # else /* I don't know how to use DynaLoader with PERLDL under OS/2 :-( */ # endif #endif /* interface to Log() */ #ifdef _MSC_VER EXTERN_C void perl_Log(pTHXo_ CV* cv) #else static XS(perl_Log) #endif { dXSARGS; char *str; int lvl; STRLEN n_a; if (items != 1 && items != 2) { Log(LL_ERR, "wrong params number to Log (need 1 or 2, exist %d)", items); XSRETURN_EMPTY; } if (items == 2) { lvl = SvUV(ST(0)); str = (char *)SvPV(ST(1), n_a); if (n_a == 0) str = ""; } else { lvl = LL_LOG; str = (char *)SvPV(ST(0), n_a); if (n_a == 0) str = ""; } Log(lvl, "%s", str); XSRETURN_EMPTY; } /* returns 1 if the first addr matches to any of the rest */ #ifdef _MSC_VER EXTERN_C void perl_aeq(pTHXo_ CV* cv) #else static XS(perl_aeq) #endif { dXSARGS; BINKD_CONFIG *cfg; STRLEN len; int i; char *a, *b; FTN_ADDR A, B; int mask_mode = 0; if (items == 1) { Log(LL_ERR, "aeq() requires 2 or more parameters, %d exist", items); XSRETURN_UNDEF; } VK_FIND_CONFIG(cfg); a = (char *)SvPV(ST(0), len); if (len == 0) XSRETURN_UNDEF; else if (strchr(a, '*')) mask_mode = 1; else if (!parse_ftnaddress(a, &A, cfg->pDomains.first)) XSRETURN_UNDEF; else exp_ftnaddress(&A, cfg->pAddr, cfg->nAddr, cfg->pDomains.first); for (i = 1; i < items; i++) { b = (char *)SvPV(ST(i), len); if (len == 0 || !parse_ftnaddress(b, &B, cfg->pDomains.first)) continue; exp_ftnaddress(&B, cfg->pAddr, cfg->nAddr, cfg->pDomains.first); if (mask_mode) { char bb[FTN_ADDR_SZ]; xftnaddress_to_str(bb, &B, 1); if (ftnamask_cmps(a, bb) == 0) XSRETURN_IV(1); } else { if (ftnaddress_cmp(&A, &B) == 0) XSRETURN_IV(1); } } XSRETURN_IV(0); } /* deletes all the addresses from the array (the first arg) */ #ifdef _MSC_VER EXTERN_C void perl_arm(pTHXo_ CV* cv) #else static XS(perl_arm) #endif { dXSARGS; BINKD_CONFIG *cfg; STRLEN len; int i, j, k, K, N, m; char *a, *b, **C; FTN_ADDR A, *B; AV *arr; SV **svp; if (items == 1) { Log(LL_ERR, "arm() requires 2 or more parameters, %d exist", items); XSRETURN_UNDEF; } if (!SvROK(ST(0)) || SvTYPE(SvRV(ST(0))) != SVt_PVAV) { Log(LL_ERR, "first parameter to arm() should be array reference"); XSRETURN_UNDEF; } VK_FIND_CONFIG(cfg); arr = (AV*)SvRV(ST(0)); B = xalloc( (items-1)*sizeof(FTN_ADDR) ); C = xalloc( (items-1)*sizeof(char*) ); memset(C, 0, (items-1)*sizeof(char*)); /* i - args, k - valid addresses */ for (i = 1, k = K = 0; i < items; i++) { b = (char *)SvPV(ST(i), len); if (len == 0) continue; if (strchr(b, '*')) { C[K++] = b; continue; } if (!parse_ftnaddress(b, B+k, cfg->pDomains.first)) continue; exp_ftnaddress(B+k, cfg->pAddr, cfg->nAddr, cfg->pDomains.first); k++; } /* j - array elements, i - valid addresses */ N = av_len(arr) + 1; for (j = m = 0; j < N; j++) { int found = 0; svp = av_fetch(arr, j, FALSE); if (j != m) av_store(arr, m, (*svp)); if (!svp) { m++; continue; } a = (char *)SvPV((*svp), len); if (len == 0 || !parse_ftnaddress(a, &A, cfg->pDomains.first)) { m++; continue; } exp_ftnaddress(&A, cfg->pAddr, cfg->nAddr, cfg->pDomains.first); /* compare */ for (i = 0; i < k; i++) { if (ftnaddress_cmp(&A, B+i) == 0) { found = 1; break; } } for (i = 0; i < K; i++) { char aa[FTN_ADDR_SZ]; xftnaddress_to_str(aa, &A, 1); if (ftnamask_cmps(C[i], aa) == 0) { found = 1; break; } } if (!found) m++; } /* reduce array size */ if (m != N) AvFILLp(arr) = m-1; free(B); free(C); XSRETURN_IV(N - m); } /* puts a message to msg-queue */ extern void msg_send2 (STATE *state, t_msg m, char *s1, char *s2); #ifdef _MSC_VER EXTERN_C void perl_msg_send(pTHXo_ CV* cv) #else static XS(perl_msg_send) #endif { dXSARGS; STATE *state; t_msg m; char *str; STRLEN n_a; if (items != 2) { Log(LL_ERR, "wrong params number to msg_send (needs 2, exist %d)", items); XSRETURN_EMPTY; } FIND_STATE(state); if (!state) { XSRETURN_EMPTY; } m = (t_msg)SvIV(ST(0)); str = (char *)SvPV(ST(1), n_a); if (n_a == 0) str = ""; msg_send2(state, m, str, NULL); XSRETURN_EMPTY; } #if defined(OS2) && !defined(PERLDL) XS(boot_DB_File); XS(boot_Fcntl); XS(boot_POSIX); XS(boot_SDBM_File); XS(boot_IO); XS(boot_OS2__Process); XS(boot_OS2__ExtAttr); XS(boot_OS2__REXX); #endif /* xs_init */ #ifdef WIN32 EXTERN_C void xs_init (pTHXo) #else #ifdef pTHX static void xs_init(pTHX) #else static void xs_init(void) #endif #endif { static char *file = __FILE__; #if defined(OS2) #ifndef PERLDL newXS("DB_File::bootstrap", boot_DB_File, file); newXS("Fcntl::bootstrap", boot_Fcntl, file); newXS("POSIX::bootstrap", boot_POSIX, file); newXS("SDBM_File::bootstrap", boot_SDBM_File, file); newXS("IO::bootstrap", boot_IO, file); newXS("OS2::Process::bootstrap", boot_OS2__Process, file); newXS("OS2::ExtAttr::bootstrap", boot_OS2__ExtAttr, file); newXS("OS2::REXX::bootstrap", boot_OS2__REXX, file); #endif #else dXSUB_SYS; #endif #if !defined(OS2) || !defined(PERLDL) newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); #endif newXS("Log", perl_Log, file); newXS("aeq", perl_aeq, file); newXS("arm", perl_arm, file); newXS("msg_send", perl_msg_send, file); newXS("binkd_warn", perl_warn, file); } /* =========================== sys ========================== */ static int add_node_to_hv(FTN_NODE *node, void *hv) { HV *hv2; SV *sv; char buf[FTN_ADDR_SZ]; hv2 = newHV(); VK_ADD_HASH_str(hv2, sv, "hosts", node->hosts); VK_ADD_HASH_str(hv2, sv, "pwd", node->pwd); VK_ADD_HASH_str(hv2, sv, "pkt_pwd", node->pkt_pwd); VK_ADD_HASH_str(hv2, sv, "out_pwd", node->out_pwd); VK_ADD_HASH_str(hv2, sv, "ibox", node->ibox); VK_ADD_HASH_str(hv2, sv, "obox", node->obox); buf[0] = node->obox_flvr; buf[1] = 0; VK_ADD_HASH_str(hv2, sv, "obox_flvr", buf); VK_ADD_HASH_int(hv2, sv, "NR", node->NR_flag); VK_ADD_HASH_int(hv2, sv, "ND", node->ND_flag); VK_ADD_HASH_int(hv2, sv, "MD", node->MD_flag); VK_ADD_HASH_int(hv2, sv, "HC", node->HC_flag); VK_ADD_HASH_int(hv2, sv, "IP", node->restrictIP); VK_ADD_HASH_int(hv2, sv, "NP", node->NP_flag); sv = newRV_noinc( (SV*)hv2 ); ftnaddress_to_str(buf, &(node->fa)); VK_ADD_HASH_sv((HV *)hv, sv, buf); return 0; } /* set config vars to root perl */ static void perl_setup(BINKD_CONFIG *cfg, PerlInterpreter *perl) { SV *sv; HV *hv, *hv2; AV *av; char buf[FTN_ADDR_SZ]; int i; if (!perl) return; Log(LL_DBG, "perl_setup(): perl context %p", perl); hv = perl_get_hv("config", TRUE); hv_clear(hv); VK_ADD_HASH_str(hv, sv, "log", cfg->logpath); VK_ADD_HASH_intz(hv, sv, "loglevel", cfg->loglevel); VK_ADD_HASH_intz(hv, sv, "conlog", cfg->conlog); VK_ADD_HASH_intz(hv, sv, "tzoff", cfg->tzoff); VK_ADD_HASH_str(hv, sv, "sysname", cfg->sysname); VK_ADD_HASH_str(hv, sv, "sysop", cfg->sysop); VK_ADD_HASH_str(hv, sv, "location", cfg->location); VK_ADD_HASH_str(hv, sv, "nodeinfo", cfg->nodeinfo); VK_ADD_HASH_str(hv, sv, "bindaddr", cfg->bindaddr); VK_ADD_HASH_str(hv, sv, "iport", cfg->iport); VK_ADD_HASH_str(hv, sv, "oport", cfg->oport); VK_ADD_HASH_intz(hv, sv, "maxservers", cfg->max_servers); VK_ADD_HASH_intz(hv, sv, "maxclients", cfg->max_clients); VK_ADD_HASH_intz(hv, sv, "oblksize", cfg->oblksize); VK_ADD_HASH_str(hv, sv, "inbound", cfg->inbound); VK_ADD_HASH_str(hv, sv, "inbound_nonsecure", cfg->inbound_nonsecure); VK_ADD_HASH_intz(hv, sv, "inboundcase", cfg->inboundcase); VK_ADD_HASH_str(hv, sv, "temp_inbound", cfg->temp_inbound); VK_ADD_HASH_intz(hv, sv, "minfree", cfg->minfree); VK_ADD_HASH_intz(hv, sv, "minfree_nonsecure", cfg->minfree_nonsecure); VK_ADD_HASH_intz(hv, sv, "hold", cfg->hold); VK_ADD_HASH_intz(hv, sv, "hold_skipped", cfg->hold_skipped); VK_ADD_HASH_intz(hv, sv, "backresolv", cfg->backresolv); VK_ADD_HASH_intz(hv, sv, "send_if_pwd", cfg->send_if_pwd); VK_ADD_HASH_str(hv, sv, "filebox", cfg->tfilebox); VK_ADD_HASH_str(hv, sv, "brakebox", cfg->bfilebox); VK_ADD_HASH_str(hv, sv, "root_domain", cfg->root_domain); VK_ADD_HASH_int(hv, sv, "check_pkthdr", cfg->pkthdr_type); VK_ADD_HASH_str(hv, sv, "pkthdr_badext", cfg->pkthdr_bad); #if defined(WITH_ZLIB) || defined(WITH_BZLIB2) VK_ADD_HASH_intz(hv, sv, "zminsize", cfg->zminsize); #endif /* perl_vars */ { struct perl_var *cur = cfg->perl_vars.first; while (cur) { VK_ADD_HASH_str(hv, sv, cur->name, cur->val); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): %%config done"); /* domain */ hv = perl_get_hv("domain", TRUE); hv_clear(hv); { FTN_DOMAIN *cur = cfg->pDomains.first; while (cur) { hv2 = newHV(); if (!cur->alias4) { VK_ADD_HASH_str(hv2, sv, "path", cur->path); VK_ADD_HASH_str(hv2, sv, "dir", cur->dir); VK_ADD_HASH_int(hv2, sv, "defzone", cur->z[0]); if (cur->idomain) { VK_ADD_HASH_str(hv2, sv, "root_domain", cur->idomain); } } else { VK_ADD_HASH_str(hv2, sv, "path", cur->alias4->path); VK_ADD_HASH_str(hv2, sv, "dir", cur->alias4->dir); VK_ADD_HASH_int(hv2, sv, "defzone", cur->alias4->z[0]); if (cur->idomain) { VK_ADD_HASH_str(hv2, sv, "root_domain", cur->idomain); } } sv = newRV_noinc( (SV*)hv2 ); VK_ADD_HASH_sv(hv, sv, cur->name); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): %%domain done"); /* address -> me */ av = perl_get_av("addr", TRUE); av_clear(av); for (i = 0; i < cfg->nAddr; i++) { ftnaddress_to_str(buf, &(cfg->pAddr[i])); sv = newSVpv(buf, 0); SvREADONLY_on(sv); av_push(av, sv); } Log(LL_DBG2, "perl_setup(): @addr done"); /* listen */ av = perl_get_av("listen", TRUE); av_clear(av); { struct listenchain *cur = cfg->listen.first; while (cur) { hv2 = newHV(); VK_ADD_HASH_str(hv2, sv, "port", cur->port); VK_ADD_HASH_str(hv2, sv, "addr", cur->addr[0] ? cur->addr : "*"); sv = newRV_noinc((SV*)hv2); SvREADONLY_on(sv); av_push(av, sv); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): @listen done"); /* ftrans */ av = perl_get_av("ftrans", TRUE); av_clear(av); { RF_RULE *cur = cfg->rf_rules.first; while (cur) { hv2 = newHV(); VK_ADD_HASH_str(hv2, sv, "from", cur->from); VK_ADD_HASH_str(hv2, sv, "to", cur->to); sv = newRV_noinc( (SV*)hv2 ); av_push(av, sv); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): @ftrans done"); /* overwrite */ av = perl_get_av("overwrite", TRUE); av_clear(av); { struct maskchain *cur = cfg->overwrite.first; while (cur) { sv = newSVpv(cur->mask, 0); SvREADONLY_on(sv); av_push(av, sv); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): @overwrite done"); /* skip */ av = perl_get_av("skip", TRUE); av_clear(av); { struct skipchain *cur = cfg->skipmask.first; while (cur) { hv2 = newHV(); VK_ADD_HASH_str(hv2, sv, "mask", cur->mask); VK_ADD_HASH_intz(hv2, sv, "type", cur->atype); VK_ADD_HASH_intz(hv2, sv, "size", cur->size); VK_ADD_HASH_intz(hv2, sv, "destr", cur->destr); sv = newRV_noinc( (SV*)hv2 ); av_push(av, sv); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): @skip done"); /* share */ hv = perl_get_hv("share", TRUE); hv_clear(hv); { SHARED_CHAIN *cur = cfg->shares.first; FTN_ADDR_CHAIN *fa; while (cur) { av = newAV(); fa = cur->sfa.first; while (fa) { ftnaddress_to_str(buf, &(fa->fa)); sv = newSVpv(buf, 0); SvREADONLY_on(sv); av_push(av, sv); fa = fa->next; } ftnaddress_to_str(buf, &(cur->sha)); sv = newRV_noinc( (SV*)av ); VK_ADD_HASH_sv(hv, sv, buf); cur = cur->next; } } Log(LL_DBG2, "perl_setup(): %%share done"); /* node */ hv = perl_get_hv("node", TRUE); hv_clear(hv); foreach_node(add_node_to_hv, hv, cfg); Log(LL_DBG2, "perl_setup(): %%node done"); } /* init root perl, parse hooks file, return success */ int perl_init(char *perlfile, BINKD_CONFIG *cfg, int first_call) { int rc, i; SV *sv; char *cmd; char *perlargs[] = {"", NULL, NULL, NULL}; char **perlargv = (char **)perlargs; char **perlenv = saved_envp; PerlInterpreter *perl; Log(LL_DBG, "perl_init(): %s", perlfile); /* try to find out the actual path to perl script and set dir to -I */ i = 1; perlargs[i++] = "-e"; perlargs[i++] = "0"; /* check perm */ if (access(perlfile, R_OK)) { Log(LL_ERR, "Cannot open %s: %s", perlfile, strerror(errno)); return 0; } #ifdef PERLDL /* load DLL */ if (!cfg->perl_dll[0]) { Log(LL_ERR, "You should define `perl-dll' in config to use Perl hooks"); return 0; } else if (*(perl_dlfuncs->f) == NULL) { /* not already loaded */ struct perl_dlfunc *dlfunc; #ifdef OS2 char buf[256]; HMODULE hl; if (DosLoadModule(buf, sizeof(buf), cfg->perl_dll, &hl)) #else /* MSC */ HINSTANCE hl = LoadLibrary(cfg->perl_dll); if (!hl) #endif { Log(LL_ERR, "perl_init(): can't load library %s", cfg->perl_dll); return 0; } Log(LL_DBG2, "perl_init(): load library: %p", hl); for (dlfunc = perl_dlfuncs; dlfunc->name; dlfunc++) { #ifdef OS2 if (!DosQueryProcAddr(hl, 0, dlfunc->name, (PFN*)dlfunc->f)) #else if ((*(dlfunc->f) = GetProcAddress(hl, dlfunc->name))) #endif Log(LL_DBG2, "perl_init(): load method %s: %p", dlfunc->name, *(dlfunc->f)); else { Log(LL_ERR, "perl_init(): can't load method %s", dlfunc->name); return 0; } } #ifdef OS2 { if (!DosQueryProcAddr(hl, 0, "Perl_sv_2pv", (PFN*)dl_Perl_sv_2pv) && !DosQueryProcAddr(hl, 0, "Perl_sv_2pv_flags", (PFN*)dl_Perl_sv_2pv_flags)) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2pv or Perl_sv_2pv_flags"); return 0; } if (!DosQueryProcAddr(hl, 0, "Perl_sv_2uv", (PFN*)dl_Perl_sv_2uv) && !DosQueryProcAddr(hl, 0, "Perl_sv_2uv_flags", (PFN*)dl_Perl_sv_2uv_flags)) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2uv or Perl_sv_2uv_flags"); return 0; } if (!DosQueryProcAddr(hl, 0, "Perl_sv_2iv", (PFN*)dl_Perl_sv_2iv) && !DosQueryProcAddr(hl, 0, "Perl_sv_2iv_flags", (PFN*)dl_Perl_sv_2iv_flags)) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2iv or Perl_sv_2iv_flags"); return 0; } if (!DosQueryProcAddr(hl, 0, "Perl_sv_setsv", (PFN*)dl_Perl_sv_setsv) && !DosQueryProcAddr(hl, 0, "Perl_sv_setsv_flags", (PFN*)dl_Perl_sv_setsv_flags)) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_setsv or Perl_sv_setsv_flags"); return 0; } } #else { *(void**)&dl_Perl_sv_2pv = GetProcAddress(hl, "Perl_sv_2pv"); *(void**)&dl_Perl_sv_2pv_flags = GetProcAddress(hl, "Perl_sv_2pv_flags"); if (!dl_Perl_sv_2pv && !dl_Perl_sv_2pv_flags) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2pv or Perl_sv_2pv_flags"); return 0; } *(void**)&dl_Perl_sv_2uv = GetProcAddress(hl, "Perl_sv_2uv"); *(void**)&dl_Perl_sv_2uv_flags = GetProcAddress(hl, "Perl_sv_2uv_flags"); if (!dl_Perl_sv_2uv && !dl_Perl_sv_2uv_flags) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2uv or Perl_sv_2uv_flags"); return 0; } *(void**)&dl_Perl_sv_2iv = GetProcAddress(hl, "Perl_sv_2iv"); *(void**)&dl_Perl_sv_2iv_flags = GetProcAddress(hl, "Perl_sv_2iv_flags"); if (!dl_Perl_sv_2iv && !dl_Perl_sv_2iv_flags) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_2iv or Perl_sv_2iv_flags"); return 0; } *(void**)&dl_Perl_sv_setsv = GetProcAddress(hl, "Perl_sv_setsv"); *(void**)&dl_Perl_sv_setsv_flags = GetProcAddress(hl, "Perl_sv_setsv_flags"); if (!dl_Perl_sv_setsv && !dl_Perl_sv_setsv_flags) { Log(LL_ERR, "perl_init(): can't load method Perl_sv_setv or Perl_sv_setsv_flags"); } } #endif } #endif /* PERLDL */ /* init perl */ #ifdef PERL_SYS_INIT3 if (first_call) PERL_SYS_INIT3(&i, &perlargv, &perlenv); #endif perl = perl_alloc(); PERL_SET_CONTEXT(perl); PL_perl_destruct_level = 1; perl_construct(perl); rc = perl_parse(perl, xs_init, i, perlargv, (char **)NULL); Log(LL_DBG, "perl_init(): parse rc=%d", rc); /* can't parse */ if (rc) { perl_destruct(perl); perl_free(perl); Log(LL_ERR, "Can't parse %s, perl filtering disabled", perlfile); return 0; } /* setup consts */ for (i = 0; i < sizeof(perl_consts)/sizeof(perl_consts[0]); i++) { VK_ADD_intz(sv, perl_consts[i].name, perl_consts[i].value); } /* setup vars */ perl_setup(cfg, perl); /* Set warn and die hooks */ if (PL_warnhook) SvREFCNT_dec (PL_warnhook); if (PL_diehook ) SvREFCNT_dec (PL_diehook ); PL_warnhook = newRV_inc ((SV*) perl_get_cv ("binkd_warn", TRUE)); PL_diehook = newRV_inc ((SV*) perl_get_cv ("binkd_warn", TRUE)); /* run main program body */ Log(LL_DBG, "perl_init(): running body"); cmd = xstrdup ("do '"); xstrcat (&cmd, perlfile); xstrcat (&cmd, "'; $@ ? $@ : '';"); sv = perl_eval_pv (cmd, TRUE); if (!SvPOK(sv)) { Log(LL_ERR, "Syntax error in internal perl expression: %s", cmd); rc = 1; } else if (SvTRUE (sv)) { perl_warn_sv (sv); rc = 1; } xfree(cmd); if (rc) { perl_destruct(perl); perl_free(perl); return 0; } /* scan for present hooks */ for (i = 0; i < sizeof(perl_subnames)/sizeof(perl_subnames[0]); i++) { if (perl_get_cv(perl_subnames[i], FALSE)) cfg->perl_ok |= (1 << i); } #if defined(HAVE_THREADS) && defined(PERL_MULTITHREAD) InitSem (&perlsem); #endif cfg->perl = perl; Log(LL_DBG, "perl_init(): end"); return 1; } /* exit, just before destruction */ static void perl_on_exit(BINKD_CONFIG *cfg) { if (cfg->perl_ok & (1 << PERL_ON_EXIT)) { Log(LL_DBG, "perl_on_exit(), perl"); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_EXIT], G_EVAL|G_VOID); SPAGAIN; PUTBACK; FREETMPS; LEAVE; } if (SvTRUE(ERRSV)) sub_err(PERL_ON_EXIT); Log(LL_DBG, "perl_on_exit() end"); } } /* deallocate root perl, call on_exit() if master==1 */ void perl_done(BINKD_CONFIG *cfg, int master) { Log(LL_DBG, "perl_done(): perl=%p", cfg->perl); if (cfg->perl) { PERL_SET_CONTEXT((PerlInterpreter *)cfg->perl); /* run on_exit() */ if (master) perl_on_exit(cfg); /* de-allocate */ Log(LL_DBG, "perl_done(): destructing perl %p", cfg->perl); #ifndef _MSC_VER PL_perl_destruct_level = 1; perl_destruct((PerlInterpreter *)cfg->perl); perl_free((PerlInterpreter *)cfg->perl); #endif cfg->perl = NULL; Log(LL_DBG, "perl_done(): end"); } if (current_config && current_config->perl) PERL_SET_CONTEXT((PerlInterpreter *)current_config->perl); } #ifdef HAVE_THREADS /* clone root perl */ void *perl_init_clone(BINKD_CONFIG *cfg) { #ifndef PERL_MULTITHREAD UV cflags = 0; #endif PerlInterpreter *p; if (cfg->perl) { Log(LL_DBG2, "perl_init_clone(), parent perl=%p, context=%p", cfg->perl, Perl_get_context()); PERL_SET_CONTEXT((PerlInterpreter *)cfg->perl); #ifndef PERL_MULTITHREAD #if defined(WIN32) && defined(CLONEf_CLONE_HOST) cflags |= CLONEf_CLONE_HOST | CLONEf_KEEP_PTR_TABLE; #endif p = perl_clone((PerlInterpreter *)cfg->perl, cflags); if (p) { PERL_SET_CONTEXT(p); /* perl<5.6.1 hack, see http://svn.apache.org/viewvc/perl/modperl/trunk/src/modules/perl/modperl_interp.c?r1=67986&r2=67992 */ if (PL_scopestack_ix == 0) { ENTER; } perl_setup(cfg, p); } #else p = (PerlInterpreter *)cfg->perl; #endif /* this pointer is used later */ if (p) { SET_CONFIG(cfg); } } else p = NULL; Log(LL_DBG, "perl_init_clone(): new clone %p", p); return p; } /* destruct a clone */ void perl_done_clone(void *p) { Log(LL_DBG, "perl_done_clone(): destructing clone %p", p); if (p == NULL) return; CLEAR_CONFIG; PL_perl_destruct_level = 2; PERL_SET_CONTEXT((PerlInterpreter *)p); /* as in mod_perl */ #ifndef PERL_MULTITHREAD perl_destruct((PerlInterpreter *)p); /* #ifndef WIN32 - mod_perl has it unless CLONEf_CLONE_HOST */ #if !defined(WIN32) || defined(CLONEf_CLONE_HOST) perl_free((PerlInterpreter *)p); #endif #endif } #endif /* set array of fido addresses */ static void setup_addrs(char *name, int n, FTN_ADDR *p) { char buf[FTN_ADDR_SZ]; AV *av; int i; av = perl_get_av(name, TRUE); SvREADONLY_off( (SV*)av ); av_clear(av); for (i = 0; i < n; i++) { ftnaddress_to_str(buf, p+i); av_push(av, newSVpv(buf, 0)); } SvREADONLY_on( (SV*)av ); } /* set session vars */ static void setup_session(STATE *state, int lvl) { SV *sv; HV *hv; BINKD_CONFIG *cfg = state->config; if (!Perl_get_context()) return; Log(LL_DBG2, "perl_setup_session(), perl context %p", Perl_get_context()); /* lvl 1 */ if (lvl >= 1 && state->perl_set_lvl < 1) { VK_ADD_intz(sv, "call", state->to != NULL); VK_ADD_intz(sv, "start", (int)state->start_time); VK_ADD_str (sv, "host", state->peer_name); VK_ADD_str (sv, "ip", state->ipaddr); VK_ADD_str (sv, "our_ip", state->our_ip); VK_ADD_intz(sv, "our_port", state->our_port); state->perl_set_lvl = 1; } /* lvl 2 */ if (lvl >= 2 && state->perl_set_lvl < 2) { int secure; uintmax_t netsize, filessize; if (state->state_ext != P_NA) secure = state->state_ext; else secure = state->state; VK_ADD_intz(sv, "secure", secure); VK_ADD_str (sv, "sysname", state->sysname); VK_ADD_str (sv, "sysop", state->sysop); VK_ADD_str (sv, "location", state->location); if (perl_get_sv("traf_mail", FALSE) == NULL) { q_get_sizes (state->q, &netsize, &filessize); VK_ADD_intz(sv, "traf_mail", (IV)netsize); VK_ADD_intz(sv, "traf_file", (IV)filessize); } hv = perl_get_hv("opt", TRUE); hv_clear(hv); VK_ADD_HASH_intz(hv, sv, "ND", state->ND_flag); VK_ADD_HASH_intz(hv, sv, "NR", state->NR_flag); VK_ADD_HASH_intz(hv, sv, "MD", state->MD_flag); VK_ADD_HASH_intz(hv, sv, "crypt", state->crypt_flag); #if defined(WITH_ZLIB) || defined(WITH_BZLIB2) VK_ADD_HASH_intz(hv, sv, "GZ", state->z_cansend); #endif setup_addrs("he", state->nfa, state->fa); if (state->nAddr && state->pAddr) setup_addrs("me", state->nAddr, state->pAddr); else setup_addrs("me", cfg->nAddr, cfg->pAddr); #if defined(WITH_ZLIB) || defined(WITH_BZLIB2) VK_ADD_intz(sv, "z_send", state->z_send); VK_ADD_intz(sv, "z_recv", state->z_recv); #endif #ifdef BW_LIM if (state->bw_send.rlim) VK_ADD_intz(sv, "bw_send", state->bw_send.rlim); if (state->bw_recv.rlim) VK_ADD_intz(sv, "bw_recv", state->bw_recv.rlim); #endif state->perl_set_lvl = 2; } /* lvl 3 */ if (lvl >= 3 && state->perl_set_lvl < 3) { VK_ADD_intz(sv, "bytes_rcvd", state->bytes_rcvd); VK_ADD_intz(sv, "bytes_sent", state->bytes_sent); VK_ADD_intz(sv, "files_rcvd", state->files_rcvd); VK_ADD_intz(sv, "files_sent", state->files_sent); } Log(LL_DBG2, "perl_setup_session() end"); } /* setup a queue */ static void setup_queue(STATE *state, FTNQ *queue) { char buf[FTN_ADDR_SZ]; AV *av; HV *hv; SV *sv; FTNQ *q; Log(LL_DBG2, "perl_setup_queue()"); av = perl_get_av("queue", TRUE); av_clear(av); for (q = queue; q; q = q->next) { hv = newHV(); VK_ADD_HASH_str (hv, sv, "file", q->path); VK_ADD_HASH_intz(hv, sv, "size", q->size); VK_ADD_HASH_intz(hv, sv, "time", q->time); VK_ADD_HASH_intz(hv, sv, "sent", q->sent); buf[0] = q->flvr; buf[1] = 0; VK_ADD_HASH_str (hv, sv, "flvr", buf); buf[0] = q->action; buf[1] = 0; VK_ADD_HASH_str (hv, sv, "action", buf); buf[0] = q->type; buf[1] = 0; VK_ADD_HASH_str (hv, sv, "type", buf); ftnaddress_to_str(buf, &(q->fa)); VK_ADD_HASH_str (hv, sv, "addr", buf); sv = newRV_noinc( (SV*)hv ); av_push(av, (SV*)sv); } Log(LL_DBG2, "perl_setup_queue() end"); } /* refresh queue */ static FTNQ *refresh_queue(STATE *state, FTNQ *queue) { FTNQ *q = NULL, *qp = NULL, *q0 = NULL; AV *av; HV *hv; SV **svp; STRLEN len; int i, n; char *s; BINKD_CONFIG *cfg; Log(LL_DBG2, "perl_refresh_queue()"); cfg = state->config; av = perl_get_av("queue", FALSE); if (!av) { Log(LL_DBG2, "perl_refresh_queue(): @queue undefined"); return queue; } n = av_len(av) + 1; for (i = 0; i < n; i++) { svp = av_fetch(av, i, 0); if (!svp || !SvROK(*svp)) continue; hv = (HV*)SvRV(*svp); if (SvTYPE(hv) != SVt_PVHV) continue; svp = hv_fetch(hv, "file", 4, 0); if (!svp || !SvOK(*svp)) continue; s = SvPV(*svp, len); if (len == 0) continue; qp = q; q = xalloc( sizeof(FTNQ) ); FQ_ZERO(q); if (!q0) q0 = q; else { qp->next = q; q->prev = qp; } strnzcpy(q->path, s, min(len+1, MAXPATHLEN)); svp = hv_fetch(hv, "size", 4, 0); if (!svp || !SvOK(*svp)) q->size = 0; else q->size = SvIV(*svp); svp = hv_fetch(hv, "time", 4, 0); if (!svp || !SvOK(*svp)) q->time = 0; else q->time = SvIV(*svp); svp = hv_fetch(hv, "sent", 4, 0); if (svp && SvOK(*svp)) q->sent = SvIV(*svp); else q->sent = 0; svp = hv_fetch(hv, "flvr", 4, 0); if (svp && SvOK(*svp)) { s = SvPV(*svp, len); q->flvr = s[0]; } else q->flvr = 'f'; svp = hv_fetch(hv, "action", 6, 0); if (svp && SvOK(*svp)) { s = SvPV(*svp, len); q->action = s[0]; } else q->action = 0; svp = hv_fetch(hv, "type", 4, 0); if (svp && SvOK(*svp)) { s = SvPV(*svp, len); q->type = s[0]; } else q->type = 0; svp = hv_fetch(hv, "addr", 4, 0); if (svp && SvOK(*svp)) { s = SvPV(*svp, len); if (!parse_ftnaddress(s, &(q->fa), cfg->pDomains.first)) q->fa = state->fa[0]; else exp_ftnaddress(&(q->fa), cfg->pAddr, cfg->nAddr, cfg->pDomains.first); } else q->fa = state->fa[0]; } if (queue != SCAN_LISTED) q_free(queue, cfg); Log(LL_DBG2, "perl_refresh_queue() end"); return q0; } /* =========================== hooks ========================== */ /* start, after init */ void perl_on_start(BINKD_CONFIG *cfg) { if (cfg->perl_ok & (1 << PERL_ON_START)) { Log(LL_DBG, "perl_on_start()"); lockperlsem(); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_START], G_EVAL|G_VOID); SPAGAIN; PUTBACK; FREETMPS; LEAVE; } if (SvTRUE(ERRSV)) sub_err(PERL_ON_START); /* { Log(LL_ERR, "Perl on_start() error: %s", SvPV(ERRSV, n_a)); }*/ releaseperlsem(); Log(LL_DBG, "perl_on_start() end"); } } /* before outgoing call */ int perl_on_call(FTN_NODE *node, BINKD_CONFIG *cfg, char **hosts #ifdef HTTPS , char **proxy, char **socks #endif ) { char buf[FTN_ADDR_SZ]; int rc, rcok; uintmax_t netsize, filessize; FTNQ *q; SV *svret, *svhosts, *sv; #ifdef HTTPS SV *svproxy, *svsocks; #endif if (cfg->perl_ok & (1 << PERL_ON_CALL)) { Log(LL_DBG, "perl_on_call(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 1; lockperlsem(); { dSP; q = q_scan_addrs (0, &(node->fa), 1, 1, cfg); q_get_sizes (q, &netsize, &filessize); VK_ADD_intz(sv, "traf_mail", (IV)netsize); VK_ADD_intz(sv, "traf_file", (IV)filessize); ftnaddress_to_str(buf, &(node->fa)); VK_ADD_strs(sv, "addr", buf); if ((svhosts = perl_get_sv("hosts", TRUE))) sv_setpv(svhosts, *hosts); #ifdef HTTPS if ((svproxy = perl_get_sv("proxy", TRUE))) sv_setpv(svproxy, *proxy); if ((svsocks = perl_get_sv("socks", TRUE))) sv_setpv(svsocks, *socks); #endif ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_CALL], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; rcok = SvOK(svret); if (rcok) rc = SvIV(svret); else rc = 1; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) sub_err(PERL_ON_CALL); else if (rc && rcok) { STRLEN len; char *s; sv = perl_get_sv("hosts", FALSE); if (sv && SvOK(sv)) { s = SvPV(sv, len); if (len == 0) s = ""; if (strcmp(s, *hosts)) { xfree(*hosts); *hosts = xstrdup(s); } } #ifdef HTTPS sv = perl_get_sv("proxy", FALSE); if (sv && SvOK(sv)) { s = SvPV(sv, len); if (len == 0) s = ""; if (strcmp(s, *proxy)) { xfree(*proxy); *proxy = xstrdup(s); } } sv = perl_get_sv("socks", FALSE); if (sv && SvOK(sv)) { s = SvPV(sv, len); if (len == 0) s = ""; if (strcmp(s, *socks)) { xfree(*socks); *socks = xstrdup(s); } } #endif } } releaseperlsem(); Log(LL_DBG, "perl_on_call() end"); return rc; } return 1; } /* after unsuccessfull call */ int perl_on_error(BINKD_CONFIG *cfg, FTN_ADDR *addr, const char *error, const int where) { char buf[FTN_ADDR_SZ]; int rc; SV *svret, *sv; if (cfg->perl_ok & (1 << PERL_ON_ERROR)) { Log(LL_DBG, "perl_on_error(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 1; lockperlsem(); { dSP; ftnaddress_to_str(buf, addr); VK_ADD_strs(sv, "addr", buf); VK_ADD_str (sv, "error", error); VK_ADD_intz(sv, "where", where); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_ERROR], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (!SvOK(svret)) rc = 1; else rc = SvIV(svret); PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) sub_err(PERL_ON_ERROR); } releaseperlsem(); Log(LL_DBG, "perl_on_error() end"); return rc; } return 1; } /* before xmitting ADR */ char *perl_on_handshake(STATE *state) { char buf[FTN_ADDR_SZ]; char *prc; int i; uintmax_t netsize, filessize; FTNQ *q; STRLEN len; AV *he, *me; SV *svret, **svp, *sv, *passwd; BINKD_CONFIG *cfg = state->config; /* this pointer is used later */ if (cfg->perl_ok && Perl_get_context()) { SET_STATE(state); } if (cfg->perl_ok & (1 << PERL_ON_HANDSHAKE)) { Log(LL_DBG, "perl_on_handshake(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return NULL; lockperlsem(); { dSP; if ( (me = perl_get_av("me", FALSE)) != NULL ) av_undef(me); if ( (passwd = perl_get_sv("passwd", FALSE)) != NULL ) passwd = &sv_undef; he = perl_get_av("he", TRUE); av_clear(he); if (!state->to) { for (i = 0; i < state->nfa; i++) { ftnaddress_to_str(buf, &(state->fa[i])); av_push(he, newSVpv(buf, 0)); } if (state->q) q = state->q; else if (OK_SEND_FILES (state, cfg)) q = state->q = q_scan_addrs (0, state->fa, state->nfa, 0, cfg); else q = NULL; } else { ftnaddress_to_str(buf, &(state->to->fa)); av_push(he, newSVpv(buf, 0)); q = q_scan_addrs (0, &(state->to->fa), 1, 1, cfg); } if (perl_get_sv("traf_mail", FALSE) == NULL) { q_get_sizes (q, &netsize, &filessize); VK_ADD_intz(sv, "traf_mail", (IV)netsize); VK_ADD_intz(sv, "traf_file", (IV)filessize); } setup_session(state, 1); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_HANDSHAKE], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvTRUE(svret)) prc = xstrdup(SvPV(svret, len)); else prc = NULL; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_ON_HANDSHAKE); if (prc) free(prc); prc = NULL; } /* make array of our aka */ else if (!prc) { if ((me = perl_get_av("me", FALSE)) != NULL) { FTN_ADDR addr; int n = 0, N = av_len(me) + 1; if (N > 0) state->pAddr = xalloc(N*sizeof(FTN_ADDR)); for (i = 0; i < N; i++) { svp = av_fetch(me, i, FALSE); if (svp == NULL) continue; if (!parse_ftnaddress(SvPV(*svp, len), &addr, cfg->pDomains.first)) continue; exp_ftnaddress(&addr, cfg->pAddr, cfg->nAddr, cfg->pDomains.first); state->pAddr[n++] = addr; } state->nAddr = n; if (n == 0) Log(LL_WARN, "Perl on_handshake(): @me contains no valid addresses"); } if ((passwd = perl_get_sv("passwd", FALSE)) != NULL && SvOK(passwd)) { strncpy(state->expected_pwd, SvPV(passwd, len), sizeof(state->expected_pwd)); state->expected_pwd[sizeof(state->expected_pwd) - 1] = '\0'; if (state->expected_pwd[0] == '\0') strcpy(state->expected_pwd, "-"); } } } releaseperlsem(); Log(LL_DBG, "perl_on_handshake() end"); return prc; } return NULL; } /* after handshake complete */ char *perl_after_handshake(STATE *state) { char *prc; STRLEN len; SV *svret; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_AFTER_HANDSHAKE)) { Log(LL_DBG, "perl_after_handshake(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return NULL; lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_AFTER_HANDSHAKE], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvTRUE(svret)) prc = xstrdup(SvPV(svret, len)); else prc = NULL; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_AFTER_HANDSHAKE); if (prc) free(prc); prc = NULL; } else state->q = refresh_queue(state, state->q); } releaseperlsem(); Log(LL_DBG, "perl_after_handshake() end"); return prc; } return NULL; } /* after session done */ void perl_after_session(STATE *state, int status) { SV *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok && Perl_get_context()) { CLEAR_STATE; } if (cfg->perl_ok & (1 << PERL_AFTER_SESSION)) { Log(LL_DBG, "perl_after_session(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return; lockperlsem(); { dSP; if (state->perl_set_lvl < 3) setup_session(state, 3); VK_ADD_intz(sv, "rc", status == 0); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_AFTER_SESSION], G_EVAL|G_VOID); SPAGAIN; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) sub_err(PERL_AFTER_SESSION); } releaseperlsem(); Log(LL_DBG, "perl_after_session() end"); } } /* before receiving file */ int perl_before_recv(STATE *state, boff_t offs) { int rc; SV *svret, *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_BEFORE_RECV)) { Log(LL_DBG, "perl_before_recv(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 0; lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); VK_ADD_str (sv, "name", state->in.netname); VK_ADD_intz(sv, "size", state->in.size); VK_ADD_intz(sv, "time", state->in.time); VK_ADD_intz(sv, "offs", offs); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_BEFORE_RECV], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_BEFORE_RECV); rc = 0; } } releaseperlsem(); Log(LL_DBG, "perl_before_recv() end"); return rc; } return 0; } /* after file has been received */ /* return 0 to keep real_name, 1 to update real_name and try renaming, 2 to kill tmp_name after having renamed it manually */ int perl_after_recv(STATE *state, TFILE *file, char *tmp_name, char *real_name) { int rc; STRLEN len; SV *svret, *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_AFTER_RECV)) { Log(LL_DBG, "perl_after_recv(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 0; lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); VK_ADD_str (sv, "name", file->netname); VK_ADD_intz(sv, "size", file->size); VK_ADD_intz(sv, "time", file->time); VK_ADD_str (sv, "tmpfile", tmp_name); VK_ADD_str (sv, "file", real_name); if (sv) { SvREADONLY_off(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_AFTER_RECV], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_AFTER_RECV); rc = 0; } /* update real_name */ else { state->q = refresh_queue(state, state->q); if (rc == 1) { sv = perl_get_sv("file", FALSE); if (sv && SvOK(sv)) { char *s = SvPV(sv, len); strnzcpy(real_name, len ? s : "", MAXPATHLEN); if (!len || !*s) rc = 2; /* turn off binkd renaming, kill */ } else rc = 2; /* turn off binkd renaming, kill */ if (rc == 1) rc = 0; /* turn on binkd renaming of updated real_name */ } } } releaseperlsem(); Log(LL_DBG, "perl_after_recv() end"); return rc; } return 0; } /* before sending file */ int perl_before_send(STATE *state) { int rc; STRLEN len; SV *svret, *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_BEFORE_SEND)) { Log(LL_DBG, "perl_before_send(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 0; lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); VK_ADD_str (sv, "file", state->out.path); VK_ADD_str (sv, "name", state->out.netname); if (sv) { SvREADONLY_off(sv); } VK_ADD_intz(sv, "size", state->out.size); VK_ADD_intz(sv, "time", state->out.time); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_BEFORE_SEND], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_BEFORE_SEND); rc = 0; } else { state->q = refresh_queue(state, state->q); if (rc == 0) { sv = perl_get_sv("name", FALSE); if (sv && SvOK(sv)) { char *s = SvPV(sv, len); strnzcpy(state->out.netname, s, MAX_NETNAME); } else rc = 1; } } } releaseperlsem(); Log(LL_DBG, "perl_before_send() end"); return rc; } return 0; } /* after file has been sent */ int perl_after_sent(STATE *state, int n) { char buf[2]; int rc; STRLEN len; SV *svret, *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_AFTER_SENT)) { Log(LL_DBG, "perl_after_sent(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 0; lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); VK_ADD_str (sv, "file", state->sent_fls[n].path); VK_ADD_str (sv, "name", state->sent_fls[n].netname); VK_ADD_intz(sv, "size", state->sent_fls[n].size); VK_ADD_intz(sv, "time", state->sent_fls[n].time); VK_ADD_intz(sv, "start", state->sent_fls[n].start); buf[0] = state->sent_fls[n].action; buf[1] = 0; VK_ADD_strs(sv, "action", buf); if (sv) { SvREADONLY_off(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_AFTER_SENT], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_AFTER_SENT); rc = 0; } else { if (rc) { sv = perl_get_sv("action", FALSE); if (sv && SvOK(sv)) { char *s = SvPV(sv, len); state->sent_fls[n].action = len ? *s : 0; } } } } releaseperlsem(); Log(LL_DBG, "perl_after_sent() end"); return rc; } return 0; } /* when writing string to log */ int perl_on_log(char *s, int bufsize, int *lev) { int rc = 1; STRLEN len; SV *svret, *sv, *svchk; BINKD_CONFIG *cfg; char inlog[20]; cfg = lock_current_config(); /* Log() always working by current_config */ if (!cfg) return 1; if (!cfg->perl_ok || !Perl_get_context()) { unlock_config_structure(cfg, 0); return 1; } if (cfg->perl_ok & (1 << PERL_ON_LOG)) { /* check: not to call while on_log() is running */ sprintf(inlog, "__in_log_%u", (unsigned)PID()); svchk = perl_get_sv(inlog, FALSE); if (svchk && SvIV(svchk) == 1) { unlock_config_structure(cfg, 0); return 1; } if (svchk) SvREADONLY_off(svchk); else if ((svchk = perl_get_sv(inlog, TRUE)) == NULL) { unlock_config_structure(cfg, 0); return 1; /* can't guarantee there won't be recursion */ } sv_setiv(svchk, 1); SvREADONLY_on(svchk); /* end of check */ Log(LL_DBG2, "perl_on_log(), perl=%p", Perl_get_context()); { dSP; VK_ADD_intz(sv, "lvl", *lev); if (sv) { SvREADONLY_off(sv); } VK_ADD_str (sv, "_", s); if (sv) { SvREADONLY_off(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_LOG], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_ON_LOG); rc = 1; } else if (rc && sv) { char *p = SvPV(sv, len); if (!p || len == 0 || *p == 0) rc = 0; else { rc = 1; strnzcpy(s, p, min((int)len+1, bufsize)); sv = perl_get_sv("lvl", FALSE); if (sv) *lev = SvIV(sv); } } else rc = 1; } Log(LL_DBG2, "perl_on_log() end"); SvREADONLY_off(svchk); sv_setiv(svchk, 0); /* check: now we can restore */ /* SvREFCNT_dec(svchk); */ unlock_config_structure(cfg, 0); return rc; } unlock_config_structure(cfg, 0); return 1; } int perl_on_send(STATE *state, t_msg *m, char **s1, char **s2) { int rc = 1; SV *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_ON_SEND)) { Log(LL_DBG2, "perl_on_send(), perl=%p", Perl_get_context()); lockperlsem(); { dSP; VK_ADD_intz(sv, "type", *m); VK_ADD_str (sv, "s1", *s1); VK_ADD_str (sv, "s2", *s2); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_SEND], G_EVAL|G_SCALAR); SPAGAIN; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_ON_SEND); } } releaseperlsem(); Log(LL_DBG2, "perl_on_send() end"); return rc; } return 1; } int perl_on_recv(STATE *state, char *s, int size) { int rc = 1; SV *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_ON_RECV)) { Log(LL_DBG2, "perl_on_recv(), perl=%p", Perl_get_context()); lockperlsem(); { dSP; if ( (sv = perl_get_sv("s", TRUE)) ) { SvREADONLY_off(sv); sv_setpvn(sv, s, size); SvREADONLY_on(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_ON_RECV], G_EVAL|G_SCALAR); SPAGAIN; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_ON_RECV); } } releaseperlsem(); Log(LL_DBG2, "perl_on_recv() end"); return rc; } return 1; } #ifdef BW_LIM int perl_setup_rlimit(STATE *state, BW *bw, char *fname) { int rc = 1; STRLEN len; SV *sv; BINKD_CONFIG *cfg = state->config; if (cfg->perl_ok & (1 << PERL_SETUP_RLIMIT)) { Log(LL_DBG2, "perl_set_rlimit(), perl=%p", Perl_get_context()); lockperlsem(); { dSP; if (state->perl_set_lvl < 2) setup_session(state, 2); setup_queue(state, state->q); VK_ADD_str (sv, "file", fname); VK_ADD_intz (sv, "rlimit", bw->rlim); if (sv) { SvREADONLY_off(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_SETUP_RLIMIT], G_EVAL|G_SCALAR); SPAGAIN; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_SETUP_RLIMIT); rc = 1; } else if (rc && sv) { char *p = SvPV(sv, len); if (!p || len == 0 || *p == 0) rc = 0; else { rc = 1; sv = perl_get_sv("rlimit", FALSE); if (sv) bw->rlim = SvIV(sv); } } } releaseperlsem(); Log(LL_DBG2, "perl_setup_rlimit() end"); return rc; } return 1; } #endif /* need reload config? */ int perl_need_reload(BINKD_CONFIG *cfg, struct conflist_type *conflist, int need_reload) { struct conflist_type *pc; int rc; AV *av; SV *sv, *svret; if (cfg->perl_ok & (1 << PERL_NEED_RELOAD)) { Log(LL_DBG, "perl_need_reload(), perl=%p", Perl_get_context()); if (!Perl_get_context()) return 0; lockperlsem(); { dSP; av = perl_get_av("conflist", TRUE); av_clear(av); for (pc = conflist; pc; pc = pc->next) { sv = newSVpv(pc->path, 0); SvREADONLY_on(sv); av_push(av, sv); } Log(LL_DBG2, "perl_need_reload(): @conflist done"); VK_ADD_intz (sv, "_", need_reload); if (sv) { SvREADONLY_off(sv); } ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_NEED_RELOAD], G_EVAL|G_SCALAR); SPAGAIN; svret=POPs; if (SvOK(svret)) rc = SvIV(svret); else rc = 0; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_NEED_RELOAD); rc = 0; } } releaseperlsem(); Log(LL_DBG, "perl_need_reload() end, returns %i", rc); return rc; } return 0; } /* config loaded */ void perl_config_loaded(BINKD_CONFIG *cfg) { if (cfg->perl && (cfg->perl_ok & (1 << PERL_CONFIG_LOADED))) { Log(LL_DBG, "perl_config_loaded()"); lockperlsem(); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; perl_call_pv(perl_subnames[PERL_CONFIG_LOADED], G_EVAL|G_SCALAR); SPAGAIN; PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sub_err(PERL_CONFIG_LOADED); } } releaseperlsem(); Log(LL_DBG, "perl_config_loaded() end"); return; } return; }