17 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
18 EXCEPTIONREGISTRATIONRECORD *,
22 static RXSTRING * strs;
24 static SHVBLOCK * vars;
28 static RXSTRING rxcommand = { 9, "RXCOMMAND" };
29 static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
30 static RXSTRING rxfunction = { 11, "RXFUNCTION" };
32 static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret);
36 #define Fetch RXSHV_FETCH
37 #define Drop RXSHV_DROPV
39 #define Set RXSHV_SYSET
40 #define Fetch RXSHV_SYFET
41 #define Drop RXSHV_SYDRO
44 static long incompartment;
47 exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
50 HMODULE hRexx, hRexxAPI;
52 LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
53 PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
54 APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
55 RexxFunctionHandler *);
56 APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
65 Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
68 if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
69 || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
70 || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
71 || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
72 (PFN *)&pRexxRegisterFunctionExe)
73 || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
74 (PFN *)&pRexxDeregisterFunction)) {
75 Perl_die(aTHX_ "REXX not available\n");
79 pRexxRegisterFunctionExe(handlerName, handler);
81 MAKERXSTRING(args[0], NULL, 0);
82 MAKERXSTRING(inst[0], cmd, strlen(cmd));
83 MAKERXSTRING(inst[1], NULL, 0);
84 MAKERXSTRING(result, NULL, 0);
85 rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
89 pRexxDeregisterFunction("StartPerl");
90 DosFreeModule(hRexxAPI);
92 if (!RXNULLSTRING(result)) {
93 res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
94 DosFreeMem(RXSTRPTR(result));
98 if (rc || SvTRUE(GvSV(PL_errgv))) {
99 if (SvTRUE(GvSV(PL_errgv))) {
101 Perl_die(aTHX_ "Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
103 Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
112 PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
114 return PERLCALL(NULL, argc, argv, queue, ret);
117 #define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \
118 "StartPerl", PERLSTART)
119 #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
120 #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
121 exec_in_REXX(aTHX_ cmd,name,PERLSTART))
122 #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
125 PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
128 EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
135 DosSetExceptionHandler(&xreg);
143 DosUnsetExceptionHandler(&xreg);
150 char **arr = alloca((argc + 1) * sizeof(char *));
152 for (i = 0; i < argc; ++i)
153 arr[ac++] = argv[i].strptr;
156 rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr);
157 } else if (exec_cv) {
161 rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
166 if (rc == 1 && SvOK(TOPs)) {
167 str = SvPVx(POPs, len);
169 if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
170 DosUnsetExceptionHandler(&xreg);
173 memcpy(ret->strptr, str, len);
174 ret->strlength = len;
182 DosUnsetExceptionHandler(&xreg);
187 DosUnsetExceptionHandler(&xreg);
198 strs = malloc(nstrs * sizeof(RXSTRING));
209 vars = malloc(nvars * sizeof(SHVBLOCK));
218 trace = getenv("PERL_REXX_DEBUG");
222 constant(char *name, int arg)
229 MODULE = OS2::REXX PACKAGE = OS2::REXX
246 int n = (items + 1) / 2;
250 fprintf(stderr, "REXXCALL::_set");
251 for (i = 0; i < n; ++i) {
252 SHVBLOCK * var = &vars[i];
255 name = SvPV(ST(2*i+0),namelen);
257 value = SvPV(ST(2*i+1),valuelen);
263 var->shvcode = RXSHV_SET;
264 var->shvnext = &vars[i+1];
265 var->shvnamelen = namelen;
266 var->shvvaluelen = valuelen;
267 MAKERXSTRING(var->shvname, name, namelen);
268 MAKERXSTRING(var->shvvalue, value, valuelen);
270 fprintf(stderr, " %.*s='%.*s'",
271 var->shvname.strlength, var->shvname.strptr,
272 var->shvvalue.strlength, var->shvvalue.strptr);
275 fprintf(stderr, "\n");
276 vars[n-1].shvnext = NULL;
277 rc = RexxVariablePool(vars);
279 fprintf(stderr, " rc=%X\n", rc);
280 RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
295 fprintf(stderr, "REXXCALL::_fetch");
296 for (i = 0; i < items; ++i) {
297 SHVBLOCK * var = &vars[i];
299 name = SvPV(ST(i),namelen);
300 var->shvcode = RXSHV_FETCH;
301 var->shvnext = &vars[i+1];
302 var->shvnamelen = namelen;
303 var->shvvaluelen = 0;
304 MAKERXSTRING(var->shvname, name, namelen);
305 MAKERXSTRING(var->shvvalue, NULL, 0);
307 fprintf(stderr, " '%s'", name);
310 fprintf(stderr, "\n");
311 vars[items-1].shvnext = NULL;
312 rc = RexxVariablePool(vars);
313 if (!(rc & ~RXSHV_NEWV)) {
314 for (i = 0; i < items; ++i) {
316 SHVBLOCK * var = &vars[i];
317 /* returned lengths appear to be swapped */
318 /* but beware of "future bug fixes" */
319 namelen = var->shvvalue.strlength; /* should be */
320 if (var->shvvaluelen < var->shvvalue.strlength)
321 namelen = var->shvvaluelen; /* is */
323 fprintf(stderr, " %.*s='%.*s'\n",
324 var->shvname.strlength, var->shvname.strptr,
325 namelen, var->shvvalue.strptr);
326 if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
329 PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
334 fprintf(stderr, " rc=%X\n", rc);
346 int len = strlen(stem), namelen, valuelen;
348 fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
349 sv.shvcode = RXSHV_NEXTV;
351 MAKERXSTRING(sv.shvvalue, NULL, 0);
353 sv.shvnamelen = sizeof name;
355 MAKERXSTRING(sv.shvname, name, sizeof name);
356 if (sv.shvvalue.strptr) {
357 DosFreeMem(sv.shvvalue.strptr);
358 MAKERXSTRING(sv.shvvalue, NULL, 0);
360 rc = RexxVariablePool(&sv);
361 } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
364 /* returned lengths appear to be swapped */
365 /* but beware of "future bug fixes" */
366 namelen = sv.shvname.strlength; /* should be */
367 if (sv.shvnamelen < sv.shvname.strlength)
368 namelen = sv.shvnamelen; /* is */
369 valuelen = sv.shvvalue.strlength; /* should be */
370 if (sv.shvvaluelen < sv.shvvalue.strlength)
371 valuelen = sv.shvvaluelen; /* is */
373 fprintf(stderr, " %.*s='%.*s'\n",
374 namelen, sv.shvname.strptr,
375 valuelen, sv.shvvalue.strptr);
376 PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
377 if (sv.shvvalue.strptr) {
378 PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
379 DosFreeMem(sv.shvvalue.strptr);
382 } else if (rc != RXSHV_LVAR) {
383 die("Error %i when in _next", rc);
386 fprintf(stderr, " rc=%X\n", rc);
397 for (i = 0; i < items; ++i) {
398 SHVBLOCK * var = &vars[i];
400 name = SvPV(ST(i),namelen);
401 var->shvcode = RXSHV_DROPV;
402 var->shvnext = &vars[i+1];
403 var->shvnamelen = namelen;
404 var->shvvaluelen = 0;
405 MAKERXSTRING(var->shvname, name, var->shvnamelen);
406 MAKERXSTRING(var->shvvalue, NULL, 0);
408 vars[items-1].shvnext = NULL;
409 RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
418 RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
432 REXX_eval_with(cmd,name,cv)