[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.
 *
 *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
 *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
 */

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