[p5sagit/p5-mst-13.2.git] / os2 / OS2 / REXX / REXX.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define INCL_BASE
#define INCL_REXXSAA
#include <os2emx.h>

#if 0
#define INCL_REXXSAA
#pragma pack(1)
#define _Packed
#include <rexxsaa.h>
#pragma pack()
#endif

extern ULONG _emx_exception (	EXCEPTIONREPORTRECORD *,
				EXCEPTIONREGISTRATIONRECORD *,
                                CONTEXTRECORD *,
                                void *);

static RXSTRING * strs;
static int	  nstrs;
static SHVBLOCK * vars;
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);

#if 1
 #define Set	RXSHV_SET
 #define Fetch	RXSHV_FETCH
 #define Drop	RXSHV_DROPV
#else
 #define Set	RXSHV_SYSET
 #define Fetch	RXSHV_SYFET
 #define Drop	RXSHV_SYDRO
#endif

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)
{
    RXSTRING args[1];
    RXSTRING inst[2];
    RXSTRING result;
    USHORT   retcode;
    LONG rc;
    SV *res;

    if (incompartment)
	Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
    incompartment = 1;

    if (handlerName)
	pRexxRegisterFunctionExe(handlerName, handler);

    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,
		    &retcode, &result);

    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(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_ "REXX compartment returned non-zero status %li", rc);
    }

    return res;
}

