From: Ilya Zakharevich Date: Wed, 21 Nov 2001 15:26:11 +0000 (-0500) Subject: REXX on OS/2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e2a34c155c6ae146f46dd9d0b10a01f07191954;p=p5sagit%2Fp5-mst-13.2.git REXX on OS/2 Message-ID: <20011121152611.A13664@math.ohio-state.edu> p4raw-id: //depot/perl@13183 --- diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index be5aad1..2f697ed 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 1a7cb4d..57e6d6d 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 is defined, but +not made a default. Use C
REXX command to make it a default +handler; alternatively, use C
to direct a command +to the handler you like. + +Experiments show that the handler C 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 provides an API to Perl as REXX functions + + PERL + PERLTERM + PERLINIT + PERLEXIT + PERLEVAL + PERLLASTERROR + PERLEXPORTALL + PERLDROPALL + PERLDROPALLEXIT + +A subcommand handler C can also be registered. Calling +the function PERLEXPORTALL() exports all these functions, as well as +exports this subcommand handler under the name C. 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, putting the result into the REXX variable C, +then evals the Perl code in the REXX variable C, 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 gives the reason for the failure of the last PERLEVAL(). +It is useful inside C handler. PERLINIT() and PERLTERM() +initialize and deinitialize the Perl interpreter. + +C initializes the Perl interpreter (if needed), and +evaluates C as Perl code. The result is returned to REXX stringified, +undefined result is considered as failure. + +C does the same as C 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 85944c7..c3ddcb4 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 6baec76..6db785b 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 740f403..f104abd 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 7711783..5706b18 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