[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);
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 Fetch	RXSHV_FETCH
 #define Drop	RXSHV_DROPV
#else
 #define Set	RXSHV_SYSET
 #define Fetch	RXSHV_SYFET
 #define Drop	RXSHV_SYDRO
#endif

static long incompartment;	/* May be used to unload the REXX */

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_cv;

/* Create a REXX compartment,
   register `n' callbacks `handlers' with the REXX names `handlerNames',
   evaluate the REXX expression `cmd'.
 */
static SV*
exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers)
{
    RXSTRING args[1];
    RXSTRING inst[2];
    RXSTRING result;
    USHORT   retcode;
    LONG rc;
    SV *res;
    char *subs = 0;
    int n = c;

    incompartment++;

    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,		/* 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--;
    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));
    } else {
	res = NEWSV(729,0);
    }
    if (rc || SvTRUE(GvSV(PL_errgv))) {
	if (SvTRUE(GvSV(PL_errgv))) {
	    STRLEN n_a;
	    Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
	}
	Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc);
    }

    return res;
}

/* 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
PERLCALLcv(PCSZ name, SV *cv, 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 (cv)
	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 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)
{
    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)
{
    ULONG rc;
    *(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");
     
    rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL);
}

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

#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
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);
9e2a34c1	35	static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
	36	static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
	37	static RexxSubcomHandler SubCommandPerlEval;
760ac839	38
	39	#if 1
	40	#define Set RXSHV_SET
	41	#define Fetch RXSHV_FETCH
	42	#define Drop RXSHV_DROPV
	43	#else
	44	#define Set RXSHV_SYSET
	45	#define Fetch RXSHV_SYFET
	46	#define Drop RXSHV_SYDRO
	47	#endif
	48
9e2a34c1	49	static long incompartment; /* May be used to unload the REXX */
760ac839	50
35bc1fdc	51	static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
	52	PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
	53	static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
	54	RexxFunctionHandler *);
	55	static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
	56
	57	static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
	58
9e2a34c1	59	static SV* exec_cv;
	60
	61	/* Create a REXX compartment,
	62	register `n' callbacks `handlers' with the REXX names `handlerNames',
	63	evaluate the REXX expression `cmd'.
	64	*/
760ac839	65	static SV*
9e2a34c1	66	exec_in_REXX_with(pTHX_ char cmd, int c, char handlerNames, RexxFunctionHandler *handlers)
760ac839	67	{
760ac839	68	RXSTRING args[1];
	69	RXSTRING inst[2];
	70	RXSTRING result;
	71	USHORT retcode;
	72	LONG rc;
	73	SV *res;
9e2a34c1	74	char *subs = 0;
9e2a34c1	75	int n = c;
760ac839	76
9e2a34c1	77	incompartment++;
760ac839	78
9e2a34c1	79	if (c)
	80	Newz(728, subs, c, char);
	81	while (n--) {
	82	rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]);
	83	if (rc == RXFUNC_DEFINED)
	84	subs[n] = 1;
	85	}
760ac839	86
	87	MAKERXSTRING(args[0], NULL, 0);
	88	MAKERXSTRING(inst[0], cmd, strlen(cmd));
	89	MAKERXSTRING(inst[1], NULL, 0);
	90	MAKERXSTRING(result, NULL, 0);
9e2a34c1	91	rc = pRexxStart(0, args, /* No arguments */
	92	"REXX_in_Perl", /* Returned on REXX' PARSE SOURCE,
	93	and the "macrospace function name" */
	94	inst, /* inst[0] - the code to execute,
	95	inst[1] will contain tokens. */
	96	"Perl", /* Pass string-cmds to this callback */
	97	RXSUBROUTINE, /* Many arguments, maybe result */
	98	NULL, /* No callbacks/exits to register */
760ac839	99	&retcode, &result);
760ac839	100
9e2a34c1	101	incompartment--;
	102	n = c;
	103	while (n--)
	104	if (!subs[n])
	105	pRexxDeregisterFunction(handlerNames[n]);
	106	if (c)
	107	Safefree(subs);
35bc1fdc	108	#if 0 /* Do we want to restore these? */
760ac839	109	DosFreeModule(hRexxAPI);
760ac839	110	DosFreeModule(hRexx);
35bc1fdc	111	#endif
9e2a34c1	112
	113	if (RXSTRPTR(inst[1])) /* Free the tokenized version */
	114	DosFreeMem(RXSTRPTR(inst[1]));
760ac839	115	if (!RXNULLSTRING(result)) {
	116	res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
	117	DosFreeMem(RXSTRPTR(result));
	118	} else {
	119	res = NEWSV(729,0);
	120	}
