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)
$(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" > $@
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:
aout_install.perl: perl_ installperl
./perl_ installperl
-perlrexx: perlrexx.dll
+perlrexx: $(PERLREXX_DLL)
@sh -c true
perlrexx.c: os2/perlrexx.c
# 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
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 $@
# 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...
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
*/
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
#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);
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];
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));
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 };
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;
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)
{
static void
initialize(void)
{
+ ULONG rc;
*(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
*(PFN *)&pRexxRegisterFunctionExe
= loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
needstrs(8);
needvars(8);
trace = getenv("PERL_REXX_DEBUG");
+
+ rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL);
}
static int
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
$| = 1; # Otherwise data from REXX may come first
-print "1..16\n";
+print "1..18\n";
$n = 1;
sub do_me {
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)'";
/* 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;
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;
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. */
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,
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;
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;
}
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;
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;
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;
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,
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;
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
projects / p5sagit/p5-mst-13.2.git / commitdiff