Commit | Line | Data |
760ac839 |
1 | #include "EXTERN.h" |
2 | #include "perl.h" |
3 | #include "XSUB.h" |
4 | |
5 | #define INCL_BASE |
6 | #define INCL_REXXSAA |
7 | #include <os2emx.h> |
8 | |
9 | #if 0 |
10 | #define INCL_REXXSAA |
11 | #pragma pack(1) |
12 | #define _Packed |
13 | #include <rexxsaa.h> |
14 | #pragma pack() |
15 | #endif |
16 | |
17 | extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, |
18 | EXCEPTIONREGISTRATIONRECORD *, |
19 | CONTEXTRECORD *, |
20 | void *); |
21 | |
22 | static RXSTRING * strs; |
23 | static int nstrs; |
24 | static SHVBLOCK * vars; |
25 | static int nvars; |
26 | static char * trace; |
27 | |
35bc1fdc |
28 | /* |
760ac839 |
29 | static RXSTRING rxcommand = { 9, "RXCOMMAND" }; |
30 | static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; |
31 | static RXSTRING rxfunction = { 11, "RXFUNCTION" }; |
35bc1fdc |
32 | */ |
760ac839 |
33 | |
46e87256 |
34 | static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); |
9e2a34c1 |
35 | static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); |
36 | static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); |
37 | static RexxSubcomHandler SubCommandPerlEval; |
760ac839 |
38 | |
39 | #if 1 |
40 | #define Set RXSHV_SET |
41 | #define Fetch RXSHV_FETCH |
42 | #define Drop RXSHV_DROPV |
43 | #else |
44 | #define Set RXSHV_SYSET |
45 | #define Fetch RXSHV_SYFET |
46 | #define Drop RXSHV_SYDRO |
47 | #endif |
48 | |
9e2a34c1 |
49 | static long incompartment; /* May be used to unload the REXX */ |
760ac839 |
50 | |
35bc1fdc |
51 | static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, |
52 | PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); |
53 | static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, |
54 | RexxFunctionHandler *); |
55 | static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); |
56 | |
57 | static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest); |
58 | |
9e2a34c1 |
59 | static SV* exec_cv; |
60 | |
61 | /* Create a REXX compartment, |
62 | register `n' callbacks `handlers' with the REXX names `handlerNames', |
63 | evaluate the REXX expression `cmd'. |
64 | */ |
760ac839 |
65 | static SV* |
9e2a34c1 |
66 | exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers) |
760ac839 |
67 | { |
760ac839 |
68 | RXSTRING args[1]; |
69 | RXSTRING inst[2]; |
70 | RXSTRING result; |
71 | USHORT retcode; |
72 | LONG rc; |
73 | SV *res; |
9e2a34c1 |
74 | char *subs = 0; |
75 | int n = c; |
760ac839 |
76 | |
9e2a34c1 |
77 | incompartment++; |
760ac839 |
78 | |
9e2a34c1 |
79 | if (c) |
80 | Newz(728, subs, c, char); |
81 | while (n--) { |
82 | rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]); |
83 | if (rc == RXFUNC_DEFINED) |
84 | subs[n] = 1; |
85 | } |
760ac839 |
86 | |
87 | MAKERXSTRING(args[0], NULL, 0); |
88 | MAKERXSTRING(inst[0], cmd, strlen(cmd)); |
89 | MAKERXSTRING(inst[1], NULL, 0); |
90 | MAKERXSTRING(result, NULL, 0); |
9e2a34c1 |
91 | rc = pRexxStart(0, args, /* No arguments */ |
92 | "REXX_in_Perl", /* Returned on REXX' PARSE SOURCE, |
93 | and the "macrospace function name" */ |
94 | inst, /* inst[0] - the code to execute, |
95 | inst[1] will contain tokens. */ |
96 | "Perl", /* Pass string-cmds to this callback */ |
97 | RXSUBROUTINE, /* Many arguments, maybe result */ |
98 | NULL, /* No callbacks/exits to register */ |
760ac839 |
99 | &retcode, &result); |
100 | |
9e2a34c1 |
101 | incompartment--; |
102 | n = c; |
103 | while (n--) |
104 | if (!subs[n]) |
105 | pRexxDeregisterFunction(handlerNames[n]); |
106 | if (c) |
107 | Safefree(subs); |
35bc1fdc |
108 | #if 0 /* Do we want to restore these? */ |
760ac839 |
109 | DosFreeModule(hRexxAPI); |
110 | DosFreeModule(hRexx); |
35bc1fdc |
111 | #endif |
9e2a34c1 |
112 | |
113 | if (RXSTRPTR(inst[1])) /* Free the tokenized version */ |
114 | DosFreeMem(RXSTRPTR(inst[1])); |
760ac839 |
115 | if (!RXNULLSTRING(result)) { |
116 | res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); |
117 | DosFreeMem(RXSTRPTR(result)); |
118 | } else { |
119 | res = NEWSV(729,0); |
120 | } |
6b88bc9c |
121 | if (rc || SvTRUE(GvSV(PL_errgv))) { |
122 | if (SvTRUE(GvSV(PL_errgv))) { |
2d8e6c8d |
123 | STRLEN n_a; |
9e2a34c1 |
124 | Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ; |
760ac839 |
125 | } |
9e2a34c1 |
126 | Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc); |
760ac839 |
127 | } |
128 | |
129 | return res; |
130 | } |
131 | |
9e2a34c1 |
132 | /* Call the Perl function given by name, or if name=0, by cv, |
133 | with the given arguments. Return the stringified result to REXX. */ |
760ac839 |
134 | static ULONG |
9e2a34c1 |
135 | PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) |
760ac839 |
136 | { |
41cd3736 |
137 | dTHX; |
760ac839 |
138 | EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; |
139 | int i, rc; |
140 | unsigned long len; |
141 | char *str; |
5ba48348 |
142 | SV *res; |
760ac839 |
143 | dSP; |
144 | |
145 | DosSetExceptionHandler(&xreg); |
146 | |
147 | ENTER; |
148 | SAVETMPS; |
924508f0 |
149 | PUSHMARK(SP); |
760ac839 |
150 | |
151 | #if 0 |
152 | if (!my_perl) { |
153 | DosUnsetExceptionHandler(&xreg); |
154 | return 1; |
155 | } |
156 | #endif |
157 | |
5ba48348 |
158 | for (i = 0; i < argc; ++i) |
159 | XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength))); |
160 | PUTBACK; |
9e2a34c1 |
161 | if (name) |
5ba48348 |
162 | rc = perl_call_pv(name, G_SCALAR | G_EVAL); |
9e2a34c1 |
163 | else if (cv) |
760ac839 |
164 | rc = perl_call_sv(cv, G_SCALAR | G_EVAL); |
9e2a34c1 |
165 | else |
5ba48348 |
166 | rc = -1; |
760ac839 |
167 | |
168 | SPAGAIN; |
169 | |
5ba48348 |
170 | if (rc == 1) /* must be! */ |
171 | res = POPs; |
172 | if (rc == 1 && SvOK(res)) { |
173 | str = SvPVx(res, len); |
174 | if (len <= 256 /* Default buffer is 256-char long */ |
175 | || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len, |
176 | PAG_READ|PAG_WRITE|PAG_COMMIT))) { |
177 | memcpy(ret->strptr, str, len); |
178 | ret->strlength = len; |
179 | } else |
180 | rc = 0; |
181 | } else |
182 | rc = 0; |
760ac839 |
183 | |
184 | PUTBACK ; |
185 | FREETMPS ; |
186 | LEAVE ; |
187 | |
760ac839 |
188 | DosUnsetExceptionHandler(&xreg); |
5ba48348 |
189 | return rc == 1 ? 0 : 1; /* 0 means SUCCESS */ |
760ac839 |
190 | } |
191 | |
9e2a34c1 |
192 | static ULONG |
193 | PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) |
194 | { |
195 | SV *cv = exec_cv; |
196 | |
197 | exec_cv = NULL; |
198 | return PERLCALLcv(NULL, cv, argc, argv, queue, ret); |
199 | } |
200 | |
201 | static ULONG |
202 | PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) |
203 | { |
204 | return PERLCALLcv(name, Nullsv, argc, argv, queue, ret); |
205 | } |
206 | |
207 | RexxFunctionHandler* PF = &PERLSTART; |
208 | char* PF_name = "StartPerl"; |
209 | |
210 | #define REXX_eval_with(cmd,name,cv) \ |
211 | ( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF)) |
212 | #define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv)) |
213 | #define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL)) |
214 | |
215 | static ULONG |
216 | SubCommandPerlEval( |
217 | PRXSTRING command, /* command to issue */ |
218 | PUSHORT flags, /* error/failure flags */ |
219 | PRXSTRING retstr ) /* return code */ |
220 | { |
221 | dSP; |
222 | STRLEN len; |
223 | int ret; |
224 | char *str = 0; |
225 | SV *in, *res; |
226 | |
227 | ENTER; |
228 | SAVETMPS; |
229 | |
230 | PUSHMARK(SP); |
231 | in = sv_2mortal(newSVpvn(command->strptr, command->strlength)); |
232 | eval_sv(in, G_SCALAR); |
233 | SPAGAIN; |
234 | res = POPs; |
235 | PUTBACK; |
236 | |
237 | ret = 0; |
238 | if (SvTRUE(ERRSV)) { |
239 | *flags = RXSUBCOM_ERROR; /* raise error condition */ |
240 | str = SvPV(ERRSV, len); |
241 | } else if (!SvOK(res)) { |
242 | *flags = RXSUBCOM_ERROR; /* raise error condition */ |
243 | str = "undefined value returned by Perl-in-REXX"; |
244 | len = strlen(str); |
245 | } else |
246 | str = SvPV(res, len); |
247 | if (len <= 256 /* Default buffer is 256-char long */ |
248 | || !DosAllocMem((PPVOID)&retstr->strptr, len, |
249 | PAG_READ|PAG_WRITE|PAG_COMMIT)) { |
250 | memcpy(retstr->strptr, str, len); |
251 | retstr->strlength = len; |
252 | } else { |
253 | *flags = RXSUBCOM_ERROR; /* raise error condition */ |
254 | strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX"); |
255 | retstr->strlength = strlen(retstr->strptr); |
256 | } |
257 | |
258 | FREETMPS; |
259 | LEAVE; |
260 | |
261 | return 0; /* finished */ |
262 | } |
263 | |
760ac839 |
264 | static void |
265 | needstrs(int n) |
266 | { |
267 | if (n > nstrs) { |
268 | if (strs) |
269 | free(strs); |
270 | nstrs = 2 * n; |
271 | strs = malloc(nstrs * sizeof(RXSTRING)); |
272 | } |
273 | } |
274 | |
275 | static void |
276 | needvars(int n) |
277 | { |
278 | if (n > nvars) { |
279 | if (vars) |
280 | free(vars); |
281 | nvars = 2 * n; |
282 | vars = malloc(nvars * sizeof(SHVBLOCK)); |
283 | } |
284 | } |
285 | |
286 | static void |
287 | initialize(void) |
288 | { |
9e2a34c1 |
289 | ULONG rc; |
35bc1fdc |
290 | *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1); |
291 | *(PFN *)&pRexxRegisterFunctionExe |
292 | = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1); |
293 | *(PFN *)&pRexxDeregisterFunction |
294 | = loadByOrdinal(ORD_RexxDeregisterFunction, 1); |
295 | *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1); |
760ac839 |
296 | needstrs(8); |
297 | needvars(8); |
298 | trace = getenv("PERL_REXX_DEBUG"); |
9e2a34c1 |
299 | |
300 | rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); |
760ac839 |
301 | } |
302 | |
303 | static int |
41cd3736 |
304 | constant(char *name, int arg) |
760ac839 |
305 | { |
306 | errno = EINVAL; |
307 | return 0; |
308 | } |
309 | |
310 | |
311 | MODULE = OS2::REXX PACKAGE = OS2::REXX |
312 | |
313 | BOOT: |
314 | initialize(); |
315 | |
316 | int |
317 | constant(name,arg) |
318 | char * name |
319 | int arg |
320 | |
760ac839 |
321 | int |
322 | _set(name,value,...) |
323 | char * name |
324 | char * value |
325 | CODE: |
326 | { |
327 | int i; |
328 | int n = (items + 1) / 2; |
329 | ULONG rc; |
330 | needvars(n); |
331 | if (trace) |
332 | fprintf(stderr, "REXXCALL::_set"); |
333 | for (i = 0; i < n; ++i) { |
334 | SHVBLOCK * var = &vars[i]; |
335 | STRLEN namelen; |
336 | STRLEN valuelen; |
337 | name = SvPV(ST(2*i+0),namelen); |
338 | if (2*i+1 < items) { |
339 | value = SvPV(ST(2*i+1),valuelen); |
340 | } |
341 | else { |
342 | value = ""; |
343 | valuelen = 0; |
344 | } |
345 | var->shvcode = RXSHV_SET; |
346 | var->shvnext = &vars[i+1]; |
347 | var->shvnamelen = namelen; |
348 | var->shvvaluelen = valuelen; |
349 | MAKERXSTRING(var->shvname, name, namelen); |
350 | MAKERXSTRING(var->shvvalue, value, valuelen); |
351 | if (trace) |
352 | fprintf(stderr, " %.*s='%.*s'", |
35bc1fdc |
353 | (int)var->shvname.strlength, var->shvname.strptr, |
354 | (int)var->shvvalue.strlength, var->shvvalue.strptr); |
760ac839 |
355 | } |
356 | if (trace) |
357 | fprintf(stderr, "\n"); |
358 | vars[n-1].shvnext = NULL; |
35bc1fdc |
359 | rc = pRexxVariablePool(vars); |
760ac839 |
360 | if (trace) |
35bc1fdc |
361 | fprintf(stderr, " rc=%#lX\n", rc); |
760ac839 |
362 | RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; |
363 | } |
364 | OUTPUT: |
365 | RETVAL |
366 | |
367 | void |
368 | _fetch(name, ...) |
369 | char * name |
370 | PPCODE: |
371 | { |
372 | int i; |
373 | ULONG rc; |
924508f0 |
374 | EXTEND(SP, items); |
760ac839 |
375 | needvars(items); |
376 | if (trace) |
377 | fprintf(stderr, "REXXCALL::_fetch"); |
378 | for (i = 0; i < items; ++i) { |
379 | SHVBLOCK * var = &vars[i]; |
380 | STRLEN namelen; |
381 | name = SvPV(ST(i),namelen); |
382 | var->shvcode = RXSHV_FETCH; |
383 | var->shvnext = &vars[i+1]; |
384 | var->shvnamelen = namelen; |
385 | var->shvvaluelen = 0; |
386 | MAKERXSTRING(var->shvname, name, namelen); |
387 | MAKERXSTRING(var->shvvalue, NULL, 0); |
388 | if (trace) |
389 | fprintf(stderr, " '%s'", name); |
390 | } |
391 | if (trace) |
392 | fprintf(stderr, "\n"); |
393 | vars[items-1].shvnext = NULL; |
35bc1fdc |
394 | rc = pRexxVariablePool(vars); |
760ac839 |
395 | if (!(rc & ~RXSHV_NEWV)) { |
396 | for (i = 0; i < items; ++i) { |
397 | int namelen; |
398 | SHVBLOCK * var = &vars[i]; |
399 | /* returned lengths appear to be swapped */ |
400 | /* but beware of "future bug fixes" */ |
401 | namelen = var->shvvalue.strlength; /* should be */ |
402 | if (var->shvvaluelen < var->shvvalue.strlength) |
403 | namelen = var->shvvaluelen; /* is */ |
404 | if (trace) |
405 | fprintf(stderr, " %.*s='%.*s'\n", |
35bc1fdc |
406 | (int)var->shvname.strlength, var->shvname.strptr, |
760ac839 |
407 | namelen, var->shvvalue.strptr); |
408 | if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) |
6b88bc9c |
409 | PUSHs(&PL_sv_undef); |
760ac839 |
410 | else |
411 | PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, |
412 | namelen))); |
413 | } |
414 | } else { |
415 | if (trace) |
35bc1fdc |
416 | fprintf(stderr, " rc=%#lX\n", rc); |
760ac839 |
417 | } |
418 | } |
419 | |
420 | void |
421 | _next(stem) |
422 | char * stem |
423 | PPCODE: |
424 | { |
425 | SHVBLOCK sv; |
426 | BYTE name[4096]; |
427 | ULONG rc; |
428 | int len = strlen(stem), namelen, valuelen; |
429 | if (trace) |
430 | fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); |
431 | sv.shvcode = RXSHV_NEXTV; |
432 | sv.shvnext = NULL; |
433 | MAKERXSTRING(sv.shvvalue, NULL, 0); |
434 | do { |
435 | sv.shvnamelen = sizeof name; |
436 | sv.shvvaluelen = 0; |
437 | MAKERXSTRING(sv.shvname, name, sizeof name); |
438 | if (sv.shvvalue.strptr) { |
439 | DosFreeMem(sv.shvvalue.strptr); |
440 | MAKERXSTRING(sv.shvvalue, NULL, 0); |
441 | } |
35bc1fdc |
442 | rc = pRexxVariablePool(&sv); |
760ac839 |
443 | } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); |
444 | if (!rc) { |
924508f0 |
445 | EXTEND(SP, 2); |
760ac839 |
446 | /* returned lengths appear to be swapped */ |
447 | /* but beware of "future bug fixes" */ |
448 | namelen = sv.shvname.strlength; /* should be */ |
449 | if (sv.shvnamelen < sv.shvname.strlength) |
450 | namelen = sv.shvnamelen; /* is */ |
451 | valuelen = sv.shvvalue.strlength; /* should be */ |
452 | if (sv.shvvaluelen < sv.shvvalue.strlength) |
453 | valuelen = sv.shvvaluelen; /* is */ |
454 | if (trace) |
455 | fprintf(stderr, " %.*s='%.*s'\n", |
456 | namelen, sv.shvname.strptr, |
457 | valuelen, sv.shvvalue.strptr); |
458 | PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); |
459 | if (sv.shvvalue.strptr) { |
460 | PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); |
461 | DosFreeMem(sv.shvvalue.strptr); |
462 | } else |
6b88bc9c |
463 | PUSHs(&PL_sv_undef); |
760ac839 |
464 | } else if (rc != RXSHV_LVAR) { |
465 | die("Error %i when in _next", rc); |
466 | } else { |
467 | if (trace) |
35bc1fdc |
468 | fprintf(stderr, " rc=%#lX\n", rc); |
760ac839 |
469 | } |
470 | } |
471 | |
472 | int |
473 | _drop(name,...) |
474 | char * name |
475 | CODE: |
476 | { |
477 | int i; |
478 | needvars(items); |
479 | for (i = 0; i < items; ++i) { |
480 | SHVBLOCK * var = &vars[i]; |
481 | STRLEN namelen; |
482 | name = SvPV(ST(i),namelen); |
483 | var->shvcode = RXSHV_DROPV; |
484 | var->shvnext = &vars[i+1]; |
485 | var->shvnamelen = namelen; |
486 | var->shvvaluelen = 0; |
487 | MAKERXSTRING(var->shvname, name, var->shvnamelen); |
488 | MAKERXSTRING(var->shvvalue, NULL, 0); |
489 | } |
490 | vars[items-1].shvnext = NULL; |
35bc1fdc |
491 | RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; |
760ac839 |
492 | } |
493 | OUTPUT: |
494 | RETVAL |
495 | |
496 | int |
497 | _register(name) |
498 | char * name |
499 | CODE: |
35bc1fdc |
500 | RETVAL = pRexxRegisterFunctionExe(name, PERLCALL); |
760ac839 |
501 | OUTPUT: |
502 | RETVAL |
503 | |
504 | SV* |
505 | REXX_call(cv) |
506 | SV *cv |
507 | PROTOTYPE: & |
508 | |
509 | SV* |
510 | REXX_eval(cmd) |
511 | char *cmd |
512 | |
513 | SV* |
514 | REXX_eval_with(cmd,name,cv) |
515 | char *cmd |
516 | char *name |
517 | SV *cv |
9e2a34c1 |
518 | |
519 | #ifdef THIS_IS_NOT_FINISHED |
520 | |
521 | SV* |
522 | _REXX_eval_with(cmd,...) |
523 | char *cmd |
524 | CODE: |
525 | { |
526 | int n = (items - 1)/2; |
527 | char **names; |
528 | SV **cvs; |
529 | |
530 | if ((items % 2) == 0) |
531 | Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()"); |
532 | New(730, names, n, char*); |
533 | New(730, cvs, n, SV*); |
534 | /* XXX Unfinished... */ |
535 | RETVAL = Nullsv; |
536 | Safefree(names); |
537 | Safefree(cvs); |
538 | } |
539 | OUTPUT: |
540 | RETVAL |
541 | |
542 | #endif |