[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(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 (*pRexxRegisterSubcomExe)  (PCSZ pszEnvName, PFN pfnEntryPoint,
    PUCHAR pUserArea);
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, have_nl = 0;
    char *ocmd = cmd, *s, *t;

    incompartment++;

    if (c)
	Newxz(subs, c, char);
    while (n--) {
	rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]);
	if (rc == RXFUNC_DEFINED)
	    subs[n] = 1;
    }

    s = cmd;
    while (*s) {
	if (*s == '\n') {		/* Is not preceeded by \r! */
	    Newx(cmd, 2*strlen(cmd)+1, char);
	    s = ocmd;
	    t = cmd;
	    while (*s) {
		if (*s == '\n')
		    *t++ = '\r';
		*t++ = *s++;
	    }
	    *t = 0;
	    break;
	} else if (*s == '\r')
	    s++;
	s++;
    }
    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 (cmd != ocmd)
	Safefree(cmd);
#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);
    *(PFN *)&pRexxRegisterSubcomExe
	= loadByOrdinal(ORD_RexxRegisterSubcomExe, 1);
    needstrs(8);
    needvars(8);
    trace = getenv("PERL_REXX_DEBUG");
     
    rc = pRexxRegisterSubcomExe("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()");
	Newx(names, n, char*);
	Newx(cvs, n, SV*);
	/* XXX Unfinished... */
	RETVAL = Nullsv;
	Safefree(names);
	Safefree(cvs);
   }
 OUTPUT:
    RETVAL

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