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(char *cmd, char * handlerName, RexxFunctionHandler *handler)
49 HMODULE hRexx, hRexxAPI;
51 LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
52 PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
53 APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
54 RexxFunctionHandler *);
55 APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
63 if (incompartment) die ("Attempt to reenter into REXX compartment");
66 if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
67 || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
68 || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
69 || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
70 (PFN *)&pRexxRegisterFunctionExe)
71 || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
72 (PFN *)&pRexxDeregisterFunction)) {
73 die("REXX not available\n");
77 pRexxRegisterFunctionExe(handlerName, handler);
79 MAKERXSTRING(args[0], NULL, 0);
80 MAKERXSTRING(inst[0], cmd, strlen(cmd));
81 MAKERXSTRING(inst[1], NULL, 0);
82 MAKERXSTRING(result, NULL, 0);
83 rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
87 pRexxDeregisterFunction("StartPerl");
88 DosFreeModule(hRexxAPI);
90 if (!RXNULLSTRING(result)) {
91 res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
92 DosFreeMem(RXSTRPTR(result));
96 if (rc || SvTRUE(GvSV(errgv))) {
97 if (SvTRUE(GvSV(errgv))) {
98 die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ;
100 die ("REXX compartment returned non-zero status %li", rc);
109 PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
111 return PERLCALL(NULL, argc, argv, queue, ret);
114 #define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \
115 "StartPerl", PERLSTART)
116 #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
117 #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
118 exec_in_REXX(cmd,name,PERLSTART))
119 #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
122 PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
124 EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
131 DosSetExceptionHandler(&xreg);
139 DosUnsetExceptionHandler(&xreg);
146 char **arr = alloca((argc + 1) * sizeof(char *));
148 for (i = 0; i < argc; ++i)
149 arr[ac++] = argv[i].strptr;
152 rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr);
153 } else if (exec_cv) {
157 rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
162 if (rc == 1 && SvOK(TOPs)) {
163 str = SvPVx(POPs, len);
165 if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
166 DosUnsetExceptionHandler(&xreg);
169 memcpy(ret->strptr, str, len);
170 ret->strlength = len;
178 DosUnsetExceptionHandler(&xreg);
183 DosUnsetExceptionHandler(&xreg);
194 strs = malloc(nstrs * sizeof(RXSTRING));
205 vars = malloc(nvars * sizeof(SHVBLOCK));
214 trace = getenv("PERL_REXX_DEBUG");
221 croak("%s not implemented on this architecture", s);
235 MODULE = OS2::REXX PACKAGE = OS2::REXX
246 _call(name, address, queue="SESSION", ...)
256 RexxFunctionHandler *fcn = address;
260 fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
261 for (i = 0; i < argc; ++i) {
263 char *ptr = SvPV(ST(3+i), len);
264 MAKERXSTRING(strs[i], ptr, len);
266 fprintf(stderr, " '%.*s'", len, ptr);
271 fprintf(stderr, "\n");
272 MAKERXSTRING(result, resbuf, sizeof resbuf);
273 rc = fcn(name, argc, strs, queue, &result);
275 fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
276 result.strlength, result.strptr);
277 ST(0) = sv_newmortal();
280 sv_setpvn(ST(0), result.strptr, result.strlength);
282 sv_setpvn(ST(0), "", 0);
284 if (result.strptr && result.strptr != resbuf)
285 DosFreeMem(result.strptr);
295 int n = (items + 1) / 2;
299 fprintf(stderr, "REXXCALL::_set");
300 for (i = 0; i < n; ++i) {
301 SHVBLOCK * var = &vars[i];
304 name = SvPV(ST(2*i+0),namelen);
306 value = SvPV(ST(2*i+1),valuelen);
312 var->shvcode = RXSHV_SET;
313 var->shvnext = &vars[i+1];
314 var->shvnamelen = namelen;
315 var->shvvaluelen = valuelen;
316 MAKERXSTRING(var->shvname, name, namelen);
317 MAKERXSTRING(var->shvvalue, value, valuelen);
319 fprintf(stderr, " %.*s='%.*s'",
320 var->shvname.strlength, var->shvname.strptr,
321 var->shvvalue.strlength, var->shvvalue.strptr);
324 fprintf(stderr, "\n");
325 vars[n-1].shvnext = NULL;
326 rc = RexxVariablePool(vars);
328 fprintf(stderr, " rc=%X\n", rc);
329 RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
344 fprintf(stderr, "REXXCALL::_fetch");
345 for (i = 0; i < items; ++i) {
346 SHVBLOCK * var = &vars[i];
348 name = SvPV(ST(i),namelen);
349 var->shvcode = RXSHV_FETCH;
350 var->shvnext = &vars[i+1];
351 var->shvnamelen = namelen;
352 var->shvvaluelen = 0;
353 MAKERXSTRING(var->shvname, name, namelen);
354 MAKERXSTRING(var->shvvalue, NULL, 0);
356 fprintf(stderr, " '%s'", name);
359 fprintf(stderr, "\n");
360 vars[items-1].shvnext = NULL;
361 rc = RexxVariablePool(vars);
362 if (!(rc & ~RXSHV_NEWV)) {
363 for (i = 0; i < items; ++i) {
365 SHVBLOCK * var = &vars[i];
366 /* returned lengths appear to be swapped */
367 /* but beware of "future bug fixes" */
368 namelen = var->shvvalue.strlength; /* should be */
369 if (var->shvvaluelen < var->shvvalue.strlength)
370 namelen = var->shvvaluelen; /* is */
372 fprintf(stderr, " %.*s='%.*s'\n",
373 var->shvname.strlength, var->shvname.strptr,
374 namelen, var->shvvalue.strptr);
375 if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
378 PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
383 fprintf(stderr, " rc=%X\n", rc);
395 int len = strlen(stem), namelen, valuelen;
397 fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
398 sv.shvcode = RXSHV_NEXTV;
400 MAKERXSTRING(sv.shvvalue, NULL, 0);
402 sv.shvnamelen = sizeof name;
404 MAKERXSTRING(sv.shvname, name, sizeof name);
405 if (sv.shvvalue.strptr) {
406 DosFreeMem(sv.shvvalue.strptr);
407 MAKERXSTRING(sv.shvvalue, NULL, 0);
409 rc = RexxVariablePool(&sv);
410 } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
413 /* returned lengths appear to be swapped */
414 /* but beware of "future bug fixes" */
415 namelen = sv.shvname.strlength; /* should be */
416 if (sv.shvnamelen < sv.shvname.strlength)
417 namelen = sv.shvnamelen; /* is */
418 valuelen = sv.shvvalue.strlength; /* should be */
419 if (sv.shvvaluelen < sv.shvvalue.strlength)
420 valuelen = sv.shvvaluelen; /* is */
422 fprintf(stderr, " %.*s='%.*s'\n",
423 namelen, sv.shvname.strptr,
424 valuelen, sv.shvvalue.strptr);
425 PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
426 if (sv.shvvalue.strptr) {
427 PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
428 DosFreeMem(sv.shvvalue.strptr);
431 } else if (rc != RXSHV_LVAR) {
432 die("Error %i when in _next", rc);
435 fprintf(stderr, " rc=%X\n", rc);
446 for (i = 0; i < items; ++i) {
447 SHVBLOCK * var = &vars[i];
449 name = SvPV(ST(i),namelen);
450 var->shvcode = RXSHV_DROPV;
451 var->shvnext = &vars[i+1];
452 var->shvnamelen = namelen;
453 var->shvvaluelen = 0;
454 MAKERXSTRING(var->shvname, name, var->shvnamelen);
455 MAKERXSTRING(var->shvvalue, NULL, 0);
457 vars[items-1].shvnext = NULL;
458 RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
467 RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
481 REXX_eval_with(cmd,name,cv)