Commit | Line | Data |
764df951 |
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 | /* |
11 | * "The Road goes ever on and on, down from the door where it began." |
12 | */ |
13 | |
14 | #ifdef OEMVS |
15 | #ifdef MYMALLOC |
16 | /* sbrk is limited to first heap segement so make it big */ |
17 | #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) |
18 | #else |
19 | #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) |
20 | #endif |
21 | #endif |
22 | |
23 | |
24 | #include "EXTERN.h" |
25 | #include "perl.h" |
26 | |
27 | static void xs_init (pTHX); |
28 | static PerlInterpreter *my_perl; |
29 | |
30 | #if defined (__MINT__) || defined (atarist) |
31 | /* The Atari operating system doesn't have a dynamic stack. The |
32 | stack size is determined from this value. */ |
33 | long _stksize = 64 * 1024; |
34 | #endif |
35 | |
36 | /* Register any extra external extensions */ |
37 | |
38 | /* Do not delete this line--writemain depends on it */ |
39 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); |
40 | |
41 | static void |
42 | xs_init(pTHX) |
43 | { |
44 | char *file = __FILE__; |
45 | dXSUB_SYS; |
46 | newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); |
47 | } |
48 | |
49 | int perlos2_is_inited; |
50 | |
51 | static void |
52 | init_perlos2(void) |
53 | { |
54 | /* static char *env[1] = {NULL}; */ |
55 | |
56 | Perl_OS2_init3(0, 0, 0); |
57 | } |
58 | |
59 | static int |
60 | init_perl(int doparse) |
61 | { |
62 | int exitstatus; |
63 | char *argv[3] = {"perl_in_REXX", "-e", ""}; |
64 | |
65 | if (!perlos2_is_inited) { |
66 | perlos2_is_inited = 1; |
67 | init_perlos2(); |
68 | } |
69 | if (my_perl) |
70 | return 1; |
71 | if (!PL_do_undump) { |
72 | my_perl = perl_alloc(); |
73 | if (!my_perl) |
74 | return 0; |
75 | perl_construct(my_perl); |
76 | PL_perl_destruct_level = 1; |
77 | } |
78 | if (!doparse) |
79 | return 1; |
80 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); |
81 | return !exitstatus; |
82 | } |
83 | |
84 | /* The REXX-callable entrypoints ... */ |
85 | |
86 | ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, |
87 | PCSZ queuename, PRXSTRING retstr) |
88 | { |
89 | int exitstatus; |
90 | char buf[256]; |
91 | char *argv[3] = {"perl_from_REXX", "-e", buf}; |
92 | ULONG ret; |
93 | |
94 | if (rargc != 1) { |
95 | sprintf(retstr->strptr, "one argument expected, got %ld", rargc); |
96 | retstr->strlength = strlen (retstr->strptr); |
97 | return 1; |
98 | } |
99 | if (rargv[0].strlength >= sizeof(buf)) { |
100 | sprintf(retstr->strptr, |
101 | "length of the argument %ld exceeds the maximum %ld", |
102 | rargv[0].strlength, (long)sizeof(buf) - 1); |
103 | retstr->strlength = strlen (retstr->strptr); |
104 | return 1; |
105 | } |
106 | |
107 | if (!init_perl(0)) |
108 | return 1; |
109 | |
110 | memcpy(buf, rargv[0].strptr, rargv[0].strlength); |
111 | buf[rargv[0].strlength] = 0; |
112 | |
113 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); |
114 | if (!exitstatus) { |
115 | exitstatus = perl_run(my_perl); |
116 | } |
117 | |
118 | perl_destruct(my_perl); |
119 | perl_free(my_perl); |
120 | my_perl = 0; |
121 | |
122 | if (exitstatus) |
123 | ret = 1; |
124 | else { |
125 | ret = 0; |
126 | sprintf(retstr->strptr, "%s", "ok"); |
127 | retstr->strlength = strlen (retstr->strptr); |
128 | } |
129 | PERL_SYS_TERM1(0); |
130 | return ret; |
131 | } |
132 | |
133 | ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, |
134 | PCSZ queuename, PRXSTRING retstr) |
135 | { |
136 | if (rargc != 0) { |
137 | sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); |
138 | retstr->strlength = strlen (retstr->strptr); |
139 | return 1; |
140 | } |
141 | PERL_SYS_TERM1(0); |
142 | return 0; |
143 | } |
144 | |
145 | ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, |
146 | PCSZ queuename, PRXSTRING retstr) |
147 | { |
148 | if (rargc != 0) { |
149 | sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); |
150 | retstr->strlength = strlen (retstr->strptr); |
151 | return 1; |
152 | } |
153 | if (!my_perl) { |
154 | sprintf(retstr->strptr, "no perl interpreter present"); |
155 | retstr->strlength = strlen (retstr->strptr); |
156 | return 1; |
157 | } |
158 | perl_destruct(my_perl); |
159 | perl_free(my_perl); |
160 | my_perl = 0; |
161 | |
162 | sprintf(retstr->strptr, "%s", "ok"); |
163 | retstr->strlength = strlen (retstr->strptr); |
164 | return 0; |
165 | } |
166 | |
167 | |
168 | ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, |
169 | PCSZ queuename, PRXSTRING retstr) |
170 | { |
171 | if (rargc != 0) { |
172 | sprintf(retstr->strptr, "no argument expected, got %ld", rargc); |
173 | retstr->strlength = strlen (retstr->strptr); |
174 | return 1; |
175 | } |
176 | if (!init_perl(1)) |
177 | return 1; |
178 | |
179 | sprintf(retstr->strptr, "%s", "ok"); |
180 | retstr->strlength = strlen (retstr->strptr); |
181 | return 0; |
182 | } |
183 | |
184 | ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, |
185 | PCSZ queuename, PRXSTRING retstr) |
186 | { |
187 | SV *res, *in; |
188 | STRLEN len; |
189 | char *str; |
190 | |
191 | if (rargc != 1) { |
192 | sprintf(retstr->strptr, "one argument expected, got %ld", rargc); |
193 | retstr->strlength = strlen (retstr->strptr); |
194 | return 1; |
195 | } |
196 | |
197 | if (!init_perl(1)) |
198 | return 1; |
199 | |
200 | { |
201 | dSP; |
202 | int ret; |
203 | |
204 | ENTER; |
205 | SAVETMPS; |
206 | |
207 | PUSHMARK(SP); |
208 | in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); |
209 | eval_sv(in, G_SCALAR); |
210 | SPAGAIN; |
211 | res = POPs; |
212 | PUTBACK; |
213 | |
214 | ret = 0; |
215 | if (SvTRUE(ERRSV) || !SvOK(res)) |
216 | ret = 1; |
217 | str = SvPV(res, len); |
218 | if (len <= 256 /* Default buffer is 256-char long */ |
219 | || !DosAllocMem((PPVOID)&retstr->strptr, len, |
220 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { |
221 | memcpy(retstr->strptr, str, len); |
222 | retstr->strlength = len; |
223 | } else |
224 | ret = 1; |
225 | |
226 | FREETMPS; |
227 | LEAVE; |
228 | |
229 | return ret; |
230 | } |
231 | } |
232 | #define INCL_DOSPROCESS |
233 | #define INCL_DOSSEMAPHORES |
234 | #define INCL_DOSMODULEMGR |
235 | #define INCL_DOSMISC |
236 | #define INCL_DOSEXCEPTIONS |
237 | #define INCL_DOSERRORS |
238 | #define INCL_REXXSAA |
2b6ff23b |
239 | #include <os2.h> |
764df951 |
240 | |
241 | /* |
242 | * "The Road goes ever on and on, down from the door where it began." |
243 | */ |
244 | |
245 | #ifdef OEMVS |
246 | #ifdef MYMALLOC |
247 | /* sbrk is limited to first heap segement so make it big */ |
248 | #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) |
249 | #else |
250 | #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) |
251 | #endif |
252 | #endif |
253 | |
254 | |
255 | #include "EXTERN.h" |
256 | #include "perl.h" |
257 | |
258 | static void xs_init (pTHX); |
259 | static PerlInterpreter *my_perl; |
260 | |
261 | #if defined (__MINT__) || defined (atarist) |
262 | /* The Atari operating system doesn't have a dynamic stack. The |
263 | stack size is determined from this value. */ |
264 | long _stksize = 64 * 1024; |
265 | #endif |
266 | |
267 | /* Register any extra external extensions */ |
268 | |
269 | /* Do not delete this line--writemain depends on it */ |
270 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); |
271 | |
272 | static void |
273 | xs_init(pTHX) |
274 | { |
275 | char *file = __FILE__; |
276 | dXSUB_SYS; |
277 | newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); |
278 | } |
279 | |
280 | int perlos2_is_inited; |
281 | |
282 | static void |
283 | init_perlos2(void) |
284 | { |
285 | /* static char *env[1] = {NULL}; */ |
286 | |
287 | Perl_OS2_init3(0, 0, 0); |
288 | } |
289 | |
290 | static int |
291 | init_perl(int doparse) |
292 | { |
293 | int exitstatus; |
294 | char *argv[3] = {"perl_in_REXX", "-e", ""}; |
295 | |
296 | if (!perlos2_is_inited) { |
297 | perlos2_is_inited = 1; |
298 | init_perlos2(); |
299 | } |
300 | if (my_perl) |
301 | return 1; |
302 | if (!PL_do_undump) { |
303 | my_perl = perl_alloc(); |
304 | if (!my_perl) |
305 | return 0; |
306 | perl_construct(my_perl); |
307 | PL_perl_destruct_level = 1; |
308 | } |
309 | if (!doparse) |
310 | return 1; |
311 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); |
312 | return !exitstatus; |
313 | } |
314 | |
315 | /* The REXX-callable entrypoints ... */ |
316 | |
317 | ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, |
318 | PCSZ queuename, PRXSTRING retstr) |
319 | { |
320 | int exitstatus; |
321 | char buf[256]; |
322 | char *argv[3] = {"perl_from_REXX", "-e", buf}; |
323 | ULONG ret; |
324 | |
325 | if (rargc != 1) { |
2b6ff23b |
326 | sprintf(retstr->strptr, "one argument expected, got %ld", rargc); |
327 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
328 | return 1; |
329 | } |
2b6ff23b |
330 | if (rargv[0].strlength >= sizeof(buf)) { |
331 | sprintf(retstr->strptr, |
764df951 |
332 | "length of the argument %ld exceeds the maximum %ld", |
333 | rargv[0].strlength, (long)sizeof(buf) - 1); |
2b6ff23b |
334 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
335 | return 1; |
336 | } |
337 | |
338 | if (!init_perl(0)) |
339 | return 1; |
340 | |
341 | memcpy(buf, rargv[0].strptr, rargv[0].strlength); |
342 | buf[rargv[0].strlength] = 0; |
343 | |
344 | exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); |
345 | if (!exitstatus) { |
346 | exitstatus = perl_run(my_perl); |
347 | } |
348 | |
349 | perl_destruct(my_perl); |
350 | perl_free(my_perl); |
351 | my_perl = 0; |
352 | |
353 | if (exitstatus) |
354 | ret = 1; |
355 | else { |
356 | ret = 0; |
2b6ff23b |
357 | sprintf(retstr->strptr, "%s", "ok"); |
358 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
359 | } |
360 | PERL_SYS_TERM1(0); |
361 | return ret; |
362 | } |
363 | |
364 | ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, |
365 | PCSZ queuename, PRXSTRING retstr) |
366 | { |
367 | if (rargc != 0) { |
2b6ff23b |
368 | sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); |
369 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
370 | return 1; |
371 | } |
372 | PERL_SYS_TERM1(0); |
373 | return 0; |
374 | } |
375 | |
376 | ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, |
377 | PCSZ queuename, PRXSTRING retstr) |
378 | { |
379 | if (rargc != 0) { |
2b6ff23b |
380 | sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); |
381 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
382 | return 1; |
383 | } |
384 | if (!my_perl) { |
2b6ff23b |
385 | sprintf(retstr->strptr, "no perl interpreter present"); |
386 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
387 | return 1; |
388 | } |
389 | perl_destruct(my_perl); |
390 | perl_free(my_perl); |
391 | my_perl = 0; |
392 | |
2b6ff23b |
393 | sprintf(retstr->strptr, "%s", "ok"); |
394 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
395 | return 0; |
396 | } |
397 | |
398 | |
399 | ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, |
400 | PCSZ queuename, PRXSTRING retstr) |
401 | { |
402 | if (rargc != 0) { |
2b6ff23b |
403 | sprintf(retstr->strptr, "no argument expected, got %ld", rargc); |
404 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
405 | return 1; |
406 | } |
407 | if (!init_perl(1)) |
408 | return 1; |
409 | |
2b6ff23b |
410 | sprintf(retstr->strptr, "%s", "ok"); |
411 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
412 | return 0; |
413 | } |
414 | |
415 | ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, |
416 | PCSZ queuename, PRXSTRING retstr) |
417 | { |
418 | SV *res, *in; |
419 | STRLEN len; |
420 | char *str; |
421 | |
422 | if (rargc != 1) { |
2b6ff23b |
423 | sprintf(retstr->strptr, "one argument expected, got %ld", rargc); |
424 | retstr->strlength = strlen (retstr->strptr); |
764df951 |
425 | return 1; |
426 | } |
427 | |
428 | if (!init_perl(1)) |
429 | return 1; |
430 | |
431 | { |
432 | dSP; |
433 | int ret; |
434 | |
435 | ENTER; |
436 | SAVETMPS; |
437 | |
438 | PUSHMARK(SP); |
439 | in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); |
440 | eval_sv(in, G_SCALAR); |
441 | SPAGAIN; |
442 | res = POPs; |
443 | PUTBACK; |
444 | |
445 | ret = 0; |
446 | if (SvTRUE(ERRSV) || !SvOK(res)) |
447 | ret = 1; |
448 | str = SvPV(res, len); |
2b6ff23b |
449 | if (len <= 256 /* Default buffer is 256-char long */ |
450 | || !DosAllocMem((PPVOID)&retstr->strptr, len, |
764df951 |
451 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { |
2b6ff23b |
452 | memcpy(retstr->strptr, str, len); |
453 | retstr->strlength = len; |
764df951 |
454 | } else |
455 | ret = 1; |
456 | |
457 | FREETMPS; |
458 | LEAVE; |
459 | |
460 | return ret; |
461 | } |
462 | } |