src/src/perl.c

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