Start
[exim.git] / src / src / perl.c
CommitLineData
059ec3d9
PH
1/* $Cambridge: exim/src/src/perl.c,v 1.1 2004/10/07 10:39:01 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
47EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
48
49
50static PerlInterpreter *interp_perl = 0;
51
52XS(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
70XS(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
79XS(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
88static 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
97uschar *
98init_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 sv = newSVpv(CS startup_code, 0);
113 PUSHMARK(SP);
114 perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
115 SvREFCNT_dec(sv);
116 if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
117 return NULL;
118 }
119}
120
121void
122cleanup_perl(void)
123{
124 if (!interp_perl)
125 return;
126 perl_destruct(interp_perl);
127 perl_free(interp_perl);
128 interp_perl = 0;
129}
130
131uschar *
132call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
133 uschar *name, uschar **arg)
134{
135 dSP;
136 SV *sv;
137 STRLEN len;
138 uschar *str;
139 int items;
140
141 if (!interp_perl)
142 {
143 *errstrp = US"the Perl interpreter has not been started";
144 return 0;
145 }
146
147 ENTER;
148 SAVETMPS;
149 PUSHMARK(SP);
150 while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
151 PUTBACK;
152 items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
153 SPAGAIN;
154 sv = POPs;
155 PUTBACK;
156 if (SvTRUE(ERRSV))
157 {
158 *errstrp = US SvPV(ERRSV, len);
159 return NULL;
160 }
161 if (!SvOK(sv))
162 {
163 *errstrp = 0;
164 return NULL;
165 }
166 str = US SvPV(sv, len);
167 yield = string_cat(yield, sizep, ptrp, str, (int)len);
168 FREETMPS;
169 LEAVE;
170
171 return yield;
172}
173
174/* End of perl.c */