REXX on OS/2

Message-ID: <20011121152611.A13664@math.ohio-state.edu>

p4raw-id: //depot/perl@13183

1 files changed, 147 insertions, 34 deletions

diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs
index 85944c75d2..c3ddcb4dbd 100644
--- a/os2/OS2/REXX/REXX.xs
+++ b/os2/OS2/REXX/REXX.xs
@@ -32,6 +32,9 @@ static RXSTRING   rxfunction   = { 11, "RXFUNCTION" };
 */
 
 static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
+static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
+static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
+static RexxSubcomHandler SubCommandPerlEval;
 
 #if 1
  #define Set	RXSHV_SET
@@ -43,7 +46,7 @@ static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRI
  #define Drop	RXSHV_SYDRO
 #endif
 
-static long incompartment;
+static long incompartment;	/* May be used to unload the REXX */
 
 static LONG    APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, 
 				    PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
@@ -53,8 +56,14 @@ static APIRET  APIENTRY (*pRexxDeregisterFunction) (PSZ);
 
 static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
 
+static SV* exec_cv;
+
+/* Create a REXX compartment,
+   register `n' callbacks `handlers' with the REXX names `handlerNames',
+   evaluate the REXX expression `cmd'.
+ */
 static SV*
-exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
+exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers)
 {
     RXSTRING args[1];
     RXSTRING inst[2];
@@ -62,27 +71,47 @@ exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
     USHORT   retcode;
     LONG rc;
     SV *res;
+    char *subs = 0;
+    int n = c;
 
-    if (incompartment)
-	Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
-    incompartment = 1;
+    incompartment++;
 
-    if (handlerName)
-	pRexxRegisterFunctionExe(handlerName, handler);
+    if (c)
+	Newz(728, subs, c, char);
+    while (n--) {
+	rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]);
+	if (rc == RXFUNC_DEFINED)
+	    subs[n] = 1;
+    }
 
     MAKERXSTRING(args[0], NULL, 0);
     MAKERXSTRING(inst[0], cmd,  strlen(cmd));
     MAKERXSTRING(inst[1], NULL, 0);
     MAKERXSTRING(result,  NULL, 0);
-    rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
+    rc = pRexxStart(0, args,		/* No arguments */
+		    "REXX_in_Perl",	/* Returned on REXX' PARSE SOURCE,
+					   and the "macrospace function name" */
+		    inst,		/* inst[0] - the code to execute,
+					   inst[1] will contain tokens. */
+		    "Perl",		/* Pass string-cmds to this callback */
+		    RXSUBROUTINE,	/* Many arguments, maybe result */
+		    NULL,		/* No callbacks/exits to register */
 		    &retcode, &result);
 
-    incompartment = 0;
-    pRexxDeregisterFunction("StartPerl");
+    incompartment--;
+    n = c;
+    while (n--)
+	if (!subs[n])
+	    pRexxDeregisterFunction(handlerNames[n]);
+    if (c)
+	Safefree(subs);
 #if 0					/* Do we want to restore these? */
     DosFreeModule(hRexxAPI);
     DosFreeModule(hRexx);
 #endif
+
+    if (RXSTRPTR(inst[1]))		/* Free the tokenized version */
+	DosFreeMem(RXSTRPTR(inst[1]));
     if (!RXNULLSTRING(result)) {
 	res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
 	DosFreeMem(RXSTRPTR(result));
@@ -92,31 +121,18 @@ exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
     if (rc || SvTRUE(GvSV(PL_errgv))) {
 	if (SvTRUE(GvSV(PL_errgv))) {
 	    STRLEN n_a;
-	    Perl_die(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
+	    Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
 	}
-	Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
+	Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc);
     }
 
     return res;
 }
 
-static SV* exec_cv;
-
+/* Call the Perl function given by name, or if name=0, by cv,
+   with the given arguments.  Return the stringified result to REXX. */
 static ULONG
-PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
-{
-    return PERLCALL(NULL, argc, argv, queue, ret);
-}
-
-#define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \
-					   "StartPerl", PERLSTART)
-#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
-#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv),		\
-				      exec_in_REXX(aTHX_ cmd,name,PERLSTART))
-#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
-
-static ULONG
-PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
+PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
 {
     dTHX;
     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
@@ -142,14 +158,11 @@ PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
     for (i = 0; i < argc; ++i)
 	XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
     PUTBACK;
-    if (name) {
+    if (name)
 	rc = perl_call_pv(name, G_SCALAR | G_EVAL);
-    } else if (exec_cv) {
-	SV *cv = exec_cv;
-
-	exec_cv = NULL;
+    else if (cv)
 	rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
-    } else
+    else
 	rc = -1;
 
     SPAGAIN;
@@ -176,6 +189,78 @@ PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
     return rc == 1 ? 0 : 1;			/* 0 means SUCCESS */
 }
 
+static ULONG
+PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
+{
+    SV *cv = exec_cv;
+
+    exec_cv = NULL;
+    return PERLCALLcv(NULL, cv, argc, argv, queue, ret);
+}
+
+static ULONG
+PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
+{
+  return PERLCALLcv(name, Nullsv, argc, argv, queue, ret);
+}
+
+RexxFunctionHandler* PF = &PERLSTART;
+char* PF_name = "StartPerl";
+
+#define REXX_eval_with(cmd,name,cv)	\
+	( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF))
+#define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv))
+#define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL))
+
+static ULONG
+SubCommandPerlEval(
+  PRXSTRING    command,                /* command to issue           */
+  PUSHORT      flags,                  /* error/failure flags        */
+  PRXSTRING    retstr )                /* return code                */
+{
+    dSP;
+    STRLEN len;
+    int ret;
+    char *str = 0;
+    SV *in, *res;
+
+    ENTER;
+    SAVETMPS;
+
+    PUSHMARK(SP);
+    in = sv_2mortal(newSVpvn(command->strptr, command->strlength));
+    eval_sv(in, G_SCALAR);
+    SPAGAIN;
+    res = POPs;
+    PUTBACK;
+
+    ret = 0;
+    if (SvTRUE(ERRSV)) {
+	*flags = RXSUBCOM_ERROR;         /* raise error condition    */
+	str = SvPV(ERRSV, len);
+    } else if (!SvOK(res)) {
+	*flags = RXSUBCOM_ERROR;         /* raise error condition    */
+	str = "undefined value returned by Perl-in-REXX";
+        len = strlen(str);
+    } else
+	str = SvPV(res, len);
+    if (len <= 256			/* Default buffer is 256-char long */
+	|| !DosAllocMem((PPVOID)&retstr->strptr, len,
+			PAG_READ|PAG_WRITE|PAG_COMMIT)) {
+	    memcpy(retstr->strptr, str, len);
+	    retstr->strlength = len;
+    } else {
+	*flags = RXSUBCOM_ERROR;         /* raise error condition    */
+	strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX");
+	retstr->strlength = strlen(retstr->strptr);
+    }
+
+    FREETMPS;
+    LEAVE;
+
+    return 0;                            /* finished                   */
+}
+
 static void
 needstrs(int n)
 {
@@ -201,6 +286,7 @@ needvars(int n)
 static void
 initialize(void)
 {
+    ULONG rc;
     *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
     *(PFN *)&pRexxRegisterFunctionExe
 	= loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
@@ -210,6 +296,8 @@ initialize(void)
     needstrs(8);
     needvars(8);
     trace = getenv("PERL_REXX_DEBUG");
+     
+    rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL);
 }
 
 static int
@@ -427,3 +515,28 @@ REXX_eval_with(cmd,name,cv)
 	char *cmd
 	char *name
 	SV *cv
+
+#ifdef THIS_IS_NOT_FINISHED
+
+SV*
+_REXX_eval_with(cmd,...)
+	char *cmd
+ CODE:
+   {
+	int n = (items - 1)/2;
+	char **names;
+	SV **cvs;
+
+	if ((items % 2) == 0)
+	    Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()");
+	New(730, names, n, char*);
+	New(730, cvs, n, SV*);
+	/* XXX Unfinished... */
+	RETVAL = Nullsv;
+	Safefree(names);
+	Safefree(cvs);
+   }
+ OUTPUT:
+    RETVAL
+
+#endif