static int nvars;
static char * trace;
+/*
static RXSTRING rxcommand = { 9, "RXCOMMAND" };
static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
static RXSTRING rxfunction = { 11, "RXFUNCTION" };
+*/
-static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret);
+static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
#if 1
#define Set RXSHV_SET
static long incompartment;
-static SV*
-exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
-{
- dTHR;
- HMODULE hRexx, hRexxAPI;
- BYTE buf[200];
- LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
+static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
- APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
+static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
RexxFunctionHandler *);
- APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
+static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
+
+static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
+
+static SV*
+exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
+{
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
LONG rc;
SV *res;
- if (incompartment) die ("Attempt to reenter into REXX compartment");
+ if (incompartment)
+ 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)) {
- die("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));
} else {
res = NEWSV(729,0);
}
- if (rc || SvTRUE(GvSV(errgv))) {
- if (SvTRUE(GvSV(errgv))) {
- die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ;
+ 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)) ;
}
- die ("REXX compartment returned non-zero status %li", rc);
+ Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
}
return res;
static SV* exec_cv;
static ULONG
-PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
+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("return StartPerl()\r\n", \
+#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(cmd,name,PERLSTART))
+ exec_in_REXX(aTHX_ cmd,name,PERLSTART))
#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
static ULONG
-PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
+PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
{
+ dTHX;
EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
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");
}
static int
-not_here(s)
-char *s;
-{
- croak("%s not implemented on this architecture", s);
- return -1;
-}
-
-static int
-constant(name, arg)
-char *name;
-int arg;
+constant(char *name, int arg)
{
errno = EINVAL;
return 0;
char * name
int arg
-SV *
-_call(name, address, queue="SESSION", ...)
- char * name
- void * address
- char * queue
- CODE:
- {
- ULONG rc;
- int argc, i;
- RXSTRING result;
- UCHAR resbuf[256];
- RexxFunctionHandler *fcn = address;
- argc = items-3;
- needstrs(argc);
- if (trace)
- fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
- for (i = 0; i < argc; ++i) {
- STRLEN len;
- char *ptr = SvPV(ST(3+i), len);
- MAKERXSTRING(strs[i], ptr, len);
- if (trace)
- fprintf(stderr, " '%.*s'", len, ptr);
- }
- if (!*queue)
- queue = "SESSION";
- if (trace)
- fprintf(stderr, "\n");
- MAKERXSTRING(result, resbuf, sizeof resbuf);
- rc = fcn(name, argc, strs, queue, &result);
- if (trace)
- fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
- result.strlength, result.strptr);
- ST(0) = sv_newmortal();
- if (rc == 0) {
- if (result.strptr)
- sv_setpvn(ST(0), result.strptr, result.strlength);
- else
- sv_setpvn(ST(0), "", 0);
- }
- if (result.strptr && result.strptr != resbuf)
- DosFreeMem(result.strptr);
- }
-
int
_set(name,value,...)
char * name
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(&sv_undef);
+ PUSHs(&PL_sv_undef);
else
PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
namelen)));
}
} 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);
PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
DosFreeMem(sv.shvvalue.strptr);
} else
- PUSHs(&sv_undef);
+ PUSHs(&PL_sv_undef);
} else if (rc != RXSHV_LVAR) {
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