REXX on OS/2

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

p4raw-id: //depot/perl@13183

6 files changed, 365 insertions, 91 deletions

diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs
index be5aad1cc8..2f697ed76e 100644
--- a/os2/Makefile.SHs
+++ b/os2/Makefile.SHs
@@ -44,6 +44,7 @@ AOUT_CLDFLAGS_DLL	= -Zexe -Zmt -Zcrtdll -Zstack 32000
 SO_CCCMD	= \$(CC) $ccflags \$(OPTIMIZE)
 
 LD_OPT		= \$(OPTIMIZE)
+PERL_DLL_LD_OPT = -Zmap -Zlinker /map
 
 PERL_DLL_BASE	= perl$dll_post
 PERL_DLL	= \$(PERL_DLL_BASE)\$(DLSUFFIX)
@@ -90,7 +91,7 @@ t/$(PERL_DLL): $(PERL_DLL)
 	$(LNS) $(PERL_DLL) t/$(PERL_DLL)
 
 $(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT)
-	$(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def || ( rm $(PERL_DLL) && sh -c false )
+	$(LD) $(LD_OPT) $(LDDLFLAGS) $(PERL_DLL_LD_OPT) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def || ( rm $(PERL_DLL) && sh -c false )
 
 perl5.olddef: perl.linkexp
 	echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE"	> $@
@@ -229,7 +230,9 @@ STAT_AOUT_CLDFLAGS = -Zexe -Zmt -Zstack 32000
 perl_stat_aout$(EXE_EXT) perl_stat_aout: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs
 	$(SHRPENV) $(CC) $(STAT_AOUT_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs)
 
-perl : perl__ perl___
+PERLREXX_DLL = perlrexx.dll
+
+perl : perl__ perl___ $(PERLREXX_DLL)
 
 # Dynamically loaded PM-application perl:
 
@@ -251,7 +254,7 @@ aout_install: perl_ aout_install.perl
 aout_install.perl: perl_ installperl
 	./perl_ installperl
 
-perlrexx: perlrexx.dll
+perlrexx: $(PERLREXX_DLL)
 	@sh -c true
 
 perlrexx.c: os2/perlrexx.c
@@ -262,10 +265,10 @@ SO_CLDFLAGS = -Zdll -Zso -Zomf -Zmt -Zsys
 
 # A callable-from-REXX DLL
 
-perlrexx.dll: perlrexx$(OBJ_EXT) perlrexx.def
+$(PERLREXX_DLL): perlrexx$(OBJ_EXT) perlrexx.def
 	$(SHRPENV) $(CC) $(SO_CLDFLAGS) $(CCDLFLAGS) -o $@ perlrexx$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) perlrexx.def
 
-perlrexx.def: miniperl \$(_preplibrary)
+perlrexx.def: miniperl $(_preplibrary)
 	echo	"LIBRARY 'perlrexx' INITINSTANCE TERMINSTANCE"	> tmp.def
 	echo	"DESCRIPTION '@#perl5-porters@perl.org:`miniperl -Ilib -MConfig -e 'print \$$]'`#@ REXX to Perl `miniperl -Ilib -MConfig -e 'print \$$Config{version}'` interface'" >> tmp.def
 	echo	"EXPORTS"					>> tmp.def
@@ -274,6 +277,11 @@ perlrexx.def: miniperl \$(_preplibrary)
 	echo	'  "PERLINIT"'					>> tmp.def
 	echo	'  "PERLEXIT"'					>> tmp.def
 	echo	'  "PERLEVAL"'					>> tmp.def
+	echo	'  "PERLLASTERROR"'				>> tmp.def
+	echo	'  "PERLEVALSUBCOMMAND"'			>> tmp.def
+	echo	'  "PERLEXPORTALL"'				>> tmp.def
+	echo	'  "PERLDROPALL"'				>> tmp.def
+	echo	'  "PERLDROPALLEXIT"'				>> tmp.def
 	sh mv-if-diff tmp.def $@
 
 
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)'";
diff --git a/os2/os2.c b/os2/os2.c
index 740f403d0b..f104abd410 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -2571,7 +2571,7 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
     atexit(jmp_out_of_atexit);		/* Allow run of atexit() w/o exit()  */
 
