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