[perl5.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(PSZ name, ULONG argc, PRXSTRING argv, PSZ 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 SV*
exec_in_REXX(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;
    USHORT   retcode;
    LONG rc;
    SV *res;

    if (incompartment) die ("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);

    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");
    DosFreeModule(hRexxAPI);
    DosFreeModule(hRexx);
    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)) ;
	}
	die ("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)
{
    return PERLCALL(NULL, argc, argv, queue, ret);
}

#define in_rexx_compartment() exec_in_REXX("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))
#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)

static ULONG
PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
{
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
    int i, rc;
    unsigned long len;
    char *str;
    char **arr;
    dSP;

    DosSetExceptionHandler(&xreg);

    ENTER;
    SAVETMPS;
    PUSHMARK(sp);

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

    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);
    } 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 && 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;
    }

    PUTBACK ;
    FREETMPS ;
    LEAVE ;

    if (rc != 1) {
	DosUnsetExceptionHandler(&xreg);
	return 1;
    }


    DosUnsetExceptionHandler(&xreg);
    return 0;
}

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)
{
    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;
{
    errno = EINVAL;
    return 0;
}


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

BOOT:
	initialize();

int
constant(name,arg)
	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
	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'",
		       var->shvname.strlength, var->shvname.strptr,
		       var->shvvalue.strlength, var->shvvalue.strptr);
       }
       if (trace)
	   fprintf(stderr, "\n");
       vars[n-1].shvnext = NULL;
       rc = RexxVariablePool(vars);
       if (trace)
	   fprintf(stderr, "  rc=%X\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 = RexxVariablePool(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",
			   var->shvname.strlength, var->shvname.strptr,
			   namelen, var->shvvalue.strptr);
	       if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
		   PUSHs(&sv_undef);
	       else
		   PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
					    namelen)));
	   }
       } else {
	   if (trace)
	       fprintf(stderr, "  rc=%X\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 = RexxVariablePool(&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(&sv_undef);
       } else if (rc != RXSHV_LVAR) {
	   die("Error %i when in _next", rc);
       } else {
	   if (trace)
	       fprintf(stderr, "  rc=%X\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 = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
   }
 OUTPUT:
    RETVAL

int
_register(name)
	char *	name
 CODE:
    RETVAL = RexxRegisterFunctionExe(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 LW	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
	28	static RXSTRING rxcommand = { 9, "RXCOMMAND" };
	29	static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
	30	static RXSTRING rxfunction = { 11, "RXFUNCTION" };
	31
	32	static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret);
	33
	34	#if 1
	35	#define Set RXSHV_SET
	36	#define Fetch RXSHV_FETCH
	37	#define Drop RXSHV_DROPV
	38	#else
	39	#define Set RXSHV_SYSET
	40	#define Fetch RXSHV_SYFET
	41	#define Drop RXSHV_SYDRO
	42	#endif
	43
	44	static long incompartment;
	45
	46	static SV*
	47	exec_in_REXX(char cmd, char handlerName, RexxFunctionHandler *handler)
	48	{
dd96f567	49	dTHR;
760ac839 LW	50	HMODULE hRexx, hRexxAPI;
	51	BYTE buf[200];
	52	LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
	53	PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
	54	APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
	55	RexxFunctionHandler *);
	56	APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
	57	RXSTRING args[1];
	58	RXSTRING inst[2];
	59	RXSTRING result;
	60	USHORT retcode;
	61	LONG rc;
	62	SV *res;
	63
	64	if (incompartment) die ("Attempt to reenter into REXX compartment");
	65	incompartment = 1;
	66
	67	if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
	68	\|\| DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
	69	\|\| DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
	70	\|\| DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
	71	(PFN *)&pRexxRegisterFunctionExe)
	72	\|\| DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
	73	(PFN *)&pRexxDeregisterFunction)) {
	74	die("REXX not available\n");
	75	}
	76
	77	if (handlerName)
	78	pRexxRegisterFunctionExe(handlerName, handler);
	79
	80	MAKERXSTRING(args[0], NULL, 0);
	81	MAKERXSTRING(inst[0], cmd, strlen(cmd));
	82	MAKERXSTRING(inst[1], NULL, 0);
	83	MAKERXSTRING(result, NULL, 0);
	84	rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
	85	&retcode, &result);
	86
	87	incompartment = 0;
	88	pRexxDeregisterFunction("StartPerl");
	89	DosFreeModule(hRexxAPI);
	90	DosFreeModule(hRexx);
	91	if (!RXNULLSTRING(result)) {
	92	res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
	93	DosFreeMem(RXSTRPTR(result));
	94	} else {
	95	res = NEWSV(729,0);
	96	}
	97	if (rc \|\| SvTRUE(GvSV(errgv))) {
	98	if (SvTRUE(GvSV(errgv))) {
	99	die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ;
	100	}
	101	die ("REXX compartment returned non-zero status %li", rc);
	102	}
	103
	104	return res;
	105	}
	106
	107	static SV* exec_cv;
	108
	109	static ULONG
	110	PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
	111	{
	112	return PERLCALL(NULL, argc, argv, queue, ret);
	113	}
