Commit | Line | Data |
---|---|---|
764df951 IZ |
1 | #define INCL_DOSPROCESS |
2 | #define INCL_DOSSEMAPHORES | |
3 | #define INCL_DOSMODULEMGR | |
4 | #define INCL_DOSMISC | |
5 | #define INCL_DOSEXCEPTIONS | |
6 | #define INCL_DOSERRORS | |
7 | #define INCL_REXXSAA | |
8 | #include <os2.h> | |
9 | ||
10 | /* | |
4ac71550 TC |
11 | * The Road goes ever on and on |
12 | * Down from the door where it began. | |
13 | * | |
14 | * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] | |
15 | * [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"] | |
764df951 IZ |
16 | */ |
17 | ||
18 | #ifdef OEMVS | |
19 | #ifdef MYMALLOC | |
20 | /* sbrk is limited to first heap segement so make it big */ | |
21 | #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) | |
22 | #else | |
23 | #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) | |
24 | #endif | |
25 | #endif | |
26 | ||
27 | ||
28 | #include "EXTERN.h" | |
29 | #include "perl.h" | |
30 | ||
31 | static void xs_init (pTHX); | |
32 | static PerlInterpreter *my_perl; | |
33 | ||
9e2a34c1 IZ |
34 | ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); |
35 | ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); | |
36 | ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); | |
37 | ||
764df951 IZ |
38 | /* Register any extra external extensions */ |
39 | ||
40 | /* Do not delete this line--writemain depends on it */ | |
41 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); | |
42 | ||
43 | static void | |
44 | xs_init(pTHX) | |
45 | { | |
46 | char *file = __FILE__; | |
47 | dXSUB_SYS; | |
48 | newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); | |
49 | } | |
50 | ||
51 | int perlos2_is_inited; | |
52 | ||
53 | static void | |
54 | init_perlos2(void) | |
55 | { | |
56 | /* static char *env[1] = {NULL}; */ | |
57 | ||
58 | Perl_OS2_init3(0, 0, 0); | |
59 | } | |
60 | ||
61 | static int | |
62 | init_perl(int doparse) | |
63 | { | |
64 | int exitstatus; | |
65 | char *argv[3] = {"perl_in_REXX", "-e", ""}; | |
66 | ||
67 | if (!perlos2_is_inited) { | |
68 | perlos2_is_inited = 1; | |
69 | init_perlos2(); | |
70 | } | |
71 | if (my_perl) | |
72 | return 1; | |
73 | if (!PL_do_undump) { | |
74 | my_perl = perl_alloc(); | |
75 | if (!my_perl) | |
76 | return 0; | |
77 | perl_construct(my_perl); | |
78 | PL_perl_destruct_level = 1; | |
79 | } | |
80 | if (!doparse) | |
81 | return 1; | |
82 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); | |
83 | return !exitstatus; | |
84 | } | |
85 | ||
9e2a34c1 IZ |
86 | static char last_error[4096]; |
87 | ||
88 | static int | |
89 | seterr(char *format, ...) | |
90 | { | |
91 | va_list va; | |
92 | char *s = last_error; | |
93 | ||
94 | va_start(va, format); | |
95 | if (s[0]) { | |
96 | s += strlen(s); | |
97 | if (s[-1] != '\n') { | |
98 | snprintf(s, sizeof(last_error) - (s - last_error), "\n"); | |
99 | s += strlen(s); | |
100 | } | |
101 | } | |
102 | vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); | |
103 | return 1; | |
104 | } | |
105 | ||
764df951 IZ |
106 | /* The REXX-callable entrypoints ... */ |
107 | ||
108 | ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
109 | PCSZ queuename, PRXSTRING retstr) | |
110 | { | |
111 | int exitstatus; | |
112 | char buf[256]; | |
113 | char *argv[3] = {"perl_from_REXX", "-e", buf}; | |
114 | ULONG ret; | |
115 | ||
9e2a34c1 IZ |
116 | if (rargc != 1) |
117 | return seterr("one argument expected, got %ld", rargc); | |
118 | if (rargv[0].strlength >= sizeof(buf)) | |
119 | return seterr("length of the argument %ld exceeds the maximum %ld", | |
120 | rargv[0].strlength, (long)sizeof(buf) - 1); | |
764df951 IZ |
121 | |
122 | if (!init_perl(0)) | |
123 | return 1; | |
124 | ||
125 | memcpy(buf, rargv[0].strptr, rargv[0].strlength); | |
126 | buf[rargv[0].strlength] = 0; | |
127 | ||
128 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); | |
129 | if (!exitstatus) { | |
130 | exitstatus = perl_run(my_perl); | |
131 | } | |
132 | ||
133 | perl_destruct(my_perl); | |
134 | perl_free(my_perl); | |
135 | my_perl = 0; | |
136 | ||
137 | if (exitstatus) | |
138 | ret = 1; | |
139 | else { | |
140 | ret = 0; | |
141 | sprintf(retstr->strptr, "%s", "ok"); | |
142 | retstr->strlength = strlen (retstr->strptr); | |
143 | } | |
144 | PERL_SYS_TERM1(0); | |
145 | return ret; | |
146 | } | |
147 | ||
148 | ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
149 | PCSZ queuename, PRXSTRING retstr) | |
150 | { | |
9e2a34c1 IZ |
151 | if (rargc != 0) |
152 | return seterr("no arguments expected, got %ld", rargc); | |
764df951 IZ |
153 | PERL_SYS_TERM1(0); |
154 | return 0; | |
155 | } | |
156 | ||
157 | ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
158 | PCSZ queuename, PRXSTRING retstr) | |
159 | { | |
9e2a34c1 IZ |
160 | if (rargc != 0) |
161 | return seterr("no arguments expected, got %ld", rargc); | |
162 | if (!my_perl) | |
163 | return seterr("no perl interpreter present"); | |
764df951 IZ |
164 | perl_destruct(my_perl); |
165 | perl_free(my_perl); | |
166 | my_perl = 0; | |
167 | ||
168 | sprintf(retstr->strptr, "%s", "ok"); | |
169 | retstr->strlength = strlen (retstr->strptr); | |
170 | return 0; | |
171 | } | |
172 | ||
173 | ||
174 | ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
175 | PCSZ queuename, PRXSTRING retstr) | |
176 | { | |
9e2a34c1 IZ |
177 | if (rargc != 0) |
178 | return seterr("no argument expected, got %ld", rargc); | |
764df951 IZ |
179 | if (!init_perl(1)) |
180 | return 1; | |
181 | ||
182 | sprintf(retstr->strptr, "%s", "ok"); | |
183 | retstr->strlength = strlen (retstr->strptr); | |
184 | return 0; | |
185 | } | |
186 | ||
9e2a34c1 IZ |
187 | ULONG |
188 | PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
189 | { | |
190 | int len = strlen(last_error); | |
191 | ||
192 | if (len <= 256 /* Default buffer is 256-char long */ | |
193 | || !DosAllocMem((PPVOID)&retstr->strptr, len, | |
194 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { | |
195 | memcpy(retstr->strptr, last_error, len); | |
196 | retstr->strlength = len; | |
197 | } else { | |
198 | strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); | |
199 | retstr->strlength = strlen(retstr->strptr); | |
200 | } | |
201 | return 0; | |
202 | } | |
203 | ||
204 | ULONG | |
205 | PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
764df951 IZ |
206 | { |
207 | SV *res, *in; | |
9e2a34c1 | 208 | STRLEN len, n_a; |
764df951 IZ |
209 | char *str; |
210 | ||
9e2a34c1 IZ |
211 | last_error[0] = 0; |
212 | if (rargc != 1) | |
213 | return seterr("one argument expected, got %ld", rargc); | |
764df951 IZ |
214 | |
215 | if (!init_perl(1)) | |
9e2a34c1 | 216 | return seterr("error initializing perl"); |
764df951 IZ |
217 | |
218 | { | |
219 | dSP; | |
220 | int ret; | |
221 | ||
222 | ENTER; | |
223 | SAVETMPS; | |
224 | ||
225 | PUSHMARK(SP); | |
226 | in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); | |
227 | eval_sv(in, G_SCALAR); | |
228 | SPAGAIN; | |
229 | res = POPs; | |
230 | PUTBACK; | |
231 | ||
232 | ret = 0; | |
9e2a34c1 IZ |
233 | if (SvTRUE(ERRSV)) |
234 | ret = seterr(SvPV(ERRSV, n_a)); | |
235 | if (!SvOK(res)) | |
236 | ret = seterr("undefined value returned by Perl-in-REXX"); | |
764df951 IZ |
237 | str = SvPV(res, len); |
238 | if (len <= 256 /* Default buffer is 256-char long */ | |
239 | || !DosAllocMem((PPVOID)&retstr->strptr, len, | |
240 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { | |
241 | memcpy(retstr->strptr, str, len); | |
242 | retstr->strlength = len; | |
243 | } else | |
9e2a34c1 | 244 | ret = seterr("Not enough memory for the return string of Perl-in-REXX"); |
764df951 IZ |
245 | |
246 | FREETMPS; | |
247 | LEAVE; | |
248 | ||
249 | return ret; | |
250 | } | |
251 | } | |
9e2a34c1 IZ |
252 | |
253 | ULONG | |
254 | PERLEVALSUBCOMMAND( | |
255 | const RXSTRING *command, /* command to issue */ | |
256 | PUSHORT flags, /* error/failure flags */ | |
257 | PRXSTRING retstr ) /* return code */ | |
258 | { | |
259 | ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr); | |
260 | ||
261 | if (rc) | |
262 | *flags = RXSUBCOM_ERROR; /* raise error condition */ | |
263 | ||
264 | return 0; /* finished */ | |
265 | } | |
266 | ||
267 | #define ArrLength(a) (sizeof(a)/sizeof(*(a))) | |
268 | ||
269 | static const struct { | |
270 | char *name; | |
271 | RexxFunctionHandler *f; | |
272 | } funcs[] = { | |
273 | {"PERL", (RexxFunctionHandler *)&PERL}, | |
274 | {"PERLTERM", (RexxFunctionHandler *)&PERLTERM}, | |
275 | {"PERLINIT", (RexxFunctionHandler *)&PERLINIT}, | |
276 | {"PERLEXIT", (RexxFunctionHandler *)&PERLEXIT}, | |
277 | {"PERLEVAL", (RexxFunctionHandler *)&PERLEVAL}, | |
278 | {"PERLLASTERROR", (RexxFunctionHandler *)&PERLLASTERROR}, | |
279 | {"PERLDROPALL", (RexxFunctionHandler *)&PERLDROPALL}, | |
280 | {"PERLDROPALLEXIT", (RexxFunctionHandler *)&PERLDROPALLEXIT}, | |
281 | /* Should be the last entry */ | |
282 | {"PERLEXPORTALL", (RexxFunctionHandler *)&PERLEXPORTALL} | |
283 | }; | |
284 | ||
285 | ULONG | |
286 | PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
287 | { | |
288 | int i = -1; | |
289 | ||
290 | while (++i < ArrLength(funcs) - 1) | |
291 | RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); | |
292 | RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL); | |
293 | retstr->strlength = 0; | |
294 | return 0; | |
295 | } | |
296 | ||
297 | ULONG | |
298 | PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
299 | { | |
300 | int i = -1; | |
301 | ||
302 | while (++i < ArrLength(funcs)) | |
303 | RexxDeregisterFunction(funcs[i].name); | |
304 | RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); | |
305 | retstr->strlength = 0; | |
306 | return 0; | |
307 | } | |
308 | ||
309 | ULONG | |
310 | PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
311 | { | |
312 | int i = -1; | |
313 | ||
314 | while (++i < ArrLength(funcs)) | |
315 | RexxDeregisterFunction(funcs[i].name); | |
316 | RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); | |
317 | PERL_SYS_TERM1(0); | |
318 | retstr->strlength = 0; | |
319 | return 0; | |
320 | } |