[p5sagit/p5-mst-13.2.git] / os2 / perlrexx.c

#define INCL_DOSPROCESS
#define INCL_DOSSEMAPHORES
#define INCL_DOSMODULEMGR
#define INCL_DOSMISC
#define INCL_DOSEXCEPTIONS
#define INCL_DOSERRORS
#define INCL_REXXSAA
#include <os2.h>

/*
 * "The Road goes ever on and on, down from the door where it began."
 */

#ifdef OEMVS
#ifdef MYMALLOC
/* sbrk is limited to first heap segement so make it big */
#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#else
#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
#endif
#endif


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

static void xs_init (pTHX);
static PerlInterpreter *my_perl;

ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);

#if defined (__MINT__) || defined (atarist)
/* The Atari operating system doesn't have a dynamic stack.  The
   stack size is determined from this value.  */
long _stksize = 64 * 1024;
#endif

/* Register any extra external extensions */

/* Do not delete this line--writemain depends on it */
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);

static void
xs_init(pTHX)
{
    char *file = __FILE__;
    dXSUB_SYS;
        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}

int perlos2_is_inited;

static void
init_perlos2(void)
{
/*    static char *env[1] = {NULL};	*/

    Perl_OS2_init3(0, 0, 0);
}

static int
init_perl(int doparse)
{
    int exitstatus;
    char *argv[3] = {"perl_in_REXX", "-e", ""};

    if (!perlos2_is_inited) {
	perlos2_is_inited = 1;
	init_perlos2();
    }
    if (my_perl)
	return 1;
    if (!PL_do_undump) {
	my_perl = perl_alloc();
	if (!my_perl)
	    return 0;
	perl_construct(my_perl);
	PL_perl_destruct_level = 1;
    }
    if (!doparse)
        return 1;
    exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
    return !exitstatus;
}

static char last_error[4096];

static int
seterr(char *format, ...)
{
	va_list va;
	char *s = last_error;

	va_start(va, format);
	if (s[0]) {
	    s += strlen(s);
	    if (s[-1] != '\n') {
		snprintf(s, sizeof(last_error) - (s - last_error), "\n");
		s += strlen(s);
	    }
	}
	vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
	return 1;
}

/* The REXX-callable entrypoints ... */

ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    int exitstatus;
    char buf[256];
    char *argv[3] = {"perl_from_REXX", "-e", buf};
    ULONG ret;

    if (rargc != 1)
	return seterr("one argument expected, got %ld", rargc);
    if (rargv[0].strlength >= sizeof(buf))
	return seterr("length of the argument %ld exceeds the maximum %ld",
		      rargv[0].strlength, (long)sizeof(buf) - 1);

    if (!init_perl(0))
	return 1;

    memcpy(buf, rargv[0].strptr, rargv[0].strlength);
    buf[rargv[0].strlength] = 0;
    
    exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
    if (!exitstatus) {
	exitstatus = perl_run(my_perl);
    }

    perl_destruct(my_perl);
    perl_free(my_perl);
    my_perl = 0;

    if (exitstatus)
	ret = 1;
    else {
	ret = 0;
	sprintf(retstr->strptr, "%s", "ok");
	retstr->strlength = strlen (retstr->strptr);
    }
    PERL_SYS_TERM1(0);
    return ret;
}

ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    if (rargc != 0)
	return seterr("no arguments expected, got %ld", rargc);
    PERL_SYS_TERM1(0);
    return 0;
}

ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    if (rargc != 0)
	return seterr("no arguments expected, got %ld", rargc);
    if (!my_perl)
	return seterr("no perl interpreter present");
    perl_destruct(my_perl);
    perl_free(my_perl);
    my_perl = 0;

    sprintf(retstr->strptr, "%s", "ok");
    retstr->strlength = strlen (retstr->strptr);
    return 0;
}


ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    if (rargc != 0)
	return seterr("no argument expected, got %ld", rargc);
    if (!init_perl(1))
	return 1;

    sprintf(retstr->strptr, "%s", "ok");
    retstr->strlength = strlen (retstr->strptr);
    return 0;
}

ULONG
PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
{
    int len = strlen(last_error);

    if (len <= 256			/* Default buffer is 256-char long */
	|| !DosAllocMem((PPVOID)&retstr->strptr, len,
			PAG_READ|PAG_WRITE|PAG_COMMIT)) {
	    memcpy(retstr->strptr, last_error, len);
	    retstr->strlength = len;
    } else {
	strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
	retstr->strlength = strlen(retstr->strptr);
    }
    return 0;
}

