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