114
115	#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \
116	"StartPerl", PERLSTART)
117	#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
118	#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
119	exec_in_REXX(cmd,name,PERLSTART))
120	#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
121
122	static ULONG
123	PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
124	{
125	EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
126	int i, rc;
127	unsigned long len;
128	char *str;
129	char **arr;
130	dSP;
131
132	DosSetExceptionHandler(&xreg);
133
134	ENTER;
135	SAVETMPS;
136	PUSHMARK(sp);
137
138	#if 0
139	if (!my_perl) {
140	DosUnsetExceptionHandler(&xreg);
141	return 1;
142	}
143	#endif
144
145	if (name) {
146	int ac = 0;
147	char *arr = alloca((argc + 1) sizeof(char *));
148
149	for (i = 0; i < argc; ++i)
150	arr[ac++] = argv[i].strptr;
151	arr[ac] = NULL;
152
153	rc = perl_call_argv(name, G_SCALAR \| G_EVAL, arr);
154	} else if (exec_cv) {
155	SV *cv = exec_cv;
156
157	exec_cv = NULL;
158	rc = perl_call_sv(cv, G_SCALAR \| G_EVAL);
159	} else rc = -1;
160
161	SPAGAIN;
162
163	if (rc == 1 && SvOK(TOPs)) {
164	str = SvPVx(POPs, len);
165	if (len > 256)
166	if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
167	DosUnsetExceptionHandler(&xreg);
168	return 1;
169	}
170	memcpy(ret->strptr, str, len);
171	ret->strlength = len;
172	}
173
174	PUTBACK ;
175	FREETMPS ;
176	LEAVE ;
177
178	if (rc != 1) {
179	DosUnsetExceptionHandler(&xreg);
180	return 1;
181	}
182
183
184	DosUnsetExceptionHandler(&xreg);
185	return 0;
186	}
187
188	static void
189	needstrs(int n)
190	{
191	if (n > nstrs) {
192	if (strs)
193	free(strs);
194	nstrs = 2 * n;
195	strs = malloc(nstrs * sizeof(RXSTRING));
196	}
197	}
198
199	static void
200	needvars(int n)
201	{
202	if (n > nvars) {
203	if (vars)
204	free(vars);
205	nvars = 2 * n;
206	vars = malloc(nvars * sizeof(SHVBLOCK));
207	}
208	}
209
210	static void
211	initialize(void)
212	{
213	needstrs(8);
214	needvars(8);
215	trace = getenv("PERL_REXX_DEBUG");
216	}
217
218	static int
219	not_here(s)
220	char *s;
221	{
222	croak("%s not implemented on this architecture", s);
223	return -1;
224	}
225
226	static int
227	constant(name, arg)
228	char *name;
229	int arg;
230	{
231	errno = EINVAL;
232	return 0;
233	}
234
235
236	MODULE = OS2::REXX PACKAGE = OS2::REXX
237
238	BOOT:
239	initialize();
240
241	int
242	constant(name,arg)
243	char * name
244	int arg
245
246	SV *
247	_call(name, address, queue="SESSION", ...)
248	char * name
249	void * address
250	char * queue
251	CODE:
252	{
253	ULONG rc;
254	int argc, i;
255	RXSTRING result;
256	UCHAR resbuf[256];
257	RexxFunctionHandler *fcn = address;
258	argc = items-3;
259	needstrs(argc);
260	if (trace)
261	fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
262	for (i = 0; i < argc; ++i) {
263	STRLEN len;
264	char *ptr = SvPV(ST(3+i), len);
265	MAKERXSTRING(strs[i], ptr, len);
266	if (trace)
267	fprintf(stderr, " '%.*s'", len, ptr);
268	}
269	if (!*queue)
270	queue = "SESSION";
271	if (trace)
272	fprintf(stderr, "\n");
273	MAKERXSTRING(result, resbuf, sizeof resbuf);
274	rc = fcn(name, argc, strs, queue, &result);
275	if (trace)
276	fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
277	result.strlength, result.strptr);
278	ST(0) = sv_newmortal();
279	if (rc == 0) {
280	if (result.strptr)
281	sv_setpvn(ST(0), result.strptr, result.strlength);
282	else
283	sv_setpvn(ST(0), "", 0);
284	}
285	if (result.strptr && result.strptr != resbuf)
286	DosFreeMem(result.strptr);
287	}
288
289	int
290	_set(name,value,...)
291	char * name
292	char * value
293	CODE:
294	{
295	int i;
296	int n = (items + 1) / 2;
297	ULONG rc;
298	needvars(n);
299	if (trace)
300	fprintf(stderr, "REXXCALL::_set");
301	for (i = 0; i < n; ++i) {
302	SHVBLOCK * var = &vars[i];
303	STRLEN namelen;
304	STRLEN valuelen;
305	name = SvPV(ST(2*i+0),namelen);
306	if (2*i+1 < items) {
307	value = SvPV(ST(2*i+1),valuelen);
308	}
309	else {
310	value = "";
311	valuelen = 0;
312	}
313	var->shvcode = RXSHV_SET;
314	var->shvnext = &vars[i+1];
315	var->shvnamelen = namelen;
316	var->shvvaluelen = valuelen;
317	MAKERXSTRING(var->shvname, name, namelen);
318	MAKERXSTRING(var->shvvalue, value, valuelen);
319	if (trace)
320	fprintf(stderr, " %.s='%.s'",
321	var->shvname.strlength, var->shvname.strptr,
322	var->shvvalue.strlength, var->shvvalue.strptr);
323	}
324	if (trace)
325	fprintf(stderr, "\n");
326	vars[n-1].shvnext = NULL;
327	rc = RexxVariablePool(vars);
328	if (trace)
329	fprintf(stderr, " rc=%X\n", rc);
330	RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
331	}
332	OUTPUT:
333	RETVAL
334
335	void
336	_fetch(name, ...)
337	char * name
338	PPCODE:
339	{
340	int i;
341	ULONG rc;
342	EXTEND(sp, items);
343	needvars(items);
344	if (trace)
345	fprintf(stderr, "REXXCALL::_fetch");
346	for (i = 0; i < items; ++i) {
347	SHVBLOCK * var = &vars[i];
348	STRLEN namelen;
349	name = SvPV(ST(i),namelen);
350	var->shvcode = RXSHV_FETCH;
351	var->shvnext = &vars[i+1];
352	var->shvnamelen = namelen;
353	var->shvvaluelen = 0;
354	MAKERXSTRING(var->shvname, name, namelen);
355	MAKERXSTRING(var->shvvalue, NULL, 0);
356	if (trace)
357	fprintf(stderr, " '%s'", name);
358	}
359	if (trace)
360	fprintf(stderr, "\n");
361	vars[items-1].shvnext = NULL;
362	rc = RexxVariablePool(vars);
363	if (!(rc & ~RXSHV_NEWV)) {
364	for (i = 0; i < items; ++i) {
365	int namelen;
366	SHVBLOCK * var = &vars[i];
367	/* returned lengths appear to be swapped */
368	/* but beware of "future bug fixes" */
369	namelen = var->shvvalue.strlength; /* should be */
370	if (var->shvvaluelen < var->shvvalue.strlength)
371	namelen = var->shvvaluelen; /* is */
372	if (trace)
373	fprintf(stderr, " %.s='%.s'\n",
374	var->shvname.strlength, var->shvname.strptr,
375	namelen, var->shvvalue.strptr);
376	if (var->shvret & RXSHV_NEWV \|\| !var->shvvalue.strptr)
377	PUSHs(&sv_undef);
378	else
379	PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
380	namelen)));
381	}
382	} else {
383	if (trace)
384	fprintf(stderr, " rc=%X\n", rc);
385	}
386	}
387
388	void
389	_next(stem)
390	char * stem
391	PPCODE:
392	{
393	SHVBLOCK sv;
394	BYTE name[4096];
395	ULONG rc;
396	int len = strlen(stem), namelen, valuelen;
397	if (trace)
398	fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
399	sv.shvcode = RXSHV_NEXTV;
400	sv.shvnext = NULL;
401	MAKERXSTRING(sv.shvvalue, NULL, 0);
402	do {
403	sv.shvnamelen = sizeof name;
404	sv.shvvaluelen = 0;
405	MAKERXSTRING(sv.shvname, name, sizeof name);
406	if (sv.shvvalue.strptr) {
407	DosFreeMem(sv.shvvalue.strptr);
408	MAKERXSTRING(sv.shvvalue, NULL, 0);
409	}
410	rc = RexxVariablePool(&sv);
411	} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
412	if (!rc) {
413	EXTEND(sp, 2);
414	/* returned lengths appear to be swapped */
415	/* but beware of "future bug fixes" */
416	namelen = sv.shvname.strlength; /* should be */
417	if (sv.shvnamelen < sv.shvname.strlength)
418	namelen = sv.shvnamelen; /* is */
419	valuelen = sv.shvvalue.strlength; /* should be */
420	if (sv.shvvaluelen < sv.shvvalue.strlength)
421	valuelen = sv.shvvaluelen; /* is */
422	if (trace)
423	fprintf(stderr, " %.s='%.s'\n",
424	namelen, sv.shvname.strptr,
425	valuelen, sv.shvvalue.strptr);
426	PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
427	if (sv.shvvalue.strptr) {
428	PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
429	DosFreeMem(sv.shvvalue.strptr);
430	} else
431	PUSHs(&sv_undef);
432	} else if (rc != RXSHV_LVAR) {
433	die("Error %i when in _next", rc);
434	} else {
435	if (trace)
436	fprintf(stderr, " rc=%X\n", rc);
437	}
438	}
439
440	int
441	_drop(name,...)
442	char * name
443	CODE:
444	{
445	int i;
446	needvars(items);
447	for (i = 0; i < items; ++i) {
448	SHVBLOCK * var = &vars[i];
449	STRLEN namelen;
450	name = SvPV(ST(i),namelen);
451	var->shvcode = RXSHV_DROPV;
452	var->shvnext = &vars[i+1];
453	var->shvnamelen = namelen;
454	var->shvvaluelen = 0;
455	MAKERXSTRING(var->shvname, name, var->shvnamelen);
456	MAKERXSTRING(var->shvvalue, NULL, 0);
457	}
458	vars[items-1].shvnext = NULL;
459	RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
460	}
461	OUTPUT:
462	RETVAL
463
464	int
465	_register(name)
466	char * name
467	CODE:
468	RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
469	OUTPUT:
470	RETVAL
471
472	SV*
473	REXX_call(cv)
474	SV *cv
475	PROTOTYPE: &
476
477	SV*
478	REXX_eval(cmd)
479	char *cmd
480
481	SV*
482	REXX_eval_with(cmd,name,cv)
483	char *cmd
484	char *name
485	SV *cv