src/src/perl.c

   1 /* $Cambridge: exim/src/src/perl.c,v 1.5 2006/07/14 14:32:09 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
 133     setlocale(LC_ALL, "C");    /* In case it got changed */
 134     return NULL;
 135     }
 136 }
 137
 138 void
 139 cleanup_perl(void)
 140 {
 141   if (!interp_perl)
 142     return;
 143   perl_destruct(interp_perl);
 144   perl_free(interp_perl);
 145   interp_perl = 0;
 146 }
 147
 148 uschar *
 149 call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
 150   uschar *name, uschar **arg)
 151 {
 152   dSP;
 153   SV *sv;
 154   STRLEN len;
 155   uschar *str;
 156   int items;
 157
 158   if (!interp_perl)
 159     {
 160     *errstrp = US"the Perl interpreter has not been started";
 161     return 0;
 162     }
 163
 164   ENTER;
 165   SAVETMPS;
 166   PUSHMARK(SP);
 167   while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
 168   PUTBACK;
 169   items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
 170   SPAGAIN;
 171   sv = POPs;
 172   PUTBACK;
 173   if (SvTRUE(ERRSV))
 174     {
 175     *errstrp = US SvPV(ERRSV, len);
 176     return NULL;
 177     }
 178   if (!SvOK(sv))
 179     {
 180     *errstrp = 0;
 181     return NULL;
 182     }
 183   str = US SvPV(sv, len);
 184   yield = string_cat(yield, sizep, ptrp, str, (int)len);
 185   FREETMPS;
 186   LEAVE;
 187
 188   setlocale(LC_ALL, "C");    /* In case it got changed */
 189   return yield;
 190 }
 191
 192 /* End of perl.c */