src/src/miscmods/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 static 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 #ifdef notdef
 150 static void
 151 cleanup_perl(void)
 152 {
 153   if (!interp_perl)
 154     return;
 155   perl_destruct(interp_perl);
 156   perl_free(interp_perl);
 157   interp_perl = 0;
 158 }
 159 #endif
 160
 161 static gstring *
 162 call_perl_cat(gstring * yield, uschar **errstrp, uschar *name, uschar **arg)
 163 {
 164   dSP;
 165   SV *sv;
 166   STRLEN len;
 167   uschar *str;
 168   int items;
 169
 170   if (!interp_perl)
 171     {
 172     *errstrp = US"the Perl interpreter has not been started";
 173     return 0;
 174     }
 175
 176   ENTER;
 177   SAVETMPS;
 178   PUSHMARK(SP);
 179   while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
 180   PUTBACK;
 181   items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
 182   SPAGAIN;
 183   sv = POPs;
 184   PUTBACK;
 185   if (SvTRUE(ERRSV))
 186     {
 187     *errstrp = US SvPV(ERRSV, len);
 188     return NULL;
 189     }
 190   if (!SvOK(sv))
 191     {
 192     *errstrp = 0;
 193     return NULL;
 194     }
 195   str = US SvPV(sv, len);
 196   yield = string_catn(yield, str, (int)len);
 197   FREETMPS;
 198   LEAVE;
 199
 200   setlocale(LC_ALL, "C");    /* In case it got changed */
 201   return yield;
 202 }
 203
 204
 205
 206
 207 /******************************************************************************/
 208 /* Module API */
 209
 210 static void * perl_functions[] = {
 211   [PERL_STARTUP] =      init_perl,
 212   [PERL_CAT] =          call_perl_cat,
 213 };
 214
 215 misc_module_info perl_module_info =
 216 {
 217   .name =               US"perl",
 218 # ifdef DYNLOOKUP
 219   .dyn_magic =          MISC_MODULE_MAGIC,
 220 # endif
 221
 222   .functions =          perl_functions,
 223   .functions_count =    nelem(perl_functions),
 224 };
 225
 226 /* End of perl.c */