static SV* exec_cv;

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)
{
    dTHX;
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
    int i, rc;
    unsigned long len;
    char *str;
    SV *res;
    dSP;

    DosSetExceptionHandler(&xreg);

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

#if 0
    if (!my_perl) {
	DosUnsetExceptionHandler(&xreg);
	return 1;
    }
#endif 

    for (i = 0; i < argc; ++i)
	XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
    PUTBACK;
    if (name) {
	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;

    SPAGAIN;

    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 ;

    DosUnsetExceptionHandler(&xreg);
    return rc == 1 ? 0 : 1;			/* 0 means SUCCESS */
}

static void
needstrs(int n)
{
    if (n > nstrs) {
	if (strs)
	    free(strs);
	nstrs = 2 * n;
	strs = malloc(nstrs * sizeof(RXSTRING));
    }
}

static void
needvars(int n)
{
    if (n > nvars) {
	if (vars)
	    free(vars);
	nvars = 2 * n;
	vars = malloc(nvars * sizeof(SHVBLOCK));
    }
}

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
constant(char *name, int arg)
{
    errno = EINVAL;
    return 0;
}


MODULE = OS2::REXX		PACKAGE = OS2::REXX

BOOT:
	initialize();

int
constant(name,arg)
	char *		name
	int		arg

int
_set(name,value,...)
	char *		name
	char *		value
 CODE:
   {
       int   i;
       int   n = (items + 1) / 2;
       ULONG rc;
       needvars(n);
       if (trace)
	   fprintf(stderr, "REXXCALL::_set");
       for (i = 0; i < n; ++i) {
	   SHVBLOCK * var = &vars[i];
	   STRLEN     namelen;
	   STRLEN     valuelen;
	   name = SvPV(ST(2*i+0),namelen);
	   if (2*i+1 < items) {
	       value = SvPV(ST(2*i+1),valuelen);
	   }
	   else {
	       value = "";
	       valuelen = 0;
	   }
	   var->shvcode = RXSHV_SET;
	   var->shvnext = &vars[i+1];
	   var->shvnamelen = namelen;
	   var->shvvaluelen = valuelen;
	   MAKERXSTRING(var->shvname, name, namelen);
	   MAKERXSTRING(var->shvvalue, value, valuelen);
	   if (trace)
	       fprintf(stderr, " %.*s='%.*s'",
		       (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 = pRexxVariablePool(vars);
       if (trace)
	   fprintf(stderr, "  rc=%#lX\n", rc);
       RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
   }
 OUTPUT:
    RETVAL

void
_fetch(name, ...)
	char *		name
 PPCODE:
   {
       int   i;
       ULONG rc;
       EXTEND(SP, items);
       needvars(items);
       if (trace)
	   fprintf(stderr, "REXXCALL::_fetch");
       for (i = 0; i < items; ++i) {
	   SHVBLOCK * var = &vars[i];
	   STRLEN     namelen;
	   name = SvPV(ST(i),namelen);
	   var->shvcode = RXSHV_FETCH;
	   var->shvnext = &vars[i+1];
	   var->shvnamelen = namelen;
	   var->shvvaluelen = 0;
	   MAKERXSTRING(var->shvname, name, namelen);
	   MAKERXSTRING(var->shvvalue, NULL, 0);
	   if (trace)
	       fprintf(stderr, " '%s'", name);
       }
       if (trace)
	   fprintf(stderr, "\n");
       vars[items-1].shvnext = NULL;
       rc = pRexxVariablePool(vars);
       if (!(rc & ~RXSHV_NEWV)) {
	   for (i = 0; i < items; ++i) {
	       int namelen;
	       SHVBLOCK * var = &vars[i];
	       /* returned lengths appear to be swapped */
	       /* but beware of "future bug fixes" */
	       namelen = var->shvvalue.strlength; /* should be */
	       if (var->shvvaluelen < var->shvvalue.strlength)
		   namelen = var->shvvaluelen; /* is */
	       if (trace)
		   fprintf(stderr, "  %.*s='%.*s'\n",
			   (int)var->shvname.strlength, var->shvname.strptr,
			   namelen, var->shvvalue.strptr);
	       if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
		   PUSHs(&PL_sv_undef);
	       else
		   PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
					    namelen)));
	   }
       } else {
	   if (trace)
	       fprintf(stderr, "  rc=%#lX\n", rc);
       }
   }

void
_next(stem)
	char *	stem
 PPCODE:
   {
       SHVBLOCK sv;
       BYTE     name[4096];
       ULONG    rc;
       int      len = strlen(stem), namelen, valuelen;
       if (trace)
	   fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
       sv.shvcode = RXSHV_NEXTV;
       sv.shvnext = NULL;
       MAKERXSTRING(sv.shvvalue, NULL, 0);
       do {
	   sv.shvnamelen = sizeof name;
	   sv.shvvaluelen = 0;
	   MAKERXSTRING(sv.shvname, name, sizeof name);
	   if (sv.shvvalue.strptr) {
	       DosFreeMem(sv.shvvalue.strptr);
	       MAKERXSTRING(sv.shvvalue, NULL, 0);
	   }
	   rc = pRexxVariablePool(&sv);
       } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
       if (!rc) {
	   EXTEND(SP, 2);
	   /* returned lengths appear to be swapped */
	   /* but beware of "future bug fixes" */
	   namelen = sv.shvname.strlength; /* should be */
	   if (sv.shvnamelen < sv.shvname.strlength)
	       namelen = sv.shvnamelen; /* is */
	   valuelen = sv.shvvalue.strlength; /* should be */
	   if (sv.shvvaluelen < sv.shvvalue.strlength)
	       valuelen = sv.shvvaluelen; /* is */
	   if (trace)
	       fprintf(stderr, "  %.*s='%.*s'\n",
		       namelen, sv.shvname.strptr,
		       valuelen, sv.shvvalue.strptr);
	   PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
	   if (sv.shvvalue.strptr) {
	       PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
				DosFreeMem(sv.shvvalue.strptr);
	   } else	
	       PUSHs(&PL_sv_undef);
       } else if (rc != RXSHV_LVAR) {
	   die("Error %i when in _next", rc);
       } else {
	   if (trace)
	       fprintf(stderr, "  rc=%#lX\n", rc);
       }
   }

int
_drop(name,...)
	char *		name
 CODE:
   {
       int i;
       needvars(items);
       for (i = 0; i < items; ++i) {
	   SHVBLOCK * var = &vars[i];
	   STRLEN     namelen;
	   name = SvPV(ST(i),namelen);
	   var->shvcode = RXSHV_DROPV;
	   var->shvnext = &vars[i+1];
	   var->shvnamelen = namelen;
	   var->shvvaluelen = 0;
	   MAKERXSTRING(var->shvname, name, var->shvnamelen);
	   MAKERXSTRING(var->shvvalue, NULL, 0);
       }
       vars[items-1].shvnext = NULL;
       RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
   }
 OUTPUT:
    RETVAL

int
_register(name)
	char *	name
 CODE:
    RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
 OUTPUT:
    RETVAL

SV*
REXX_call(cv)
	SV *cv
  PROTOTYPE: &

SV*
REXX_eval(cmd)
	char *cmd

SV*
REXX_eval_with(cmd,name,cv)
	char *cmd
	char *name
	SV *cv
Commit	Line	Data
760ac839	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
	5	#define INCL_BASE
	6	#define INCL_REXXSAA
	7	#include <os2emx.h>
	8
	9	#if 0
	10	#define INCL_REXXSAA
	11	#pragma pack(1)
	12	#define _Packed
	13	#include <rexxsaa.h>
	14	#pragma pack()
	15	#endif
	16
	17	extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
	18	EXCEPTIONREGISTRATIONRECORD *,
	19	CONTEXTRECORD *,
	20	void *);
	21
	22	static RXSTRING * strs;
	23	static int nstrs;
	24	static SHVBLOCK * vars;
	25	static int nvars;
	26	static char * trace;
	27
