constification
[exim.git] / 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 #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), CCS  str);
65   else if (!f.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 = 1;
101   static char *argv[4] = { "exim-perl" };
102   SV *sv;
103   STRLEN len;
104
105   if (opt_perl_taintmode) argv[argc++] = "-T";
106   argv[argc++] = "/dev/null";
107   argv[argc] = 0;
108
109   assert(sizeof(argv)/sizeof(argv[0]) > argc);
110
111   if (interp_perl) return 0;
112   interp_perl = perl_alloc();
113   perl_construct(interp_perl);
114   perl_parse(interp_perl, xs_init, argc, argv, 0);
115   perl_run(interp_perl);
116     {
117     dSP;
118
119     /*********************************************************************/
120     /* These lines by PH added to make "warn" output go to the Exim log; I
121     hope this doesn't break anything. */
122
123     sv = newSVpv(
124       "$SIG{__WARN__} = sub { my($s) = $_[0];"
125       "$s =~ s/\\n$//;"
126       "Exim::log_write($s) };", 0);
127     PUSHMARK(SP);
128     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
129     SvREFCNT_dec(sv);
130     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
131     /*********************************************************************/
132
133     sv = newSVpv(CS startup_code, 0);
134     PUSHMARK(SP);
135     perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
136     SvREFCNT_dec(sv);
137     if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
138
139     setlocale(LC_ALL, "C");    /* In case it got changed */
140     return NULL;
141     }
142 }
143
144 void
145 cleanup_perl(void)
146 {
147   if (!interp_perl)
148     return;
149   perl_destruct(interp_perl);
150   perl_free(interp_perl);
151   interp_perl = 0;
152 }
153
154 gstring *
155 call_perl_cat(gstring * yield, uschar **errstrp, uschar *name, uschar **arg)
156 {
157   dSP;
158   SV *sv;
159   STRLEN len;
160   uschar *str;
161   int items;
162
163   if (!interp_perl)
164     {
165     *errstrp = US"the Perl interpreter has not been started";
166     return 0;
167     }
168
169   ENTER;
170   SAVETMPS;
171   PUSHMARK(SP);
172   while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
173   PUTBACK;
174   items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
175   SPAGAIN;
176   sv = POPs;
177   PUTBACK;
178   if (SvTRUE(ERRSV))
179     {
180     *errstrp = US SvPV(ERRSV, len);
181     return NULL;
182     }
183   if (!SvOK(sv))
184     {
185     *errstrp = 0;
186     return NULL;
187     }
188   str = US SvPV(sv, len);
189   yield = string_catn(yield, str, (int)len);
190   FREETMPS;
191   LEAVE;
192
193   setlocale(LC_ALL, "C");    /* In case it got changed */
194   return yield;
195 }
196
197 /* End of perl.c */