src/src/perl.c

   1 /* $Cambridge: exim/src/src/perl.c,v 1.3 2005/01/27 15:00:39 ph10 Exp $ */
   2
   3 /*************************************************
   4 *     Exim - an Internet mail transport agent    *
   5 *************************************************/
   6
   7 /* Copyright (c) 1998 Malcolm Beattie */
   8
   9 /* Modified by PH to get rid of the "na" usage, March 1999.
  10    Modified further by PH for general tidying for Exim 4.
  11    Threaded Perl support added by Stefan Traby, Nov 2002
  12 */
  13
  14
  15 /* This Perl add-on can be distributed under the same terms as Exim itself. */
  16 /* See the file NOTICE for conditions of use and distribution. */
  17
  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), (const char *) str);
  65   else if (!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 = 2;
 101   static char *argv[3] = { "exim-perl", "/dev/null", 0 };
 102   SV *sv;
 103   STRLEN len;
 104
 105   if (interp_perl) return 0;
 106   interp_perl = perl_alloc();
 107   perl_construct(interp_perl);
 108   perl_parse(interp_perl, xs_init, argc, argv, 0);
 109   perl_run(interp_perl);
 110     {
 111     dSP;
 112
 113     /*********************************************************************/
 114     /* These lines by PH added to make "warn" output go to the Exim log; I
 115     hope this doesn't break anything. */
 116
 117     sv = newSVpv(
 118       "$SIG{__WARN__} = sub { my($s) = $_[0];"
 119       "$s =~ s/\\n$//;"
 120       "Exim::log_write($s) };", 0);
 121     PUSHMARK(SP);
 122     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
 123     SvREFCNT_dec(sv);
 124     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
 125     /*********************************************************************/
 126
 127     sv = newSVpv(CS startup_code, 0);
 128     PUSHMARK(SP);
 129     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
 130     SvREFCNT_dec(sv);
 131     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
 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 */