35bc1fdc	28	/*
760ac839	29	static RXSTRING rxcommand = { 9, "RXCOMMAND" };
	30	static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
	31	static RXSTRING rxfunction = { 11, "RXFUNCTION" };
35bc1fdc	32	*/
760ac839	33
46e87256	34	static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
760ac839	35
	36	#if 1
	37	#define Set RXSHV_SET
	38	#define Fetch RXSHV_FETCH
	39	#define Drop RXSHV_DROPV
	40	#else
	41	#define Set RXSHV_SYSET
	42	#define Fetch RXSHV_SYFET
	43	#define Drop RXSHV_SYDRO
	44	#endif
	45
	46	static long incompartment;
	47
35bc1fdc	48	static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
	49	PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
	50	static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
	51	RexxFunctionHandler *);
	52	static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
	53
	54	static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
	55
760ac839	56	static SV*
41cd3736	57	exec_in_REXX(pTHX_ char cmd, char handlerName, RexxFunctionHandler *handler)
760ac839	58	{
760ac839	59	RXSTRING args[1];
	60	RXSTRING inst[2];
	61	RXSTRING result;
	62	USHORT retcode;
	63	LONG rc;
	64	SV *res;
	65
41cd3736	66	if (incompartment)
41cd3736	67	Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
760ac839	68	incompartment = 1;
760ac839	69
760ac839	70	if (handlerName)
	71	pRexxRegisterFunctionExe(handlerName, handler);
	72
	73	MAKERXSTRING(args[0], NULL, 0);
	74	MAKERXSTRING(inst[0], cmd, strlen(cmd));
	75	MAKERXSTRING(inst[1], NULL, 0);
	76	MAKERXSTRING(result, NULL, 0);
	77	rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
	78	&retcode, &result);
	79
	80	incompartment = 0;
	81	pRexxDeregisterFunction("StartPerl");
35bc1fdc	82	#if 0 /* Do we want to restore these? */
760ac839	83	DosFreeModule(hRexxAPI);
760ac839	84	DosFreeModule(hRexx);
35bc1fdc	85	#endif
760ac839	86	if (!RXNULLSTRING(result)) {
	87	res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
	88	DosFreeMem(RXSTRPTR(result));
	89	} else {
	90	res = NEWSV(729,0);
	91	}
