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