17 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
18 EXCEPTIONREGISTRATIONRECORD *,
22 static RXSTRING * strs;
24 static SHVBLOCK * vars;
29 static RXSTRING rxcommand = { 9, "RXCOMMAND" };
30 static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
31 static RXSTRING rxfunction = { 11, "RXFUNCTION" };
34 static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
38 #define Fetch RXSHV_FETCH
39 #define Drop RXSHV_DROPV
41 #define Set RXSHV_SYSET
42 #define Fetch RXSHV_SYFET
43 #define Drop RXSHV_SYDRO
46 static long incompartment;
48 static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
49 PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
50 static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
51 RexxFunctionHandler *);
52 static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
54 static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
57 exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
67 Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
71 pRexxRegisterFunctionExe(handlerName, handler);
73 MAKERXSTRING(args[0], NULL, 0);
74 MAKERXSTRING(inst[0], cmd, strlen(cmd));
75 MAKERXSTRING(inst[1], NULL, 0);
76 MAKERXSTRING(result, NULL, 0);
77 rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
81 pRexxDeregisterFunction("StartPerl");
82 #if 0 /* Do we want to restore these? */
83 DosFreeModule(hRexxAPI);
86 if (!RXNULLSTRING(result)) {
87 res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
88 DosFreeMem(RXSTRPTR(result));
92 if (rc || SvTRUE(GvSV(PL_errgv))) {
93 if (SvTRUE(GvSV(PL_errgv))) {
95 Perl_die(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
97 Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
106 PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
108 return PERLCALL(NULL, argc, argv, queue, ret);
111 #define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \
112 "StartPerl", PERLSTART)
113 #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
114 #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
115 exec_in_REXX(aTHX_ cmd,name,PERLSTART))
116 #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
119 PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
122 EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
129 DosSetExceptionHandler(&xreg);
137 DosUnsetExceptionHandler(&xreg);
142 for (i = 0; i < argc; ++i)
143 XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
146 rc = perl_call_pv(name, G_SCALAR | G_EVAL);
147 } else if (exec_cv) {
151 rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
157 if (rc == 1) /* must be! */
159 if (rc == 1 && SvOK(res)) {
160 str = SvPVx(res, len);
161 if (len <= 256 /* Default buffer is 256-char long */
162 || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len,
163 PAG_READ|PAG_WRITE|PAG_COMMIT))) {
164 memcpy(ret->strptr, str, len);
165 ret->strlength = len;
175 DosUnsetExceptionHandler(&xreg);
176 return rc == 1 ? 0 : 1; /* 0 means SUCCESS */
186 strs = malloc(nstrs * sizeof(RXSTRING));
197 vars = malloc(nvars * sizeof(SHVBLOCK));
204 *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
205 *(PFN *)&pRexxRegisterFunctionExe
206 = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
207 *(PFN *)&pRexxDeregisterFunction
208 = loadByOrdinal(ORD_RexxDeregisterFunction, 1);
209 *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
212 trace = getenv("PERL_REXX_DEBUG");
216 constant(char *name, int arg)
223 MODULE = OS2::REXX PACKAGE = OS2::REXX
240 int n = (items + 1) / 2;
244 fprintf(stderr, "REXXCALL::_set");
245 for (i = 0; i < n; ++i) {
246 SHVBLOCK * var = &vars[i];
249 name = SvPV(ST(2*i+0),namelen);
251 value = SvPV(ST(2*i+1),valuelen);
257 var->shvcode = RXSHV_SET;
258 var->shvnext = &vars[i+1];
259 var->shvnamelen = namelen;
260 var->shvvaluelen = valuelen;
261 MAKERXSTRING(var->shvname, name, namelen);
262 MAKERXSTRING(var->shvvalue, value, valuelen);
264 fprintf(stderr, " %.*s='%.*s'",
265 (int)var->shvname.strlength, var->shvname.strptr,
266 (int)var->shvvalue.strlength, var->shvvalue.strptr);
269 fprintf(stderr, "\n");
270 vars[n-1].shvnext = NULL;
271 rc = pRexxVariablePool(vars);
273 fprintf(stderr, " rc=%#lX\n", rc);
274 RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
289 fprintf(stderr, "REXXCALL::_fetch");
290 for (i = 0; i < items; ++i) {
291 SHVBLOCK * var = &vars[i];
293 name = SvPV(ST(i),namelen);
294 var->shvcode = RXSHV_FETCH;
295 var->shvnext = &vars[i+1];
296 var->shvnamelen = namelen;
297 var->shvvaluelen = 0;
298 MAKERXSTRING(var->shvname, name, namelen);
299 MAKERXSTRING(var->shvvalue, NULL, 0);
301 fprintf(stderr, " '%s'", name);
304 fprintf(stderr, "\n");
305 vars[items-1].shvnext = NULL;
306 rc = pRexxVariablePool(vars);
307 if (!(rc & ~RXSHV_NEWV)) {
308 for (i = 0; i < items; ++i) {
310 SHVBLOCK * var = &vars[i];
311 /* returned lengths appear to be swapped */
312 /* but beware of "future bug fixes" */
313 namelen = var->shvvalue.strlength; /* should be */
314 if (var->shvvaluelen < var->shvvalue.strlength)
315 namelen = var->shvvaluelen; /* is */
317 fprintf(stderr, " %.*s='%.*s'\n",
318 (int)var->shvname.strlength, var->shvname.strptr,
319 namelen, var->shvvalue.strptr);
320 if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
323 PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
328 fprintf(stderr, " rc=%#lX\n", rc);
340 int len = strlen(stem), namelen, valuelen;
342 fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
343 sv.shvcode = RXSHV_NEXTV;
345 MAKERXSTRING(sv.shvvalue, NULL, 0);
347 sv.shvnamelen = sizeof name;
349 MAKERXSTRING(sv.shvname, name, sizeof name);
350 if (sv.shvvalue.strptr) {
351 DosFreeMem(sv.shvvalue.strptr);
352 MAKERXSTRING(sv.shvvalue, NULL, 0);
354 rc = pRexxVariablePool(&sv);
355 } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
358 /* returned lengths appear to be swapped */
359 /* but beware of "future bug fixes" */
360 namelen = sv.shvname.strlength; /* should be */
361 if (sv.shvnamelen < sv.shvname.strlength)
362 namelen = sv.shvnamelen; /* is */
363 valuelen = sv.shvvalue.strlength; /* should be */
364 if (sv.shvvaluelen < sv.shvvalue.strlength)
365 valuelen = sv.shvvaluelen; /* is */
367 fprintf(stderr, " %.*s='%.*s'\n",
368 namelen, sv.shvname.strptr,
369 valuelen, sv.shvvalue.strptr);
370 PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
371 if (sv.shvvalue.strptr) {
372 PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
373 DosFreeMem(sv.shvvalue.strptr);
376 } else if (rc != RXSHV_LVAR) {
377 die("Error %i when in _next", rc);
380 fprintf(stderr, " rc=%#lX\n", rc);
391 for (i = 0; i < items; ++i) {
392 SHVBLOCK * var = &vars[i];
394 name = SvPV(ST(i),namelen);
395 var->shvcode = RXSHV_DROPV;
396 var->shvnext = &vars[i+1];
397 var->shvnamelen = namelen;
398 var->shvvaluelen = 0;
399 MAKERXSTRING(var->shvname, name, var->shvnamelen);
400 MAKERXSTRING(var->shvvalue, NULL, 0);
402 vars[items-1].shvnext = NULL;
403 RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
412 RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
426 REXX_eval_with(cmd,name,cv)