6b88bc9c	92	if (rc \|\| SvTRUE(GvSV(PL_errgv))) {
6b88bc9c	93	if (SvTRUE(GvSV(PL_errgv))) {
2d8e6c8d	94	STRLEN n_a;
5ba48348	95	Perl_die(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
760ac839	96	}
41cd3736	97	Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
760ac839	98	}
	99
	100	return res;
	101	}
	102
	103	static SV* exec_cv;
	104
	105	static ULONG
46e87256	106	PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
760ac839	107	{
	108	return PERLCALL(NULL, argc, argv, queue, ret);
	109	}
	110
41cd3736	111	#define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \
760ac839	112	"StartPerl", PERLSTART)
	113	#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
	114	#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
41cd3736	115	exec_in_REXX(aTHX_ cmd,name,PERLSTART))
760ac839	116	#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
	117
	118	static ULONG
46e87256	119	PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
760ac839	120	{
41cd3736	121	dTHX;
760ac839	122	EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
	123	int i, rc;
	124	unsigned long len;
	125	char *str;
5ba48348	126	SV *res;
760ac839	127	dSP;
	128
	129	DosSetExceptionHandler(&xreg);
	130
	131	ENTER;
	132	SAVETMPS;
924508f0	133	PUSHMARK(SP);
760ac839	134
	135	#if 0
	136	if (!my_perl) {
	137	DosUnsetExceptionHandler(&xreg);
	138	return 1;
	139	}
	140	#endif
	141
5ba48348	142	for (i = 0; i < argc; ++i)
	143	XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
	144	PUTBACK;
760ac839	145	if (name) {
5ba48348	146	rc = perl_call_pv(name, G_SCALAR \| G_EVAL);
760ac839	147	} else if (exec_cv) {
	148	SV *cv = exec_cv;
	149
	150	exec_cv = NULL;
	151	rc = perl_call_sv(cv, G_SCALAR \| G_EVAL);
5ba48348	152	} else
5ba48348	153	rc = -1;
760ac839	154
	155	SPAGAIN;
	156
5ba48348	157	if (rc == 1) /* must be! */
	158	res = POPs;
	159	if (rc == 1 && SvOK(res)) {
	160	str = SvPVx(res, len);
	161	if (len <= 256 /* Default buffer is 256-char long */
	162	\|\| !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len,
	163	PAG_READ\|PAG_WRITE\|PAG_COMMIT))) {
	164	memcpy(ret->strptr, str, len);
	165	ret->strlength = len;
	166	} else
	167	rc = 0;
	168	} else
	169	rc = 0;
760ac839	170
	171	PUTBACK ;
	172	FREETMPS ;
	173	LEAVE ;
	174
760ac839	175	DosUnsetExceptionHandler(&xreg);
5ba48348	176	return rc == 1 ? 0 : 1; /* 0 means SUCCESS */
760ac839	177	}
	178
	179	static void
	180	needstrs(int n)
	181	{
	182	if (n > nstrs) {
	183	if (strs)
	184	free(strs);
	185	nstrs = 2 * n;
	186	strs = malloc(nstrs * sizeof(RXSTRING));
	187	}
	188	}
	189
	190	static void
	191	needvars(int n)
	192	{
	193	if (n > nvars) {
	194	if (vars)
	195	free(vars);
	196	nvars = 2 * n;
	197	vars = malloc(nvars * sizeof(SHVBLOCK));
	198	}
	199	}
	200
	201	static void
	202	initialize(void)
	203	{
35bc1fdc	204	(PFN )&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
	205	(PFN )&pRexxRegisterFunctionExe
	206	= loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
	207	(PFN )&pRexxDeregisterFunction
	208	= loadByOrdinal(ORD_RexxDeregisterFunction, 1);
	209	(PFN )&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
760ac839	210	needstrs(8);
	211	needvars(8);
	212	trace = getenv("PERL_REXX_DEBUG");
	213	}
	214
	215	static int
