diff options
Diffstat (limited to '')
| -rw-r--r-- | src/perl.c | 197 |
1 files changed, 197 insertions, 0 deletions
diff --git a/src/perl.c b/src/perl.c new file mode 100644 index 0000000..58643f0 --- /dev/null +++ b/src/perl.c @@ -0,0 +1,197 @@ +/************************************************* +* Exim - an Internet mail transport agent * +*************************************************/ + +/* Copyright (c) 1998 Malcolm Beattie */ +/* Copyright (C) 1999 - 2018 Exim maintainers */ + +/* Modified by PH to get rid of the "na" usage, March 1999. + Modified further by PH for general tidying for Exim 4. + Threaded Perl support added by Stefan Traby, Nov 2002 +*/ + + +/* This Perl add-on can be distributed under the same terms as Exim itself. */ +/* See the file NOTICE for conditions of use and distribution. */ + +#include <assert.h> +#include "exim.h" + +#define EXIM_TRUE TRUE +#undef TRUE + +#define EXIM_FALSE FALSE +#undef FALSE + +#define EXIM_DEBUG DEBUG +#undef DEBUG + +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> + +#ifndef ERRSV +#define ERRSV (GvSV(errgv)) +#endif + +/* Some people like very old perl versions, so avoid any build side-effects. */ + +#ifndef pTHX +# define pTHX +# define pTHX_ +#endif +#ifndef EXTERN_C +# define EXTERN_C extern +#endif + +EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); + + +static PerlInterpreter *interp_perl = 0; + +XS(xs_expand_string) +{ + dXSARGS; + uschar *str; + STRLEN len; + + if (items != 1) + croak("Usage: Exim::expand_string(string)"); + + str = expand_string(US SvPV(ST(0), len)); + ST(0) = sv_newmortal(); + if (str != NULL) + sv_setpv(ST(0), CCS str); + else if (!f.expand_string_forcedfail) + croak("syntax error in Exim::expand_string argument: %s", + expand_string_message); +} + +XS(xs_debug_write) +{ + dXSARGS; + STRLEN len; + if (items != 1) + croak("Usage: Exim::debug_write(string)"); + debug_printf("%s", US SvPV(ST(0), len)); +} + +XS(xs_log_write) +{ + dXSARGS; + STRLEN len; + if (items != 1) + croak("Usage: Exim::log_write(string)"); + log_write(0, LOG_MAIN, "%s", US SvPV(ST(0), len)); +} + +static void xs_init(pTHX) +{ + char *file = __FILE__; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + newXS("Exim::expand_string", xs_expand_string, file); + newXS("Exim::debug_write", xs_debug_write, file); + newXS("Exim::log_write", xs_log_write, file); +} + +uschar * +init_perl(uschar *startup_code) +{ + static int argc = 1; + static char *argv[4] = { "exim-perl" }; + SV *sv; + STRLEN len; + + if (opt_perl_taintmode) argv[argc++] = "-T"; + argv[argc++] = "/dev/null"; + argv[argc] = 0; + + assert(sizeof(argv)/sizeof(argv[0]) > argc); + + if (interp_perl) return 0; + interp_perl = perl_alloc(); + perl_construct(interp_perl); + perl_parse(interp_perl, xs_init, argc, argv, 0); + perl_run(interp_perl); + { + dSP; + + /*********************************************************************/ + /* These lines by PH added to make "warn" output go to the Exim log; I + hope this doesn't break anything. */ + + sv = newSVpv( + "$SIG{__WARN__} = sub { my($s) = $_[0];" + "$s =~ s/\\n$//;" + "Exim::log_write($s) };", 0); + PUSHMARK(SP); + perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR); + SvREFCNT_dec(sv); + if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len); + /*********************************************************************/ + + sv = newSVpv(CS startup_code, 0); + PUSHMARK(SP); + perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR); + SvREFCNT_dec(sv); + if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len); + + setlocale(LC_ALL, "C"); /* In case it got changed */ + return NULL; + } +} + +void +cleanup_perl(void) +{ + if (!interp_perl) + return; + perl_destruct(interp_perl); + perl_free(interp_perl); + interp_perl = 0; +} + +gstring * +call_perl_cat(gstring * yield, uschar **errstrp, uschar *name, uschar **arg) +{ + dSP; + SV *sv; + STRLEN len; + uschar *str; + int items; + + if (!interp_perl) + { + *errstrp = US"the Perl interpreter has not been started"; + return 0; + } + + ENTER; + SAVETMPS; + PUSHMARK(SP); + while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0)); + PUTBACK; + items = perl_call_pv(CS name, G_SCALAR|G_EVAL); + SPAGAIN; + sv = POPs; + PUTBACK; + if (SvTRUE(ERRSV)) + { + *errstrp = US SvPV(ERRSV, len); + return NULL; + } + if (!SvOK(sv)) + { + *errstrp = 0; + return NULL; + } + str = US SvPV(sv, len); + yield = string_catn(yield, str, (int)len); + FREETMPS; + LEAVE; + + setlocale(LC_ALL, "C"); /* In case it got changed */ + return yield; +} + +/* End of perl.c */ |