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 | { | |
764df951 IZ |
64 | char *argv[3] = {"perl_in_REXX", "-e", ""}; |
65 | ||
66 | if (!perlos2_is_inited) { | |
67 | perlos2_is_inited = 1; | |
68 | init_perlos2(); | |
69 | } | |
70 | if (my_perl) | |
71 | return 1; | |
72 | if (!PL_do_undump) { | |
73 | my_perl = perl_alloc(); | |
74 | if (!my_perl) | |
75 | return 0; | |
76 | perl_construct(my_perl); | |
77 | PL_perl_destruct_level = 1; | |
78 | } | |
79 | if (!doparse) | |
80 | return 1; | |
fe2024f9 | 81 | return !perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); |
764df951 IZ |
82 | } |
83 | ||
9e2a34c1 IZ |
84 | static char last_error[4096]; |
85 | ||
86 | static int | |
87 | seterr(char *format, ...) | |
88 | { | |
89 | va_list va; | |
90 | char *s = last_error; | |
91 | ||
92 | va_start(va, format); | |
93 | if (s[0]) { | |
94 | s += strlen(s); | |
95 | if (s[-1] != '\n') { | |
96 | snprintf(s, sizeof(last_error) - (s - last_error), "\n"); | |
97 | s += strlen(s); | |
98 | } | |
99 | } | |
100 | vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); | |
101 | return 1; | |
102 | } | |
103 | ||
764df951 IZ |
104 | /* The REXX-callable entrypoints ... */ |
105 | ||
106 | ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
107 | PCSZ queuename, PRXSTRING retstr) | |
108 | { | |
109 | int exitstatus; | |
110 | char buf[256]; | |
111 | char *argv[3] = {"perl_from_REXX", "-e", buf}; | |
112 | ULONG ret; | |
113 | ||
9e2a34c1 IZ |
114 | if (rargc != 1) |
115 | return seterr("one argument expected, got %ld", rargc); | |
116 | if (rargv[0].strlength >= sizeof(buf)) | |
117 | return seterr("length of the argument %ld exceeds the maximum %ld", | |
118 | rargv[0].strlength, (long)sizeof(buf) - 1); | |
764df951 IZ |
119 | |
120 | if (!init_perl(0)) | |
121 | return 1; | |
122 | ||
123 | memcpy(buf, rargv[0].strptr, rargv[0].strlength); | |
124 | buf[rargv[0].strlength] = 0; | |
125 | ||
fe2024f9 Z |
126 | if (!perl_parse(my_perl, xs_init, 3, argv, (char **)NULL)) |
127 | perl_run(my_perl); | |
764df951 | 128 | |
fe2024f9 | 129 | exitstatus = perl_destruct(my_perl); |
764df951 IZ |
130 | perl_free(my_perl); |
131 | my_perl = 0; | |
132 | ||
133 | if (exitstatus) | |
134 | ret = 1; | |
135 | else { | |
136 | ret = 0; | |
137 | sprintf(retstr->strptr, "%s", "ok"); | |
138 | retstr->strlength = strlen (retstr->strptr); | |
139 | } | |
140 | PERL_SYS_TERM1(0); | |
141 | return ret; | |
142 | } | |
143 | ||
144 | ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
145 | PCSZ queuename, PRXSTRING retstr) | |
146 | { | |
9e2a34c1 IZ |
147 | if (rargc != 0) |
148 | return seterr("no arguments expected, got %ld", rargc); | |
764df951 IZ |
149 | PERL_SYS_TERM1(0); |
150 | return 0; | |
151 | } | |
152 | ||
153 | ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
154 | PCSZ queuename, PRXSTRING retstr) | |
155 | { | |
9e2a34c1 IZ |
156 | if (rargc != 0) |
157 | return seterr("no arguments expected, got %ld", rargc); | |
158 | if (!my_perl) | |
159 | return seterr("no perl interpreter present"); | |
764df951 IZ |
160 | perl_destruct(my_perl); |
161 | perl_free(my_perl); | |
162 | my_perl = 0; | |
163 | ||
164 | sprintf(retstr->strptr, "%s", "ok"); | |
165 | retstr->strlength = strlen (retstr->strptr); | |
166 | return 0; | |
167 | } | |
168 | ||
169 | ||
170 | ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, | |
171 | PCSZ queuename, PRXSTRING retstr) | |
172 | { | |
9e2a34c1 IZ |
173 | if (rargc != 0) |
174 | return seterr("no argument expected, got %ld", rargc); | |
764df951 IZ |
175 | if (!init_perl(1)) |
176 | return 1; | |
177 | ||
178 | sprintf(retstr->strptr, "%s", "ok"); | |
179 | retstr->strlength = strlen (retstr->strptr); | |
180 | return 0; | |
181 | } | |
182 | ||
9e2a34c1 IZ |
183 | ULONG |
184 | PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
185 | { | |
186 | int len = strlen(last_error); | |
187 | ||
188 | if (len <= 256 /* Default buffer is 256-char long */ | |
189 | || !DosAllocMem((PPVOID)&retstr->strptr, len, | |
190 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { | |
191 | memcpy(retstr->strptr, last_error, len); | |
192 | retstr->strlength = len; | |
193 | } else { | |
194 | strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); | |
195 | retstr->strlength = strlen(retstr->strptr); | |
196 | } | |
197 | return 0; | |
198 | } | |
199 | ||
200 | ULONG | |
201 | PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
764df951 IZ |
202 | { |
203 | SV *res, *in; | |
9e2a34c1 | 204 | STRLEN len, n_a; |
764df951 IZ |
205 | char *str; |
206 | ||
9e2a34c1 IZ |
207 | last_error[0] = 0; |
208 | if (rargc != 1) | |
209 | return seterr("one argument expected, got %ld", rargc); | |
764df951 IZ |
210 | |
211 | if (!init_perl(1)) | |
9e2a34c1 | 212 | return seterr("error initializing perl"); |
764df951 IZ |
213 | |
214 | { | |
215 | dSP; | |
216 | int ret; | |
217 | ||
218 | ENTER; | |
219 | SAVETMPS; | |
220 | ||
221 | PUSHMARK(SP); | |
222 | in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); | |
223 | eval_sv(in, G_SCALAR); | |
224 | SPAGAIN; | |
225 | res = POPs; | |
226 | PUTBACK; | |
227 | ||
228 | ret = 0; | |
9e2a34c1 IZ |
229 | if (SvTRUE(ERRSV)) |
230 | ret = seterr(SvPV(ERRSV, n_a)); | |
231 | if (!SvOK(res)) | |
232 | ret = seterr("undefined value returned by Perl-in-REXX"); | |
764df951 IZ |
233 | str = SvPV(res, len); |
234 | if (len <= 256 /* Default buffer is 256-char long */ | |
235 | || !DosAllocMem((PPVOID)&retstr->strptr, len, | |
236 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { | |
237 | memcpy(retstr->strptr, str, len); | |
238 | retstr->strlength = len; | |
239 | } else | |
9e2a34c1 | 240 | ret = seterr("Not enough memory for the return string of Perl-in-REXX"); |
764df951 IZ |
241 | |
242 | FREETMPS; | |
243 | LEAVE; | |
244 | ||
245 | return ret; | |
246 | } | |
247 | } | |
9e2a34c1 IZ |
248 | |
249 | ULONG | |
250 | PERLEVALSUBCOMMAND( | |
251 | const RXSTRING *command, /* command to issue */ | |
252 | PUSHORT flags, /* error/failure flags */ | |
253 | PRXSTRING retstr ) /* return code */ | |
254 | { | |
255 | ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr); | |
256 | ||
257 | if (rc) | |
258 | *flags = RXSUBCOM_ERROR; /* raise error condition */ | |
259 | ||
260 | return 0; /* finished */ | |
261 | } | |
262 | ||
263 | #define ArrLength(a) (sizeof(a)/sizeof(*(a))) | |
264 | ||
265 | static const struct { | |
266 | char *name; | |
267 | RexxFunctionHandler *f; | |
268 | } funcs[] = { | |
269 | {"PERL", (RexxFunctionHandler *)&PERL}, | |
270 | {"PERLTERM", (RexxFunctionHandler *)&PERLTERM}, | |
271 | {"PERLINIT", (RexxFunctionHandler *)&PERLINIT}, | |
272 | {"PERLEXIT", (RexxFunctionHandler *)&PERLEXIT}, | |
273 | {"PERLEVAL", (RexxFunctionHandler *)&PERLEVAL}, | |
274 | {"PERLLASTERROR", (RexxFunctionHandler *)&PERLLASTERROR}, | |
275 | {"PERLDROPALL", (RexxFunctionHandler *)&PERLDROPALL}, | |
276 | {"PERLDROPALLEXIT", (RexxFunctionHandler *)&PERLDROPALLEXIT}, | |
277 | /* Should be the last entry */ | |
278 | {"PERLEXPORTALL", (RexxFunctionHandler *)&PERLEXPORTALL} | |
279 | }; | |
280 | ||
281 | ULONG | |
282 | PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
283 | { | |
284 | int i = -1; | |
285 | ||
286 | while (++i < ArrLength(funcs) - 1) | |
287 | RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); | |
288 | RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL); | |
289 | retstr->strlength = 0; | |
290 | return 0; | |
291 | } | |
292 | ||
293 | ULONG | |
294 | PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
295 | { | |
296 | int i = -1; | |
297 | ||
298 | while (++i < ArrLength(funcs)) | |
299 | RexxDeregisterFunction(funcs[i].name); | |
300 | RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); | |
301 | retstr->strlength = 0; | |
302 | return 0; | |
303 | } | |
304 | ||
305 | ULONG | |
306 | PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) | |
307 | { | |
308 | int i = -1; | |
309 | ||
310 | while (++i < ArrLength(funcs)) | |
311 | RexxDeregisterFunction(funcs[i].name); | |
312 | RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); | |
313 | PERL_SYS_TERM1(0); | |
314 | retstr->strlength = 0; | |
315 | return 0; | |
316 | } |