REXX on OS/2

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

p4raw-id: //depot/perl@13183

3 files changed, 216 insertions, 36 deletions

diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm
index 1a7cb4d54c..57e6d6d1a4 100644
--- a/os2/OS2/REXX/REXX.pm
+++ b/os2/OS2/REXX/REXX.pm
@@ -12,7 +12,7 @@ require OS2::DLL;
 # Other items we are prepared to export if requested
 @EXPORT_OK = qw(drop register);
 
-$VERSION = '1.00';
+$VERSION = '1.01';
 
 # We cannot just put OS2::DLL in @ISA, since some scripts would use
 # function interface, not method interface...
@@ -333,6 +333,67 @@ part of the key and it is subject to character set restrictions.
 
 Since REXX is not case-sensitive, the names should be uppercase.
 
+=head1 Subcommand handlers
+
+By default, the executed REXX code runs without any default subcommand
+handler present.  A subcommand handler named C<PERLEVAL> is defined, but
+not made a default.  Use C<ADDRESS PERLEVAL> REXX command to make it a default
+handler; alternatively, use C<ADDRESS Handler WhatToDo> to direct a command
+to the handler you like.
+
+Experiments show that the handler C<CMD> is also available; probably it is
+provided by the REXX runtime.
+
+=head1 Interfacing from REXX to Perl
+
+This module provides an interface from Perl to REXX, and from REXX-inside-Perl
+back to Perl.  There is an alternative scenario which allows usage of Perl
+from inside REXX.
+
+A DLL F<PerlRexx> provides an API to Perl as REXX functions
+
+  PERL
+  PERLTERM
+  PERLINIT
+  PERLEXIT
+  PERLEVAL
+  PERLLASTERROR
+  PERLEXPORTALL
+  PERLDROPALL
+  PERLDROPALLEXIT
+
+A subcommand handler C<PERLEVALSUBCOMMAND> can also be registered.  Calling
+the function PERLEXPORTALL() exports all these functions, as well as
+exports this subcommand handler under the name C<EVALPERL>.  PERLDROPALL()
+inverts this action (and unloads PERLEXPORTALL() as well).  In particular
+
+  rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL")
+  rc = PerlExportAll()
+  res = PERLEVAL(perlarg)
+  ADDRESS EVALPERL perlarg1
+  rc = PerlDropAllExit()
+
+loads all the functions above, evals the Perl code in the REXX variable
+C<perlarg>, putting the result into the REXX variable C<res>,
+then evals the Perl code in the REXX variable C<perlarg1>, and, finally,
+drops the loaded functions and the subcommand handler, deinitializes
+the Perl interpreter, and exits the Perl's C runtime library.
+
+PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of
+the REXX program.  (This is considered as a bug.)  Their purpose is to flush
+all the output buffers of the Perl's C runtime library.
+
+C<PERLLASTERROR> gives the reason for the failure of the last PERLEVAL().
+It is useful inside C<signal on syntax> handler.  PERLINIT() and PERLTERM()
+initialize and deinitialize the Perl interpreter.
+
+C<PERLEVAL(string)> initializes the Perl interpreter (if needed), and
+evaluates C<string> as Perl code.  The result is returned to REXX stringified,
+undefined result is considered as failure.
+
+C<PERL(string)> does the same as C<PERLEVAL(string)> wrapped by calls to
+PERLINIT() and PERLEXIT().
+
 =head1 NOTES
 
 Note that while function and variable names are case insensitive in the
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
diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t
index 6baec7687d..6db785be51 100644
--- a/os2/OS2/REXX/t/rx_cmprt.t
+++ b/os2/OS2/REXX/t/rx_cmprt.t
@@ -12,7 +12,7 @@ use OS2::REXX qw(:DEFAULT register);
 
 $| = 1;				# Otherwise data from REXX may come first
 
-print "1..16\n";
+print "1..18\n";
 
 $n = 1;
 sub do_me {
@@ -46,3 +46,9 @@ sub MYFUNC2 {3 * shift}
 REXX_eval_with "call myfunc
 		say 'ok 'myfunc1(1)myfunc2(2)",
   myfunc => sub { register qw(myfunc1 myfunc2) };
+
+REXX_eval_with "say 'ok 'myfunc(10,7)",
+  myfunc => sub { REXX_eval "return $_[0] + $_[1]" };
+
+sub MyFunc3 {print 'ok ', shift() + shift(), "\n"}
+REXX_eval "address perleval\n'MyFunc3(10,8)'";