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