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