6b88bc9c	121	if (rc \|\| SvTRUE(GvSV(PL_errgv))) {
6b88bc9c	122	if (SvTRUE(GvSV(PL_errgv))) {
2d8e6c8d	123	STRLEN n_a;
9e2a34c1	124	Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
760ac839	125	}
9e2a34c1	126	Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc);
760ac839	127	}
	128
	129	return res;
	130	}
	131
9e2a34c1	132	/* Call the Perl function given by name, or if name=0, by cv,
9e2a34c1	133	with the given arguments. Return the stringified result to REXX. */
760ac839	134	static ULONG
9e2a34c1	135	PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
760ac839	136	{
41cd3736	137	dTHX;
760ac839	138	EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
	139	int i, rc;
	140	unsigned long len;
	141	char *str;
5ba48348	142	SV *res;
760ac839	143	dSP;
	144
	145	DosSetExceptionHandler(&xreg);
	146
	147	ENTER;
	148	SAVETMPS;
924508f0	149	PUSHMARK(SP);
760ac839	150
	151	#if 0
	152	if (!my_perl) {
	153	DosUnsetExceptionHandler(&xreg);
	154	return 1;
	155	}
	156	#endif
	157
5ba48348	158	for (i = 0; i < argc; ++i)
	159	XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
	160	PUTBACK;
9e2a34c1	161	if (name)
5ba48348	162	rc = perl_call_pv(name, G_SCALAR \| G_EVAL);
9e2a34c1	163	else if (cv)
760ac839	164	rc = perl_call_sv(cv, G_SCALAR \| G_EVAL);
9e2a34c1	165	else
5ba48348	166	rc = -1;
760ac839	167
	168	SPAGAIN;
	169
5ba48348	170	if (rc == 1) /* must be! */
	171	res = POPs;
	172	if (rc == 1 && SvOK(res)) {
	173	str = SvPVx(res, len);
	174	if (len <= 256 /* Default buffer is 256-char long */
	175	\|\| !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len,
	176	PAG_READ\|PAG_WRITE\|PAG_COMMIT))) {
	177	memcpy(ret->strptr, str, len);
	178	ret->strlength = len;
	179	} else
	180	rc = 0;
	181	} else
	182	rc = 0;
760ac839	183
	184	PUTBACK ;
	185	FREETMPS ;
	186	LEAVE ;
	187
760ac839	188	DosUnsetExceptionHandler(&xreg);
5ba48348	189	return rc == 1 ? 0 : 1; /* 0 means SUCCESS */
760ac839	190	}
760ac839	191
9e2a34c1	192	static ULONG
	193	PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
	194	{
	195	SV *cv = exec_cv;
	196
	197	exec_cv = NULL;
	198	return PERLCALLcv(NULL, cv, argc, argv, queue, ret);
	199	}
	200
	201	static ULONG
	202	PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
	203	{
	204	return PERLCALLcv(name, Nullsv, argc, argv, queue, ret);
	205	}
	206
	207	RexxFunctionHandler* PF = &PERLSTART;
	208	char* PF_name = "StartPerl";
	209
	210	#define REXX_eval_with(cmd,name,cv) \
	211	( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF))
	212	#define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv))
	213	#define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL))
	214
	215	static ULONG
	216	SubCommandPerlEval(
	217	PRXSTRING command, /* command to issue */
	218	PUSHORT flags, /* error/failure flags */
	219	PRXSTRING retstr ) /* return code */
	220	{
	221	dSP;
	222	STRLEN len;
	223	int ret;
	224	char *str = 0;
	225	SV in, res;
	226
	227	ENTER;
	228	SAVETMPS;
	229
	230	PUSHMARK(SP);
	231	in = sv_2mortal(newSVpvn(command->strptr, command->strlength));
	232	eval_sv(in, G_SCALAR);
	233	SPAGAIN;
	234	res = POPs;
	235	PUTBACK;
	236
	237	ret = 0;
	238	if (SvTRUE(ERRSV)) {
	239	flags = RXSUBCOM_ERROR; / raise error condition */
	240	str = SvPV(ERRSV, len);
	241	} else if (!SvOK(res)) {
	242	flags = RXSUBCOM_ERROR; / raise error condition */
	243	str = "undefined value returned by Perl-in-REXX";
	244	len = strlen(str);
	245	} else
	246	str = SvPV(res, len);
	247	if (len <= 256 /* Default buffer is 256-char long */
	248	\|\| !DosAllocMem((PPVOID)&retstr->strptr, len,
	249	PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
	250	memcpy(retstr->strptr, str, len);
	251	retstr->strlength = len;
	252	} else {
	253	flags = RXSUBCOM_ERROR; / raise error condition */
	254	strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX");
	255	retstr->strlength = strlen(retstr->strptr);
256	}
257
258	FREETMPS;
259	LEAVE;
260
261	return 0; /* finished */
262	}
263
760ac839	264	static void
	265	needstrs(int n)
	266	{
	267	if (n > nstrs) {
	268	if (strs)
	269	free(strs);
	270	nstrs = 2 * n;
	271	strs = malloc(nstrs * sizeof(RXSTRING));
	272	}
	273	}
	274
	275	static void
	276	needvars(int n)
	277	{
	278	if (n > nvars) {
	279	if (vars)
	280	free(vars);
	281	nvars = 2 * n;
	282	vars = malloc(nvars * sizeof(SHVBLOCK));
	283	}
	284	}
	285
	286	static void
	287	initialize(void)
	288	{
9e2a34c1	289	ULONG rc;
35bc1fdc	290	(PFN )&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
	291	(PFN )&pRexxRegisterFunctionExe
	292	= loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
	293	(PFN )&pRexxDeregisterFunction
	294	= loadByOrdinal(ORD_RexxDeregisterFunction, 1);
	295	(PFN )&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
760ac839	296	needstrs(8);
	297	needvars(8);
	298	trace = getenv("PERL_REXX_DEBUG");
9e2a34c1	299
9e2a34c1	300	rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL);
760ac839	301	}
	302
	303	static int