ULONG
PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
{
    SV *res, *in;
    STRLEN len, n_a;
    char *str;

    last_error[0] = 0;
    if (rargc != 1)
	return seterr("one argument expected, got %ld", rargc);

    if (!init_perl(1))
	return seterr("error initializing perl");

  {
    dSP;
    int ret;

    ENTER;
    SAVETMPS;

    PUSHMARK(SP);
    in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
    eval_sv(in, G_SCALAR);
    SPAGAIN;
    res = POPs;
    PUTBACK;

    ret = 0;
    if (SvTRUE(ERRSV))
	ret = seterr(SvPV(ERRSV, n_a));
    if (!SvOK(res))
	ret = seterr("undefined value returned by Perl-in-REXX");
    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
	ret = seterr("Not enough memory for the return string of Perl-in-REXX");

    FREETMPS;
    LEAVE;

    return ret;
  }
}

ULONG
PERLEVALSUBCOMMAND(
  const RXSTRING    *command,          /* command to issue           */
  PUSHORT      flags,                  /* error/failure flags        */
  PRXSTRING    retstr )                /* return code                */
{
    ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);

    if (rc)
	*flags = RXSUBCOM_ERROR;         /* raise error condition    */

    return 0;                            /* finished                   */
}

#define ArrLength(a) (sizeof(a)/sizeof(*(a)))

static const struct {
  char *name;
  RexxFunctionHandler *f;
} funcs[] = {
             {"PERL",			(RexxFunctionHandler *)&PERL},
             {"PERLTERM",		(RexxFunctionHandler *)&PERLTERM},
             {"PERLINIT",		(RexxFunctionHandler *)&PERLINIT},
             {"PERLEXIT",		(RexxFunctionHandler *)&PERLEXIT},
             {"PERLEVAL",		(RexxFunctionHandler *)&PERLEVAL},
             {"PERLLASTERROR",		(RexxFunctionHandler *)&PERLLASTERROR},
             {"PERLDROPALL",		(RexxFunctionHandler *)&PERLDROPALL},
             {"PERLDROPALLEXIT",	(RexxFunctionHandler *)&PERLDROPALLEXIT},
             /* Should be the last entry */
             {"PERLEXPORTALL",		(RexxFunctionHandler *)&PERLEXPORTALL}
          };

ULONG
PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
{
   int i = -1;

   while (++i < ArrLength(funcs) - 1)
	RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
   RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
   retstr->strlength = 0;
   return 0;
}

ULONG
PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
{
   int i = -1;

   while (++i < ArrLength(funcs))
	RexxDeregisterFunction(funcs[i].name);
   RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
   retstr->strlength = 0;
   return 0;
}

ULONG
PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
{
   int i = -1;

   while (++i < ArrLength(funcs))
	RexxDeregisterFunction(funcs[i].name);
   RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
   PERL_SYS_TERM1(0);
   retstr->strlength = 0;
   return 0;
}
Commit	Line	Data
764df951	1	#define INCL_DOSPROCESS
	2	#define INCL_DOSSEMAPHORES
	3	#define INCL_DOSMODULEMGR
	4	#define INCL_DOSMISC
	5	#define INCL_DOSEXCEPTIONS
	6	#define INCL_DOSERRORS
	7	#define INCL_REXXSAA
	8	#include <os2.h>
	9
	10	/*
	11	* "The Road goes ever on and on, down from the door where it began."
	12	*/
	13
	14	#ifdef OEMVS
	15	#ifdef MYMALLOC
	16	/* sbrk is limited to first heap segement so make it big */
	17	#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
	18	#else
	19	#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
	20	#endif
	21	#endif
	22
	23
	24	#include "EXTERN.h"
	25	#include "perl.h"
	26
	27	static void xs_init (pTHX);
	28	static PerlInterpreter *my_perl;
	29
9e2a34c1	30	ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
	31	ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
	32	ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
	33
