src/src/perl.c

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