src/src/perl.c

   1 /* $Cambridge: exim/src/src/perl.c,v 1.2 2004/12/20 11:46:21 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     sv = newSVpv(CS startup_code, 0);
 113     PUSHMARK(SP);
 114     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
 115     SvREFCNT_dec(sv);
 116     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
 117     return NULL;
 118     }
 119 }
 120
 121 void
 122 cleanup_perl(void)
 123 {
 124   if (!interp_perl)
 125     return;
 126   perl_destruct(interp_perl);
 127   perl_free(interp_perl);
 128   interp_perl = 0;
 129 }
 130
 131 uschar *
 132 call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
 133   uschar *name, uschar **arg)
 134 {
 135   dSP;
 136   SV *sv;
 137   STRLEN len;
 138   uschar *str;
 139   int items;
 140
 141   if (!interp_perl)
 142     {
 143     *errstrp = US"the Perl interpreter has not been started";
 144     return 0;
 145     }
 146
 147   ENTER;
 148   SAVETMPS;
 149   PUSHMARK(SP);
 150   while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
 151   PUTBACK;
 152   items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
 153   SPAGAIN;
 154   sv = POPs;
 155   PUTBACK;
 156   if (SvTRUE(ERRSV))
 157     {
 158     *errstrp = US SvPV(ERRSV, len);
 159     return NULL;
 160     }
 161   if (!SvOK(sv))
 162     {
 163     *errstrp = 0;
 164     return NULL;
 165     }
 166   str = US SvPV(sv, len);
 167   yield = string_cat(yield, sizep, ptrp, str, (int)len);
 168   FREETMPS;
 169   LEAVE;
 170
 171   setlocale(LC_ALL, "C");    /* In case it got changed */
 172   return yield;
 173 }
 174
 175 /* End of perl.c */