1 /***********************************************************************
2 *
3 * embperl.c
4 *
5 * Routines for manipulating embedded Perl interpreter
6 *
7 * Copyright (C) 2003 by Roaring Penguin Software Inc.
8 *
9 ***********************************************************************/
10
11 #ifdef EMBED_PERL
12 #include <EXTERN.h>
13 #include <perl.h>
14 #include <errno.h>
15 #include <syslog.h>
16
17 #ifdef PERL_SET_CONTEXT
18 #define PSC(x) PERL_SET_CONTEXT(x)
19 #else
20 #define PSC(x) (void) 0
21 #endif
22
23 #define PERLPARSE_NUM_ARGS 6
24
25 static PerlInterpreter *my_perl = NULL;
26 extern void xs_init ();
27
28 void
init_embedded_interpreter(int argc,char ** argv,char ** env)29 init_embedded_interpreter(int argc, char **argv, char **env)
30 {
31 #ifdef PERL_SYS_INIT3
32 PERL_SYS_INIT3(&argc, &argv, &env);
33 #endif
34 }
35
36 void
term_embedded_interpreter(void)37 term_embedded_interpreter(void)
38 {
39 if (my_perl != NULL) {
40 PSC(my_perl);
41 PERL_SET_INTERP(my_perl);
42 PL_perl_destruct_level = 1;
43 perl_destruct(my_perl);
44 perl_free(my_perl);
45 #ifdef PERL_SYS_TERM
46 PERL_SYS_TERM();
47 #endif
48 my_perl = NULL;
49 }
50 }
51
52 static char **argv = NULL;
53
54 int
make_embedded_interpreter(char const * progPath,char const * subFilter,int wantStatusReports,char ** env)55 make_embedded_interpreter(char const *progPath,
56 char const *subFilter,
57 int wantStatusReports,
58 char **env)
59 {
60 int argc;
61
62 /* Why do we malloc argv instead of making it static? Because on some
63 systems, Perl makes horrendously evil assumptions about the alignment
64 of argv... we use malloc to get guaranteed worst-case alignment.
65 Yes, the Perl innards are completely horrible. */
66 if (!argv) {
67 argv = (char **) malloc(PERLPARSE_NUM_ARGS * sizeof(char *));
68 if (!argv) {
69 fprintf(stderr, "Out of memory allocating argv[] array for embedded Perl!");
70 syslog(LOG_ERR, "Out of memory allocating argv[] array for embedded Perl!");
71 exit(EXIT_FAILURE);
72 }
73 }
74 memset(argv, 0, PERLPARSE_NUM_ARGS * sizeof(char *));
75
76 if (my_perl != NULL) {
77 #ifdef SAFE_EMBED_PERL
78 PSC(my_perl);
79 PERL_SET_INTERP(my_perl);
80 PL_perl_destruct_level = 1;
81 perl_destruct(my_perl);
82 perl_free(my_perl);
83 my_perl = NULL;
84 #else
85 syslog(LOG_WARNING, "Cannot destroy and recreate a Perl interpreter safely on this platform. Filter rules will NOT be reread.");
86 return 0;
87 #endif
88
89 }
90
91 if (subFilter) {
92 argv[0] = "";
93 argv[1] = (char *) progPath;
94 argv[2] = "-f";
95 argv[3] = (char *) subFilter;
96 if (wantStatusReports) {
97 argv[4] = "-embserveru";
98 } else {
99 argv[4] = "-embserver";
100 }
101 argv[5] = NULL;
102 argc = 5;
103 } else {
104 argv[0] = "";
105 argv[1] = (char *) progPath;
106 if (wantStatusReports) {
107 argv[2] = "-embserveru";
108 } else {
109 argv[2] = "-embserver";
110 }
111 argv[3] = NULL;
112 argc = 3;
113 }
114
115 my_perl = perl_alloc();
116 if (!my_perl) {
117 errno = ENOMEM;
118 return -1;
119 }
120 PSC(my_perl);
121 PERL_SET_INTERP(my_perl);
122 PL_perl_destruct_level = 1;
123 perl_construct(my_perl);
124 perl_parse(my_perl, xs_init, argc, argv, NULL);
125 perl_run(my_perl);
126 return 0;
127 }
128
129 /* Perl caches $$ so the PID is wrong after we fork. This
130 routine fixes it up */
131 static void
embperl_fix_pid(void)132 embperl_fix_pid(void)
133 {
134 GV *tmpgv;
135 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
136 SvREADONLY_off(GvSV(tmpgv));
137 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
138 SvREADONLY_on(GvSV(tmpgv));
139 }
140 }
141
142 void
run_embedded_filter(void)143 run_embedded_filter(void)
144 {
145 char *args[] = { NULL };
146
147 PSC(my_perl);
148 PERL_SET_INTERP(my_perl);
149 embperl_fix_pid();
150
151 perl_call_argv("do_main_loop", G_DISCARD | G_NOARGS, args);
152 }
153
154 #endif
155
156