src/src/perl.c

   1 /*************************************************
   2 *     Exim - an Internet mail transport agent    *
   3 *************************************************/
   4
   5 /* Copyright (c) 1998 Malcolm Beattie */
   6 /* Copyright (C) 1999 - 2018  Exim maintainers */
   7
   8 /* Modified by PH to get rid of the "na" usage, March 1999.
   9    Modified further by PH for general tidying for Exim 4.
  10    Threaded Perl support added by Stefan Traby, Nov 2002
  11 */
  12
  13
  14 /* This Perl add-on can be distributed under the same terms as Exim itself. */
  15 /* See the file NOTICE for conditions of use and distribution. */
  16
  17 #include <assert.h>
  18 #include "exim.h"
  19
  20 #define EXIM_TRUE TRUE
  21 #undef TRUE
  22
  23 #define EXIM_FALSE FALSE
  24 #undef FALSE
  25
  26 #define EXIM_DEBUG DEBUG
  27 #undef DEBUG
  28
  29 #include <EXTERN.h>
  30 #include <perl.h>
  31 #include <XSUB.h>
  32
  33 #ifndef ERRSV
  34 #define ERRSV (GvSV(errgv))
  35 #endif
  36
  37 /* Some people like very old perl versions, so avoid any build side-effects. */
  38
  39 #ifndef pTHX
  40 # define pTHX
  41 # define pTHX_
  42 #endif
  43 #ifndef EXTERN_C
  44 # define EXTERN_C extern
  45 #endif
  46
  47 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
  48
  49
  50 static PerlInterpreter *interp_perl = 0;
  51
  52 XS(xs_expand_string)
  53 {
  54   dXSARGS;
  55   uschar *str;
  56   STRLEN len;
  57
  58   if (items != 1)
  59     croak("Usage: Exim::expand_string(string)");
  60
  61   str = expand_string(US SvPV(ST(0), len));
  62   ST(0) = sv_newmortal();
  63   if (str != NULL)
  64     sv_setpv(ST(0), CCS  str);
  65   else if (!f.expand_string_forcedfail)
  66     croak("syntax error in Exim::expand_string argument: %s",
  67       expand_string_message);
  68 }
  69
  70 XS(xs_debug_write)
  71 {
  72   dXSARGS;
  73   STRLEN len;
  74   if (items != 1)
  75     croak("Usage: Exim::debug_write(string)");
  76   debug_printf("%s", US SvPV(ST(0), len));
  77 }
  78
  79 XS(xs_log_write)
  80 {
  81   dXSARGS;
  82   STRLEN len;
  83   if (items != 1)
  84     croak("Usage: Exim::log_write(string)");
  85   log_write(0, LOG_MAIN, "%s", US SvPV(ST(0), len));
  86 }
  87
  88 static void  xs_init(pTHX)
  89 {
  90   char *file = __FILE__;
  91   newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  92   newXS("Exim::expand_string", xs_expand_string, file);
  93   newXS("Exim::debug_write", xs_debug_write, file);
  94   newXS("Exim::log_write", xs_log_write, file);
  95 }
  96
  97 uschar *
  98 init_perl(uschar *startup_code)
  99 {
 100   static int argc = 1;
 101   static char *argv[4] = { "exim-perl" };
 102   SV *sv;
 103   STRLEN len;
 104
 105   if (opt_perl_taintmode) argv[argc++] = "-T";
 106   argv[argc++] = "/dev/null";
 107   argv[argc] = 0;
 108
 109   assert(sizeof(argv)/sizeof(argv[0]) > argc);
 110
 111   if (interp_perl) return 0;
 112   interp_perl = perl_alloc();
 113   perl_construct(interp_perl);
 114   perl_parse(interp_perl, xs_init, argc, argv, 0);
 115   perl_run(interp_perl);
 116     {
 117     dSP;
 118
 119     /*********************************************************************/
 120     /* These lines by PH added to make "warn" output go to the Exim log; I
 121     hope this doesn't break anything. */
 122
 123     sv = newSVpv(
 124       "$SIG{__WARN__} = sub { my($s) = $_[0];"
 125       "$s =~ s/\\n$//;"
 126       "Exim::log_write($s) };", 0);
 127     PUSHMARK(SP);
 128     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
 129     SvREFCNT_dec(sv);
 130     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
 131     /*********************************************************************/
 132
 133     sv = newSVpv(CS startup_code, 0);
 134     PUSHMARK(SP);
 135     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
 136     SvREFCNT_dec(sv);
 137     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
 138
 139     setlocale(LC_ALL, "C");    /* In case it got changed */
 140     return NULL;
 141     }
 142 }
 143
 144 void
 145 cleanup_perl(void)
 146 {
 147   if (!interp_perl)
 148     return;
 149   perl_destruct(interp_perl);
 150   perl_free(interp_perl);
 151   interp_perl = 0;
 152 }
 153
 154 gstring *
 155 call_perl_cat(gstring * yield, uschar **errstrp, uschar *name, uschar **arg)
 156 {
 157   dSP;
 158   SV *sv;
 159   STRLEN len;
 160   uschar *str;
 161   int items;
 162
 163   if (!interp_perl)
 164     {
 165     *errstrp = US"the Perl interpreter has not been started";
 166     return 0;
 167     }
 168
 169   ENTER;
 170   SAVETMPS;
 171   PUSHMARK(SP);
 172   while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
 173   PUTBACK;
 174   items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
 175   SPAGAIN;
 176   sv = POPs;
 177   PUTBACK;
 178   if (SvTRUE(ERRSV))
 179     {
 180     *errstrp = US SvPV(ERRSV, len);
 181     return NULL;
 182     }
 183   if (!SvOK(sv))
 184     {
 185     *errstrp = 0;
 186     return NULL;
 187     }
 188   str = US SvPV(sv, len);
 189   yield = string_catn(yield, str, (int)len);
 190   FREETMPS;
 191   LEAVE;
 192
 193   setlocale(LC_ALL, "C");    /* In case it got changed */
 194   return yield;
 195 }
 196
 197 /* End of perl.c */