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