-    if (!env) {				/* Fetch from the process info block */
+    if (env == NULL) {			/* Fetch from the process info block */
 	int c = 0;
 	PPIB pib;
 	PTIB tib;
@@ -2583,11 +2583,6 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
 	    c++;
 	    e = e + strlen(e) + 1;
 	}
-	e = pib->pib_pchenv;
-	while (*e) {			/* Get count */
-	    c++;
-	    e = e + strlen(e) + 1;
-	}
 	New(1307, env, c + 1, char*);
 	ep = env;
 	e = pib->pib_pchenv;
diff --git a/os2/perlrexx.c b/os2/perlrexx.c
index 7711783733..5706b18969 100644
--- a/os2/perlrexx.c
+++ b/os2/perlrexx.c
@@ -27,6 +27,10 @@
 static void xs_init (pTHX);
 static PerlInterpreter *my_perl;
 
+ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
+ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
+ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
+
 #if defined (__MINT__) || defined (atarist)
 /* The Atari operating system doesn't have a dynamic stack.  The
    stack size is determined from this value.  */
@@ -81,6 +85,26 @@ init_perl(int doparse)
     return !exitstatus;
 }
 
+static char last_error[4096];
+
+static int
+seterr(char *format, ...)
+{
+	va_list va;
+	char *s = last_error;
+
+	va_start(va, format);
+	if (s[0]) {
+	    s += strlen(s);
+	    if (s[-1] != '\n') {
+		snprintf(s, sizeof(last_error) - (s - last_error), "\n");
+		s += strlen(s);
+	    }
+	}
+	vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
+	return 1;
+}
+
 /* The REXX-callable entrypoints ... */
 
 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
@@ -91,18 +115,11 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
     char *argv[3] = {"perl_from_REXX", "-e", buf};
     ULONG ret;
 
