1 /*************************************************
2 * Exim - an Internet mail transport agent *
3 *************************************************/
5 /* Copyright (c) 1998 Malcolm Beattie */
7 /* Modified by PH to get rid of the "na" usage, March 1999.
8 Modified further by PH for general tidying for Exim 4.
9 Threaded Perl support added by Stefan Traby, Nov 2002
13 /* This Perl add-on can be distributed under the same terms as Exim itself. */
14 /* See the file NOTICE for conditions of use and distribution. */
19 #define EXIM_TRUE TRUE
22 #define EXIM_FALSE FALSE
25 #define EXIM_DEBUG DEBUG
33 #define ERRSV (GvSV(errgv))
36 /* Some people like very old perl versions, so avoid any build side-effects. */
43 # define EXTERN_C extern
46 EXTERN_C
void boot_DynaLoader(pTHX_ CV
*cv
);
49 static PerlInterpreter
*interp_perl
= 0;
58 croak("Usage: Exim::expand_string(string)");
60 str
= expand_string(US
SvPV(ST(0), len
));
61 ST(0) = sv_newmortal();
63 sv_setpv(ST(0), (const char *) str
);
64 else if (!expand_string_forcedfail
)
65 croak("syntax error in Exim::expand_string argument: %s",
66 expand_string_message
);
74 croak("Usage: Exim::debug_write(string)");
75 debug_printf("%s", US
SvPV(ST(0), len
));
83 croak("Usage: Exim::log_write(string)");
84 log_write(0, LOG_MAIN
, "%s", US
SvPV(ST(0), len
));
87 static void xs_init(pTHX
)
89 char *file
= __FILE__
;
90 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader
, file
);
91 newXS("Exim::expand_string", xs_expand_string
, file
);
92 newXS("Exim::debug_write", xs_debug_write
, file
);
93 newXS("Exim::log_write", xs_log_write
, file
);
97 init_perl(uschar
*startup_code
)
100 static char *argv
[4] = { "exim-perl" };
104 if (opt_perl_taintmode
) argv
[argc
++] = "-T";
105 argv
[argc
++] = "/dev/null";
108 assert(sizeof(argv
)/sizeof(argv
[0]) > argc
);
110 if (interp_perl
) return 0;
111 interp_perl
= perl_alloc();
112 perl_construct(interp_perl
);
113 perl_parse(interp_perl
, xs_init
, argc
, argv
, 0);
114 perl_run(interp_perl
);
118 /*********************************************************************/
119 /* These lines by PH added to make "warn" output go to the Exim log; I
120 hope this doesn't break anything. */
123 "$SIG{__WARN__} = sub { my($s) = $_[0];"
125 "Exim::log_write($s) };", 0);
127 perl_eval_sv(sv
, G_SCALAR
|G_DISCARD
|G_KEEPERR
);
129 if (SvTRUE(ERRSV
)) return US
SvPV(ERRSV
, len
);
130 /*********************************************************************/
132 sv
= newSVpv(CS startup_code
, 0);
134 perl_eval_sv(sv
, G_SCALAR
|G_DISCARD
|G_KEEPERR
);
136 if (SvTRUE(ERRSV
)) return US
SvPV(ERRSV
, len
);
138 setlocale(LC_ALL
, "C"); /* In case it got changed */
148 perl_destruct(interp_perl
);
149 perl_free(interp_perl
);
154 call_perl_cat(uschar
*yield
, int *sizep
, int *ptrp
, uschar
**errstrp
,
155 uschar
*name
, uschar
**arg
)
165 *errstrp
= US
"the Perl interpreter has not been started";
172 while (*arg
!= NULL
) XPUSHs(newSVpv(CS (*arg
++), 0));
174 items
= perl_call_pv(CS name
, G_SCALAR
|G_EVAL
);
180 *errstrp
= US
SvPV(ERRSV
, len
);
188 str
= US
SvPV(sv
, len
);
189 yield
= string_catn(yield
, sizep
, ptrp
, str
, (int)len
);
193 setlocale(LC_ALL
, "C"); /* In case it got changed */