static int nvars;
static char * trace;
+/*
static RXSTRING rxcommand = { 9, "RXCOMMAND" };
static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
static RXSTRING rxfunction = { 11, "RXFUNCTION" };
+*/
static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
static long incompartment;
+static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
+ PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
+static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
+ RexxFunctionHandler *);
+static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
+
+static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
+
static SV*
exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
{
- dTHR;
- HMODULE hRexx, hRexxAPI;
- BYTE buf[200];
- LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
- PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
- APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
- RexxFunctionHandler *);
- APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
incompartment = 1;
- if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
- || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
- || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
- || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
- (PFN *)&pRexxRegisterFunctionExe)
- || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
- (PFN *)&pRexxDeregisterFunction)) {
- Perl_die(aTHX_ "REXX not available\n");
- }
-
if (handlerName)
pRexxRegisterFunctionExe(handlerName, handler);
incompartment = 0;
pRexxDeregisterFunction("StartPerl");
+#if 0 /* Do we want to restore these? */
DosFreeModule(hRexxAPI);
DosFreeModule(hRexx);
+#endif
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_die(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);
}
int i, rc;
unsigned long len;
char *str;
- char **arr;
+ SV *res;
dSP;
DosSetExceptionHandler(&xreg);
}
#endif
+ for (i = 0; i < argc; ++i)
+ XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
+ PUTBACK;
if (name) {
- int ac = 0;
- char **arr = alloca((argc + 1) * sizeof(char *));
-
- for (i = 0; i < argc; ++i)
- arr[ac++] = argv[i].strptr;
- arr[ac] = NULL;
-
- rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr);
+ rc = perl_call_pv(name, G_SCALAR | G_EVAL);
} else if (exec_cv) {
SV *cv = exec_cv;
exec_cv = NULL;
rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
- } else rc = -1;
+ } else
+ rc = -1;
SPAGAIN;
- if (rc == 1 && SvOK(TOPs)) {
- str = SvPVx(POPs, len);
- if (len > 256)
- if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
- DosUnsetExceptionHandler(&xreg);
- return 1;
- }
- memcpy(ret->strptr, str, len);
- ret->strlength = len;
- }
+ if (rc == 1) /* must be! */
+ res = POPs;
+ if (rc == 1 && SvOK(res)) {
+ str = SvPVx(res, len);
+ if (len <= 256 /* Default buffer is 256-char long */
+ || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len,
+ PAG_READ|PAG_WRITE|PAG_COMMIT))) {
+ memcpy(ret->strptr, str, len);
+ ret->strlength = len;
+ } else
+ rc = 0;
+ } else
+ rc = 0;
PUTBACK ;
FREETMPS ;
LEAVE ;
- if (rc != 1) {
- DosUnsetExceptionHandler(&xreg);
- return 1;
- }
-
-
DosUnsetExceptionHandler(&xreg);
- return 0;
+ return rc == 1 ? 0 : 1; /* 0 means SUCCESS */
}
static void
static void
initialize(void)
{
+ *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
+ *(PFN *)&pRexxRegisterFunctionExe
+ = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
+ *(PFN *)&pRexxDeregisterFunction
+ = loadByOrdinal(ORD_RexxDeregisterFunction, 1);
+ *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
needstrs(8);
needvars(8);
trace = getenv("PERL_REXX_DEBUG");
MAKERXSTRING(var->shvvalue, value, valuelen);
if (trace)
fprintf(stderr, " %.*s='%.*s'",
- var->shvname.strlength, var->shvname.strptr,
- var->shvvalue.strlength, var->shvvalue.strptr);
+ (int)var->shvname.strlength, var->shvname.strptr,
+ (int)var->shvvalue.strlength, var->shvvalue.strptr);
}
if (trace)
fprintf(stderr, "\n");
vars[n-1].shvnext = NULL;
- rc = RexxVariablePool(vars);
+ rc = pRexxVariablePool(vars);
if (trace)
- fprintf(stderr, " rc=%X\n", rc);
+ fprintf(stderr, " rc=%#lX\n", rc);
RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
if (trace)
fprintf(stderr, "\n");
vars[items-1].shvnext = NULL;
- rc = RexxVariablePool(vars);
+ rc = pRexxVariablePool(vars);
if (!(rc & ~RXSHV_NEWV)) {
for (i = 0; i < items; ++i) {
int namelen;
namelen = var->shvvaluelen; /* is */
if (trace)
fprintf(stderr, " %.*s='%.*s'\n",
- var->shvname.strlength, var->shvname.strptr,
+ (int)var->shvname.strlength, var->shvname.strptr,
namelen, var->shvvalue.strptr);
if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
PUSHs(&PL_sv_undef);
}
} else {
if (trace)
- fprintf(stderr, " rc=%X\n", rc);
+ fprintf(stderr, " rc=%#lX\n", rc);
}
}
DosFreeMem(sv.shvvalue.strptr);
MAKERXSTRING(sv.shvvalue, NULL, 0);
}
- rc = RexxVariablePool(&sv);
+ rc = pRexxVariablePool(&sv);
} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
if (!rc) {
EXTEND(SP, 2);
die("Error %i when in _next", rc);
} else {
if (trace)
- fprintf(stderr, " rc=%X\n", rc);
+ fprintf(stderr, " rc=%#lX\n", rc);
}
}
MAKERXSTRING(var->shvvalue, NULL, 0);
}
vars[items-1].shvnext = NULL;
- RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
+ RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
RETVAL
_register(name)
char * name
CODE:
- RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
+ RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
OUTPUT:
RETVAL
projects / p5sagit/p5-mst-13.2.git / blobdiff