-    if (rargc != 1) {
-	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
-    if (rargv[0].strlength >= sizeof(buf)) {
-	sprintf(retstr->strptr,
-		"length of the argument %ld exceeds the maximum %ld",
-		rargv[0].strlength, (long)sizeof(buf) - 1);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
+    if (rargc != 1)
+	return seterr("one argument expected, got %ld", rargc);
+    if (rargv[0].strlength >= sizeof(buf))
+	return seterr("length of the argument %ld exceeds the maximum %ld",
+		      rargv[0].strlength, (long)sizeof(buf) - 1);
 
     if (!init_perl(0))
 	return 1;
@@ -133,11 +150,8 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
                     PCSZ queuename, PRXSTRING retstr)
 {
-    if (rargc != 0) {
-	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
+    if (rargc != 0)
+	return seterr("no arguments expected, got %ld", rargc);
     PERL_SYS_TERM1(0);
     return 0;
 }
@@ -145,16 +159,10 @@ ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
                     PCSZ queuename, PRXSTRING retstr)
 {
-    if (rargc != 0) {
-	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
-    if (!my_perl) {
-	sprintf(retstr->strptr, "no perl interpreter present");
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
+    if (rargc != 0)
+	return seterr("no arguments expected, got %ld", rargc);
+    if (!my_perl)
+	return seterr("no perl interpreter present");
     perl_destruct(my_perl);
     perl_free(my_perl);
     my_perl = 0;
@@ -168,11 +176,8 @@ ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
                     PCSZ queuename, PRXSTRING retstr)
 {
-    if (rargc != 0) {
-	sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
+    if (rargc != 0)
+	return seterr("no argument expected, got %ld", rargc);
     if (!init_perl(1))
 	return 1;
 
@@ -181,21 +186,36 @@ ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
     return 0;
 }
 
-ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
-                    PCSZ queuename, PRXSTRING retstr)
+ULONG
+PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
+{
+    int len = strlen(last_error);
+
+    if (len <= 256			/* Default buffer is 256-char long */
+	|| !DosAllocMem((PPVOID)&retstr->strptr, len,
+			PAG_READ|PAG_WRITE|PAG_COMMIT)) {
+	    memcpy(retstr->strptr, last_error, len);
+	    retstr->strlength = len;
+    } else {
+	strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
+	retstr->strlength = strlen(retstr->strptr);
+    }
+    return 0;
+}
+
+ULONG
+PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 {
     SV *res, *in;
-    STRLEN len;
+    STRLEN len, n_a;
     char *str;
 
-    if (rargc != 1) {
-	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
-	retstr->strlength = strlen (retstr->strptr);
-	return 1;
-    }
+    last_error[0] = 0;
+    if (rargc != 1)
+	return seterr("one argument expected, got %ld", rargc);
 
     if (!init_perl(1))
-	return 1;
+	return seterr("error initializing perl");
 
   {
     dSP;
@@ -212,8 +232,10 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
     PUTBACK;
 
     ret = 0;
-    if (SvTRUE(ERRSV) || !SvOK(res))
-	ret = 1;
+    if (SvTRUE(ERRSV))
+	ret = seterr(SvPV(ERRSV, n_a));
+    if (!SvOK(res))
+	ret = seterr("undefined value returned by Perl-in-REXX");
     str = SvPV(res, len);
     if (len <= 256			/* Default buffer is 256-char long */
 	|| !DosAllocMem((PPVOID)&retstr->strptr, len,
@@ -221,7 +243,7 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 	    memcpy(retstr->strptr, str, len);
 	    retstr->strlength = len;
     } else
-	ret = 1;
+	ret = seterr("Not enough memory for the return string of Perl-in-REXX");
 
     FREETMPS;
     LEAVE;
@@ -229,6 +251,75 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
     return ret;
   }
 }
+
+ULONG
+PERLEVALSUBCOMMAND(
+  const RXSTRING    *command,          /* command to issue           */
+  PUSHORT      flags,                  /* error/failure flags        */
+  PRXSTRING    retstr )                /* return code                */
+{
+    ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
+
+    if (rc)
+	*flags = RXSUBCOM_ERROR;         /* raise error condition    */
+
+    return 0;                            /* finished                   */
+}
+
+#define ArrLength(a) (sizeof(a)/sizeof(*(a)))
+
+static const struct {
+  char *name;
+  RexxFunctionHandler *f;
+} funcs[] = {
+             {"PERL",			(RexxFunctionHandler *)&PERL},
+             {"PERLTERM",		(RexxFunctionHandler *)&PERLTERM},
+             {"PERLINIT",		(RexxFunctionHandler *)&PERLINIT},
+             {"PERLEXIT",		(RexxFunctionHandler *)&PERLEXIT},
+             {"PERLEVAL",		(RexxFunctionHandler *)&PERLEVAL},
+             {"PERLLASTERROR",		(RexxFunctionHandler *)&PERLLASTERROR},
+             {"PERLDROPALL",		(RexxFunctionHandler *)&PERLDROPALL},
+             {"PERLDROPALLEXIT",	(RexxFunctionHandler *)&PERLDROPALLEXIT},
+             /* Should be the last entry */
+             {"PERLEXPORTALL",		(RexxFunctionHandler *)&PERLEXPORTALL}
+          };
+
+ULONG
+PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
+{
+   int i = -1;
+
+   while (++i < ArrLength(funcs) - 1)
+	RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
+   RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
+   retstr->strlength = 0;
+   return 0;
+}
+
+ULONG
+PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
+{
+   int i = -1;
+
+   while (++i < ArrLength(funcs))
+	RexxDeregisterFunction(funcs[i].name);
+   RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
+   retstr->strlength = 0;
+   return 0;
+}
+
+ULONG
+PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
+{
+   int i = -1;
+
+   while (++i < ArrLength(funcs))
+	RexxDeregisterFunction(funcs[i].name);
+   RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
+   PERL_SYS_TERM1(0);
+   retstr->strlength = 0;
+   return 0;
+}
 #define INCL_DOSPROCESS
 #define INCL_DOSSEMAPHORES
 #define INCL_DOSMODULEMGR