41cd3736	216	constant(char *name, int arg)
760ac839	217	{
	218	errno = EINVAL;
	219	return 0;
	220	}
	221
	222
	223	MODULE = OS2::REXX PACKAGE = OS2::REXX
	224
	225	BOOT:
	226	initialize();
	227
	228	int
	229	constant(name,arg)
	230	char * name
	231	int arg
	232
760ac839	233	int
	234	_set(name,value,...)
	235	char * name
	236	char * value
	237	CODE:
	238	{
	239	int i;
	240	int n = (items + 1) / 2;
	241	ULONG rc;
	242	needvars(n);
	243	if (trace)
	244	fprintf(stderr, "REXXCALL::_set");
	245	for (i = 0; i < n; ++i) {
	246	SHVBLOCK * var = &vars[i];
	247	STRLEN namelen;
	248	STRLEN valuelen;
	249	name = SvPV(ST(2*i+0),namelen);
	250	if (2*i+1 < items) {
	251	value = SvPV(ST(2*i+1),valuelen);
	252	}
	253	else {
	254	value = "";
	255	valuelen = 0;
	256	}
	257	var->shvcode = RXSHV_SET;
	258	var->shvnext = &vars[i+1];
	259	var->shvnamelen = namelen;
	260	var->shvvaluelen = valuelen;
	261	MAKERXSTRING(var->shvname, name, namelen);
	262	MAKERXSTRING(var->shvvalue, value, valuelen);
	263	if (trace)
	264	fprintf(stderr, " %.s='%.s'",
35bc1fdc	265	(int)var->shvname.strlength, var->shvname.strptr,
35bc1fdc	266	(int)var->shvvalue.strlength, var->shvvalue.strptr);
760ac839	267	}
	268	if (trace)
	269	fprintf(stderr, "\n");
	270	vars[n-1].shvnext = NULL;
35bc1fdc	271	rc = pRexxVariablePool(vars);
760ac839	272	if (trace)
35bc1fdc	273	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	274	RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
	275	}
	276	OUTPUT:
	277	RETVAL
	278
	279	void
	280	_fetch(name, ...)
	281	char * name
	282	PPCODE:
	283	{
	284	int i;
	285	ULONG rc;
924508f0	286	EXTEND(SP, items);
760ac839	287	needvars(items);
	288	if (trace)
	289	fprintf(stderr, "REXXCALL::_fetch");
	290	for (i = 0; i < items; ++i) {
	291	SHVBLOCK * var = &vars[i];
	292	STRLEN namelen;
	293	name = SvPV(ST(i),namelen);
	294	var->shvcode = RXSHV_FETCH;
	295	var->shvnext = &vars[i+1];
	296	var->shvnamelen = namelen;
	297	var->shvvaluelen = 0;
	298	MAKERXSTRING(var->shvname, name, namelen);
	299	MAKERXSTRING(var->shvvalue, NULL, 0);
	300	if (trace)
	301	fprintf(stderr, " '%s'", name);
	302	}
	303	if (trace)
	304	fprintf(stderr, "\n");
	305	vars[items-1].shvnext = NULL;
35bc1fdc	306	rc = pRexxVariablePool(vars);
760ac839	307	if (!(rc & ~RXSHV_NEWV)) {
	308	for (i = 0; i < items; ++i) {
	309	int namelen;
	310	SHVBLOCK * var = &vars[i];
	311	/* returned lengths appear to be swapped */
	312	/* but beware of "future bug fixes" */
	313	namelen = var->shvvalue.strlength; /* should be */
	314	if (var->shvvaluelen < var->shvvalue.strlength)
	315	namelen = var->shvvaluelen; /* is */
	316	if (trace)
	317	fprintf(stderr, " %.s='%.s'\n",
35bc1fdc	318	(int)var->shvname.strlength, var->shvname.strptr,
760ac839	319	namelen, var->shvvalue.strptr);
760ac839	320	if (var->shvret & RXSHV_NEWV \|\| !var->shvvalue.strptr)
6b88bc9c	321	PUSHs(&PL_sv_undef);
760ac839	322	else
	323	PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
	324	namelen)));
	325	}
	326	} else {
	327	if (trace)
35bc1fdc	328	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	329	}
	330	}
	331
	332	void
	333	_next(stem)
	334	char * stem
	335	PPCODE:
	336	{
	337	SHVBLOCK sv;
	338	BYTE name[4096];
	339	ULONG rc;
	340	int len = strlen(stem), namelen, valuelen;
	341	if (trace)
	342	fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
	343	sv.shvcode = RXSHV_NEXTV;
	344	sv.shvnext = NULL;
	345	MAKERXSTRING(sv.shvvalue, NULL, 0);
	346	do {
	347	sv.shvnamelen = sizeof name;
	348	sv.shvvaluelen = 0;
	349	MAKERXSTRING(sv.shvname, name, sizeof name);
	350	if (sv.shvvalue.strptr) {
	351	DosFreeMem(sv.shvvalue.strptr);
	352	MAKERXSTRING(sv.shvvalue, NULL, 0);
	353	}
35bc1fdc	354	rc = pRexxVariablePool(&sv);
760ac839	355	} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
760ac839	356	if (!rc) {
924508f0	357	EXTEND(SP, 2);
760ac839	358	/* returned lengths appear to be swapped */
	359	/* but beware of "future bug fixes" */
	360	namelen = sv.shvname.strlength; /* should be */
	361	if (sv.shvnamelen < sv.shvname.strlength)
	362	namelen = sv.shvnamelen; /* is */
	363	valuelen = sv.shvvalue.strlength; /* should be */
	364	if (sv.shvvaluelen < sv.shvvalue.strlength)
	365	valuelen = sv.shvvaluelen; /* is */
	366	if (trace)
	367	fprintf(stderr, " %.s='%.s'\n",
	368	namelen, sv.shvname.strptr,
	369	valuelen, sv.shvvalue.strptr);
	370	PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
	371	if (sv.shvvalue.strptr) {
	372	PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
	373	DosFreeMem(sv.shvvalue.strptr);
	374	} else
6b88bc9c	375	PUSHs(&PL_sv_undef);
760ac839	376	} else if (rc != RXSHV_LVAR) {
	377	die("Error %i when in _next", rc);
	378	} else {
	379	if (trace)
35bc1fdc	380	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	381	}
	382	}
	383
	384	int
	385	_drop(name,...)
	386	char * name
	387	CODE:
	388	{
	389	int i;
	390	needvars(items);
	391	for (i = 0; i < items; ++i) {
	392	SHVBLOCK * var = &vars[i];
	393	STRLEN namelen;
	394	name = SvPV(ST(i),namelen);
	395	var->shvcode = RXSHV_DROPV;
	396	var->shvnext = &vars[i+1];
	397	var->shvnamelen = namelen;
	398	var->shvvaluelen = 0;
	399	MAKERXSTRING(var->shvname, name, var->shvnamelen);
	400	MAKERXSTRING(var->shvvalue, NULL, 0);
	401	}
	402	vars[items-1].shvnext = NULL;
35bc1fdc	403	RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
760ac839	404	}
	405	OUTPUT:
	406	RETVAL
	407
	408	int
	409	_register(name)
	410	char * name
	411	CODE:
35bc1fdc	412	RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
760ac839	413	OUTPUT:
	414	RETVAL
	415
	416	SV*
	417	REXX_call(cv)
	418	SV *cv
	419	PROTOTYPE: &
	420
	421	SV*
	422	REXX_eval(cmd)
	423	char *cmd
	424
	425	SV*
	426	REXX_eval_with(cmd,name,cv)
	427	char *cmd
	428	char *name
	429	SV *cv