New expansion operator sha256 for certificates. Bug 1170
[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 */