41cd3736	304	constant(char *name, int arg)
760ac839	305	{
	306	errno = EINVAL;
	307	return 0;
	308	}
	309
	310
	311	MODULE = OS2::REXX PACKAGE = OS2::REXX
	312
	313	BOOT:
	314	initialize();
	315
	316	int
	317	constant(name,arg)
	318	char * name
	319	int arg
	320
760ac839	321	int
	322	_set(name,value,...)
	323	char * name
	324	char * value
	325	CODE:
	326	{
	327	int i;
	328	int n = (items + 1) / 2;
	329	ULONG rc;
	330	needvars(n);
	331	if (trace)
	332	fprintf(stderr, "REXXCALL::_set");
	333	for (i = 0; i < n; ++i) {
	334	SHVBLOCK * var = &vars[i];
	335	STRLEN namelen;
	336	STRLEN valuelen;
	337	name = SvPV(ST(2*i+0),namelen);
	338	if (2*i+1 < items) {
	339	value = SvPV(ST(2*i+1),valuelen);
	340	}
	341	else {
	342	value = "";
	343	valuelen = 0;
	344	}
	345	var->shvcode = RXSHV_SET;
	346	var->shvnext = &vars[i+1];
	347	var->shvnamelen = namelen;
	348	var->shvvaluelen = valuelen;
	349	MAKERXSTRING(var->shvname, name, namelen);
	350	MAKERXSTRING(var->shvvalue, value, valuelen);
	351	if (trace)
	352	fprintf(stderr, " %.s='%.s'",
35bc1fdc	353	(int)var->shvname.strlength, var->shvname.strptr,
35bc1fdc	354	(int)var->shvvalue.strlength, var->shvvalue.strptr);
760ac839	355	}
	356	if (trace)
	357	fprintf(stderr, "\n");
	358	vars[n-1].shvnext = NULL;
35bc1fdc	359	rc = pRexxVariablePool(vars);
760ac839	360	if (trace)
35bc1fdc	361	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	362	RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
	363	}
	364	OUTPUT:
	365	RETVAL
	366
	367	void
	368	_fetch(name, ...)
	369	char * name
	370	PPCODE:
	371	{
	372	int i;
	373	ULONG rc;
924508f0	374	EXTEND(SP, items);
760ac839	375	needvars(items);
	376	if (trace)
	377	fprintf(stderr, "REXXCALL::_fetch");
	378	for (i = 0; i < items; ++i) {
	379	SHVBLOCK * var = &vars[i];
	380	STRLEN namelen;
	381	name = SvPV(ST(i),namelen);
	382	var->shvcode = RXSHV_FETCH;
	383	var->shvnext = &vars[i+1];
	384	var->shvnamelen = namelen;
	385	var->shvvaluelen = 0;
	386	MAKERXSTRING(var->shvname, name, namelen);
	387	MAKERXSTRING(var->shvvalue, NULL, 0);
	388	if (trace)
	389	fprintf(stderr, " '%s'", name);
	390	}
	391	if (trace)
	392	fprintf(stderr, "\n");
	393	vars[items-1].shvnext = NULL;
35bc1fdc	394	rc = pRexxVariablePool(vars);
760ac839	395	if (!(rc & ~RXSHV_NEWV)) {
	396	for (i = 0; i < items; ++i) {
	397	int namelen;
	398	SHVBLOCK * var = &vars[i];
	399	/* returned lengths appear to be swapped */
	400	/* but beware of "future bug fixes" */
	401	namelen = var->shvvalue.strlength; /* should be */
	402	if (var->shvvaluelen < var->shvvalue.strlength)
	403	namelen = var->shvvaluelen; /* is */
	404	if (trace)
	405	fprintf(stderr, " %.s='%.s'\n",
35bc1fdc	406	(int)var->shvname.strlength, var->shvname.strptr,
760ac839	407	namelen, var->shvvalue.strptr);
760ac839	408	if (var->shvret & RXSHV_NEWV \|\| !var->shvvalue.strptr)
6b88bc9c	409	PUSHs(&PL_sv_undef);
760ac839	410	else
	411	PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
	412	namelen)));
	413	}
	414	} else {
	415	if (trace)
35bc1fdc	416	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	417	}
	418	}
	419
	420	void
	421	_next(stem)
	422	char * stem
	423	PPCODE:
	424	{
	425	SHVBLOCK sv;
	426	BYTE name[4096];
	427	ULONG rc;
	428	int len = strlen(stem), namelen, valuelen;
	429	if (trace)
	430	fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
	431	sv.shvcode = RXSHV_NEXTV;
	432	sv.shvnext = NULL;
	433	MAKERXSTRING(sv.shvvalue, NULL, 0);
	434	do {
	435	sv.shvnamelen = sizeof name;
	436	sv.shvvaluelen = 0;
	437	MAKERXSTRING(sv.shvname, name, sizeof name);
	438	if (sv.shvvalue.strptr) {
	439	DosFreeMem(sv.shvvalue.strptr);
	440	MAKERXSTRING(sv.shvvalue, NULL, 0);
	441	}
35bc1fdc	442	rc = pRexxVariablePool(&sv);
760ac839	443	} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
760ac839	444	if (!rc) {
924508f0	445	EXTEND(SP, 2);
760ac839	446	/* returned lengths appear to be swapped */
	447	/* but beware of "future bug fixes" */
	448	namelen = sv.shvname.strlength; /* should be */
	449	if (sv.shvnamelen < sv.shvname.strlength)
	450	namelen = sv.shvnamelen; /* is */
	451	valuelen = sv.shvvalue.strlength; /* should be */
	452	if (sv.shvvaluelen < sv.shvvalue.strlength)
	453	valuelen = sv.shvvaluelen; /* is */
	454	if (trace)
	455	fprintf(stderr, " %.s='%.s'\n",
	456	namelen, sv.shvname.strptr,
	457	valuelen, sv.shvvalue.strptr);
	458	PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
	459	if (sv.shvvalue.strptr) {
	460	PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
	461	DosFreeMem(sv.shvvalue.strptr);
	462	} else
6b88bc9c	463	PUSHs(&PL_sv_undef);
760ac839	464	} else if (rc != RXSHV_LVAR) {
	465	die("Error %i when in _next", rc);
	466	} else {
	467	if (trace)
35bc1fdc	468	fprintf(stderr, " rc=%#lX\n", rc);
760ac839	469	}
	470	}
	471
	472	int
	473	_drop(name,...)
	474	char * name
	475	CODE:
	476	{
	477	int i;
	478	needvars(items);
	479	for (i = 0; i < items; ++i) {
	480	SHVBLOCK * var = &vars[i];
	481	STRLEN namelen;
	482	name = SvPV(ST(i),namelen);
	483	var->shvcode = RXSHV_DROPV;
	484	var->shvnext = &vars[i+1];
	485	var->shvnamelen = namelen;
	486	var->shvvaluelen = 0;
	487	MAKERXSTRING(var->shvname, name, var->shvnamelen);
	488	MAKERXSTRING(var->shvvalue, NULL, 0);
	489	}
	490	vars[items-1].shvnext = NULL;
35bc1fdc	491	RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
760ac839	492	}
	493	OUTPUT:
	494	RETVAL
	495
	496	int
	497	_register(name)
	498	char * name
	499	CODE:
35bc1fdc	500	RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
760ac839	501	OUTPUT:
	502	RETVAL
	503
	504	SV*
	505	REXX_call(cv)
	506	SV *cv
	507	PROTOTYPE: &
	508
	509	SV*
	510	REXX_eval(cmd)
	511	char *cmd
	512
	513	SV*
	514	REXX_eval_with(cmd,name,cv)
	515	char *cmd
	516	char *name
	517	SV *cv
9e2a34c1	518
	519	#ifdef THIS_IS_NOT_FINISHED
	520
	521	SV*
	522	_REXX_eval_with(cmd,...)
	523	char *cmd
	524	CODE:
	525	{
	526	int n = (items - 1)/2;
	527	char **names;
	528	SV **cvs;
	529
	530	if ((items % 2) == 0)
	531	Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()");
	532	New(730, names, n, char*);
	533	New(730, cvs, n, SV*);
	534	/* XXX Unfinished... */
	535	RETVAL = Nullsv;
	536	Safefree(names);
	537	Safefree(cvs);
	538	}
	539	OUTPUT:
	540	RETVAL
	541
	542	#endif