764df951	34	#if defined (__MINT__) \|\| defined (atarist)
	35	/* The Atari operating system doesn't have a dynamic stack. The
	36	stack size is determined from this value. */
	37	long _stksize = 64 * 1024;
	38	#endif
	39
	40	/* Register any extra external extensions */
	41
	42	/* Do not delete this line--writemain depends on it */
	43	EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
	44
	45	static void
	46	xs_init(pTHX)
	47	{
	48	char *file = __FILE__;
	49	dXSUB_SYS;
	50	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	51	}
	52
	53	int perlos2_is_inited;
	54
	55	static void
	56	init_perlos2(void)
	57	{
	58	/* static char env[1] = {NULL}; /
	59
	60	Perl_OS2_init3(0, 0, 0);
	61	}
	62
	63	static int
	64	init_perl(int doparse)
	65	{
	66	int exitstatus;
	67	char *argv[3] = {"perl_in_REXX", "-e", ""};
	68
	69	if (!perlos2_is_inited) {
	70	perlos2_is_inited = 1;
	71	init_perlos2();
	72	}
	73	if (my_perl)
	74	return 1;
	75	if (!PL_do_undump) {
	76	my_perl = perl_alloc();
	77	if (!my_perl)
	78	return 0;
	79	perl_construct(my_perl);
	80	PL_perl_destruct_level = 1;
	81	}
	82	if (!doparse)
	83	return 1;
	84	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
	85	return !exitstatus;
	86	}
	87
9e2a34c1	88	static char last_error[4096];
	89
	90	static int
	91	seterr(char *format, ...)
	92	{
	93	va_list va;
	94	char *s = last_error;
	95
	96	va_start(va, format);
	97	if (s[0]) {
	98	s += strlen(s);
	99	if (s[-1] != '\n') {
	100	snprintf(s, sizeof(last_error) - (s - last_error), "\n");
	101	s += strlen(s);
	102	}
	103	}
	104	vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
	105	return 1;
	106	}
	107
764df951	108	/* The REXX-callable entrypoints ... */
	109
	110	ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
	111	PCSZ queuename, PRXSTRING retstr)
	112	{
	113	int exitstatus;
	114	char buf[256];
	115	char *argv[3] = {"perl_from_REXX", "-e", buf};
	116	ULONG ret;
	117
9e2a34c1	118	if (rargc != 1)
	119	return seterr("one argument expected, got %ld", rargc);
	120	if (rargv[0].strlength >= sizeof(buf))
	121	return seterr("length of the argument %ld exceeds the maximum %ld",
	122	rargv[0].strlength, (long)sizeof(buf) - 1);
764df951	123
	124	if (!init_perl(0))
	125	return 1;
	126
	127	memcpy(buf, rargv[0].strptr, rargv[0].strlength);
	128	buf[rargv[0].strlength] = 0;
	129
	130	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
	131	if (!exitstatus) {
	132	exitstatus = perl_run(my_perl);
	133	}
	134
	135	perl_destruct(my_perl);
	136	perl_free(my_perl);
	137	my_perl = 0;
	138
	139	if (exitstatus)
	140	ret = 1;
	141	else {
	142	ret = 0;
	143	sprintf(retstr->strptr, "%s", "ok");
	144	retstr->strlength = strlen (retstr->strptr);
	145	}
	146	PERL_SYS_TERM1(0);
	147	return ret;
	148	}
	149
	150	ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
	151	PCSZ queuename, PRXSTRING retstr)
	152	{
9e2a34c1	153	if (rargc != 0)
9e2a34c1	154	return seterr("no arguments expected, got %ld", rargc);
764df951	155	PERL_SYS_TERM1(0);
	156	return 0;
	157	}
	158
	159	ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
	160	PCSZ queuename, PRXSTRING retstr)
	161	{
9e2a34c1	162	if (rargc != 0)
	163	return seterr("no arguments expected, got %ld", rargc);
	164	if (!my_perl)
	165	return seterr("no perl interpreter present");
764df951	166	perl_destruct(my_perl);
	167	perl_free(my_perl);
	168	my_perl = 0;
	169
	170	sprintf(retstr->strptr, "%s", "ok");
	171	retstr->strlength = strlen (retstr->strptr);
	172	return 0;
	173	}
	174
	175
	176	ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
	177	PCSZ queuename, PRXSTRING retstr)
	178	{
9e2a34c1	179	if (rargc != 0)
9e2a34c1	180	return seterr("no argument expected, got %ld", rargc);
764df951	181	if (!init_perl(1))
	182	return 1;
	183
	184	sprintf(retstr->strptr, "%s", "ok");
	185	retstr->strlength = strlen (retstr->strptr);
	186	return 0;
	187	}
	188
