DKIM: use Exim native memoory management
[exim.git] / src / src / perl.c
CommitLineData
059ec3d9
PH
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
2f680c0c 16#include <assert.h>
059ec3d9
PH
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
46EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
47
48
49static PerlInterpreter *interp_perl = 0;
50
51XS(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), (const char *) str);
64 else if (!expand_string_forcedfail)
65 croak("syntax error in Exim::expand_string argument: %s",
66 expand_string_message);
67}
68
69XS(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
78XS(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
87static 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
96uschar *
97init_perl(uschar *startup_code)
98{
2f680c0c
HSHR
99 static int argc = 1;
100 static char *argv[4] = { "exim-perl" };
059ec3d9
PH
101 SV *sv;
102 STRLEN len;
103
2f680c0c
HSHR
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
059ec3d9
PH
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;
76a2d7ba
PH
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. */
8e669ac1 121
76a2d7ba
PH
122 sv = newSVpv(
123 "$SIG{__WARN__} = sub { my($s) = $_[0];"
8e669ac1 124 "$s =~ s/\\n$//;"
76a2d7ba
PH
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 /*********************************************************************/
8e669ac1 131
059ec3d9
PH
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);
35d40a98
PH
137
138 setlocale(LC_ALL, "C"); /* In case it got changed */
059ec3d9
PH
139 return NULL;
140 }
141}
142
143void
144cleanup_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
153uschar *
154call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
155 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_cat(yield, sizep, ptrp, str, (int)len);
190 FREETMPS;
191 LEAVE;
8e669ac1 192
a444213a 193 setlocale(LC_ALL, "C"); /* In case it got changed */
059ec3d9
PH
194 return yield;
195}
196
197/* End of perl.c */