src/src/perl.c

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