9e2a34c1	189	ULONG
	190	PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
	191	{
	192	int len = strlen(last_error);
	193
	194	if (len <= 256 /* Default buffer is 256-char long */
	195	\|\| !DosAllocMem((PPVOID)&retstr->strptr, len,
	196	PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
	197	memcpy(retstr->strptr, last_error, len);
	198	retstr->strlength = len;
	199	} else {
	200	strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
	201	retstr->strlength = strlen(retstr->strptr);
	202	}
	203	return 0;
	204	}
	205
	206	ULONG
	207	PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
764df951	208	{
764df951	209	SV res, in;
9e2a34c1	210	STRLEN len, n_a;
764df951	211	char *str;
764df951	212
9e2a34c1	213	last_error[0] = 0;
	214	if (rargc != 1)
	215	return seterr("one argument expected, got %ld", rargc);
764df951	216
764df951	217	if (!init_perl(1))
9e2a34c1	218	return seterr("error initializing perl");
764df951	219
	220	{
	221	dSP;
	222	int ret;
	223
	224	ENTER;
	225	SAVETMPS;
	226
	227	PUSHMARK(SP);
	228	in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
	229	eval_sv(in, G_SCALAR);
	230	SPAGAIN;
	231	res = POPs;
	232	PUTBACK;
	233
	234	ret = 0;
9e2a34c1	235	if (SvTRUE(ERRSV))
	236	ret = seterr(SvPV(ERRSV, n_a));
	237	if (!SvOK(res))
	238	ret = seterr("undefined value returned by Perl-in-REXX");
764df951	239	str = SvPV(res, len);
	240	if (len <= 256 /* Default buffer is 256-char long */
	241	\|\| !DosAllocMem((PPVOID)&retstr->strptr, len,
	242	PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
	243	memcpy(retstr->strptr, str, len);
	244	retstr->strlength = len;
	245	} else
9e2a34c1	246	ret = seterr("Not enough memory for the return string of Perl-in-REXX");
764df951	247
	248	FREETMPS;
	249	LEAVE;
	250
	251	return ret;
	252	}
	253	}
9e2a34c1	254
	255	ULONG
	256	PERLEVALSUBCOMMAND(
	257	const RXSTRING command, / command to issue */
	258	PUSHORT flags, /* error/failure flags */
	259	PRXSTRING retstr ) /* return code */
	260	{
	261	ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
	262
	263	if (rc)
	264	flags = RXSUBCOM_ERROR; / raise error condition */
	265
	266	return 0; /* finished */
	267	}
	268
	269	#define ArrLength(a) (sizeof(a)/sizeof(*(a)))
	270
	271	static const struct {
	272	char *name;
	273	RexxFunctionHandler *f;
	274	} funcs[] = {
	275	{"PERL", (RexxFunctionHandler *)&PERL},
	276	{"PERLTERM", (RexxFunctionHandler *)&PERLTERM},
	277	{"PERLINIT", (RexxFunctionHandler *)&PERLINIT},
	278	{"PERLEXIT", (RexxFunctionHandler *)&PERLEXIT},
	279	{"PERLEVAL", (RexxFunctionHandler *)&PERLEVAL},
	280	{"PERLLASTERROR", (RexxFunctionHandler *)&PERLLASTERROR},
	281	{"PERLDROPALL", (RexxFunctionHandler *)&PERLDROPALL},
	282	{"PERLDROPALLEXIT", (RexxFunctionHandler *)&PERLDROPALLEXIT},
	283	/* Should be the last entry */
	284	{"PERLEXPORTALL", (RexxFunctionHandler *)&PERLEXPORTALL}
	285	};
	286
	287	ULONG
	288	PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
	289	{
	290	int i = -1;
	291
	292	while (++i < ArrLength(funcs) - 1)
	293	RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
	294	RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
	295	retstr->strlength = 0;
	296	return 0;
	297	}
	298
	299	ULONG
	300	PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
	301	{
	302	int i = -1;
	303
	304	while (++i < ArrLength(funcs))
	305	RexxDeregisterFunction(funcs[i].name);
	306	RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
	307	retstr->strlength = 0;
	308	return 0;
	309	}
	310
	311	ULONG
	312	PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
	313	{
	314	int i = -1;
	315
	316	while (++i < ArrLength(funcs))
	317	RexxDeregisterFunction(funcs[i].name);
318	RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
319	PERL_SYS_TERM1(0);
320	retstr->strlength = 0;
321	return 0;
322	}