[perl5.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;

#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;
}

/* 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) {
	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (rargv[0].strlength >= sizeof(buf)) {
	sprintf(retstr->strptr,
		"length of the argument %ld exceeds the maximum %ld",
		rargv[0].strlength, (long)sizeof(buf) - 1);
	retstr->strlength = strlen (retstr->strptr);
	return 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) {
	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    PERL_SYS_TERM1(0);
    return 0;
}

ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    if (rargc != 0) {
	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (!my_perl) {
	sprintf(retstr->strptr, "no perl interpreter present");
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    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) {
	sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (!init_perl(1))
	return 1;

    sprintf(retstr->strptr, "%s", "ok");
    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;
    char *str;

    if (rargc != 1) {
	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }

    if (!init_perl(1))
	return 1;

  {
    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) || !SvOK(res))
	ret = 1;
    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 = 1;

    FREETMPS;
    LEAVE;

    return ret;
  }
}
#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;

#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;
}

/* 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) {
	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (rargv[0].strlength >= sizeof(buf)) {
	sprintf(retstr->strptr,
		"length of the argument %ld exceeds the maximum %ld",
		rargv[0].strlength, (long)sizeof(buf) - 1);
	retstr->strlength = strlen (retstr->strptr);
	return 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) {
	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    PERL_SYS_TERM1(0);
    return 0;
}

ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
                    PCSZ queuename, PRXSTRING retstr)
{
    if (rargc != 0) {
	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (!my_perl) {
	sprintf(retstr->strptr, "no perl interpreter present");
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    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) {
	sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }
    if (!init_perl(1))
	return 1;

    sprintf(retstr->strptr, "%s", "ok");
    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;
    char *str;

    if (rargc != 1) {
	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
	retstr->strlength = strlen (retstr->strptr);
	return 1;
    }

    if (!init_perl(1))
	return 1;

  {
    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) || !SvOK(res))
	ret = 1;
    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 = 1;

    FREETMPS;
    LEAVE;

    return ret;
  }
}
Commit	Line	Data
764df951 IZ	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
	30	#if defined (__MINT__) \|\| defined (atarist)
	31	/* The Atari operating system doesn't have a dynamic stack. The
	32	stack size is determined from this value. */
	33	long _stksize = 64 * 1024;
	34	#endif
	35
	36	/* Register any extra external extensions */
	37
	38	/* Do not delete this line--writemain depends on it */
	39	EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
	40
	41	static void
	42	xs_init(pTHX)
	43	{
	44	char *file = __FILE__;
	45	dXSUB_SYS;
	46	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	47	}
	48
	49	int perlos2_is_inited;
	50
	51	static void
	52	init_perlos2(void)
	53	{
	54	/* static char env[1] = {NULL}; /
	55
	56	Perl_OS2_init3(0, 0, 0);
	57	}
	58
	59	static int
	60	init_perl(int doparse)
	61	{
	62	int exitstatus;
	63	char *argv[3] = {"perl_in_REXX", "-e", ""};
	64
65	if (!perlos2_is_inited) {
66	perlos2_is_inited = 1;
67	init_perlos2();
68	}
69	if (my_perl)
70	return 1;
71	if (!PL_do_undump) {
72	my_perl = perl_alloc();
73	if (!my_perl)
74	return 0;
75	perl_construct(my_perl);
76	PL_perl_destruct_level = 1;
77	}
78	if (!doparse)
79	return 1;
80	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
81	return !exitstatus;
82	}
83
84	/* The REXX-callable entrypoints ... */
85
86	ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
87	PCSZ queuename, PRXSTRING retstr)
88	{
89	int exitstatus;
90	char buf[256];
91	char *argv[3] = {"perl_from_REXX", "-e", buf};
92	ULONG ret;
93
94	if (rargc != 1) {
95	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
96	retstr->strlength = strlen (retstr->strptr);
97	return 1;
98	}
99	if (rargv[0].strlength >= sizeof(buf)) {
100	sprintf(retstr->strptr,
101	"length of the argument %ld exceeds the maximum %ld",
102	rargv[0].strlength, (long)sizeof(buf) - 1);
103	retstr->strlength = strlen (retstr->strptr);
104	return 1;
105	}
106
107	if (!init_perl(0))
108	return 1;
109
110	memcpy(buf, rargv[0].strptr, rargv[0].strlength);
111	buf[rargv[0].strlength] = 0;
112
113	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
114	if (!exitstatus) {
115	exitstatus = perl_run(my_perl);
116	}
117
118	perl_destruct(my_perl);
119	perl_free(my_perl);
120	my_perl = 0;
121
122	if (exitstatus)
123	ret = 1;
124	else {
125	ret = 0;
126	sprintf(retstr->strptr, "%s", "ok");
127	retstr->strlength = strlen (retstr->strptr);
128	}
129	PERL_SYS_TERM1(0);
130	return ret;
131	}
132
133	ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
134	PCSZ queuename, PRXSTRING retstr)
135	{
136	if (rargc != 0) {
137	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
138	retstr->strlength = strlen (retstr->strptr);
139	return 1;
140	}
141	PERL_SYS_TERM1(0);
142	return 0;
143	}
144
145	ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
146	PCSZ queuename, PRXSTRING retstr)
147	{
148	if (rargc != 0) {
149	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
150	retstr->strlength = strlen (retstr->strptr);
151	return 1;
152	}
153	if (!my_perl) {
154	sprintf(retstr->strptr, "no perl interpreter present");
155	retstr->strlength = strlen (retstr->strptr);
156	return 1;
157	}
158	perl_destruct(my_perl);
159	perl_free(my_perl);
160	my_perl = 0;
161
162	sprintf(retstr->strptr, "%s", "ok");
163	retstr->strlength = strlen (retstr->strptr);
164	return 0;
165	}
166
167
168	ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
169	PCSZ queuename, PRXSTRING retstr)
170	{
171	if (rargc != 0) {
172	sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
173	retstr->strlength = strlen (retstr->strptr);
174	return 1;
175	}
176	if (!init_perl(1))
177	return 1;
178
179	sprintf(retstr->strptr, "%s", "ok");
180	retstr->strlength = strlen (retstr->strptr);
181	return 0;
182	}
183
184	ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
185	PCSZ queuename, PRXSTRING retstr)
186	{
187	SV res, in;
188	STRLEN len;
189	char *str;
190
191	if (rargc != 1) {
192	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
193	retstr->strlength = strlen (retstr->strptr);
194	return 1;
195	}
196
197	if (!init_perl(1))
198	return 1;
199
200	{
201	dSP;
202	int ret;
203
204	ENTER;
205	SAVETMPS;
206
207	PUSHMARK(SP);
208	in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
209	eval_sv(in, G_SCALAR);
210	SPAGAIN;
211	res = POPs;
212	PUTBACK;
213
214	ret = 0;
215	if (SvTRUE(ERRSV) \|\| !SvOK(res))
216	ret = 1;
217	str = SvPV(res, len);
218	if (len <= 256 /* Default buffer is 256-char long */
219	\|\| !DosAllocMem((PPVOID)&retstr->strptr, len,
220	PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
221	memcpy(retstr->strptr, str, len);
222	retstr->strlength = len;
223	} else
224	ret = 1;
225
226	FREETMPS;
227	LEAVE;
228
229	return ret;
230	}
231	}
232	#define INCL_DOSPROCESS
233	#define INCL_DOSSEMAPHORES
234	#define INCL_DOSMODULEMGR
235	#define INCL_DOSMISC
236	#define INCL_DOSEXCEPTIONS
237	#define INCL_DOSERRORS
238	#define INCL_REXXSAA
2b6ff23b	239	#include <os2.h>
764df951 IZ	240
	241	/*
	242	* "The Road goes ever on and on, down from the door where it began."
	243	*/
	244
	245	#ifdef OEMVS
	246	#ifdef MYMALLOC
	247	/* sbrk is limited to first heap segement so make it big */
	248	#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
	249	#else
	250	#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
	251	#endif
	252	#endif
	253
	254
	255	#include "EXTERN.h"
	256	#include "perl.h"
	257
	258	static void xs_init (pTHX);
	259	static PerlInterpreter *my_perl;
	260
	261	#if defined (__MINT__) \|\| defined (atarist)
	262	/* The Atari operating system doesn't have a dynamic stack. The
	263	stack size is determined from this value. */
	264	long _stksize = 64 * 1024;
	265	#endif
	266
	267	/* Register any extra external extensions */
	268
	269	/* Do not delete this line--writemain depends on it */
	270	EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
	271
	272	static void
	273	xs_init(pTHX)
	274	{
	275	char *file = __FILE__;
	276	dXSUB_SYS;
	277	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
	278	}
	279
	280	int perlos2_is_inited;
	281
	282	static void
	283	init_perlos2(void)
	284	{
	285	/* static char env[1] = {NULL}; /
	286
	287	Perl_OS2_init3(0, 0, 0);
	288	}
	289
	290	static int
	291	init_perl(int doparse)
	292	{
	293	int exitstatus;
	294	char *argv[3] = {"perl_in_REXX", "-e", ""};
	295
	296	if (!perlos2_is_inited) {
	297	perlos2_is_inited = 1;
	298	init_perlos2();
	299	}
	300	if (my_perl)
	301	return 1;
	302	if (!PL_do_undump) {
	303	my_perl = perl_alloc();
304	if (!my_perl)
305	return 0;
306	perl_construct(my_perl);
307	PL_perl_destruct_level = 1;
308	}
309	if (!doparse)
310	return 1;
311	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
312	return !exitstatus;
313	}
314
315	/* The REXX-callable entrypoints ... */
316
317	ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
318	PCSZ queuename, PRXSTRING retstr)
319	{
320	int exitstatus;
321	char buf[256];
322	char *argv[3] = {"perl_from_REXX", "-e", buf};
323	ULONG ret;
324
325	if (rargc != 1) {
2b6ff23b PN	326	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
2b6ff23b PN	327	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	328	return 1;
764df951 IZ	329	}
2b6ff23b PN	330	if (rargv[0].strlength >= sizeof(buf)) {
2b6ff23b PN	331	sprintf(retstr->strptr,
764df951 IZ	332	"length of the argument %ld exceeds the maximum %ld",
764df951 IZ	333	rargv[0].strlength, (long)sizeof(buf) - 1);
2b6ff23b	334	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	335	return 1;
	336	}
	337
	338	if (!init_perl(0))
	339	return 1;
	340
	341	memcpy(buf, rargv[0].strptr, rargv[0].strlength);
	342	buf[rargv[0].strlength] = 0;
	343
	344	exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
	345	if (!exitstatus) {
	346	exitstatus = perl_run(my_perl);
	347	}
	348
	349	perl_destruct(my_perl);
	350	perl_free(my_perl);
	351	my_perl = 0;
	352
	353	if (exitstatus)
	354	ret = 1;
	355	else {
	356	ret = 0;
2b6ff23b PN	357	sprintf(retstr->strptr, "%s", "ok");
2b6ff23b PN	358	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	359	}
	360	PERL_SYS_TERM1(0);
	361	return ret;
	362	}
	363
	364	ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
	365	PCSZ queuename, PRXSTRING retstr)
	366	{
	367	if (rargc != 0) {
2b6ff23b PN	368	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
2b6ff23b PN	369	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	370	return 1;
	371	}
	372	PERL_SYS_TERM1(0);
	373	return 0;
	374	}
	375
	376	ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
	377	PCSZ queuename, PRXSTRING retstr)
	378	{
	379	if (rargc != 0) {
2b6ff23b PN	380	sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
2b6ff23b PN	381	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	382	return 1;
	383	}
	384	if (!my_perl) {
2b6ff23b PN	385	sprintf(retstr->strptr, "no perl interpreter present");
2b6ff23b PN	386	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	387	return 1;
	388	}
	389	perl_destruct(my_perl);
	390	perl_free(my_perl);
	391	my_perl = 0;
	392
2b6ff23b PN	393	sprintf(retstr->strptr, "%s", "ok");
2b6ff23b PN	394	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	395	return 0;
	396	}
	397
	398
	399	ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
	400	PCSZ queuename, PRXSTRING retstr)
	401	{
	402	if (rargc != 0) {
2b6ff23b PN	403	sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
2b6ff23b PN	404	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	405	return 1;
	406	}
	407	if (!init_perl(1))
	408	return 1;
	409
2b6ff23b PN	410	sprintf(retstr->strptr, "%s", "ok");
2b6ff23b PN	411	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	412	return 0;
	413	}
	414
	415	ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
	416	PCSZ queuename, PRXSTRING retstr)
	417	{
	418	SV res, in;
	419	STRLEN len;
	420	char *str;
	421
	422	if (rargc != 1) {
2b6ff23b PN	423	sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
2b6ff23b PN	424	retstr->strlength = strlen (retstr->strptr);
764df951 IZ	425	return 1;
	426	}
	427
	428	if (!init_perl(1))
	429	return 1;
	430
	431	{
	432	dSP;
	433	int ret;
	434
	435	ENTER;
	436	SAVETMPS;
	437
	438	PUSHMARK(SP);
	439	in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
	440	eval_sv(in, G_SCALAR);
	441	SPAGAIN;
	442	res = POPs;
	443	PUTBACK;
	444
	445	ret = 0;
	446	if (SvTRUE(ERRSV) \|\| !SvOK(res))
	447	ret = 1;
	448	str = SvPV(res, len);
2b6ff23b PN	449	if (len <= 256 /* Default buffer is 256-char long */
2b6ff23b PN	450	\|\| !DosAllocMem((PPVOID)&retstr->strptr, len,
764df951	451	PAG_READ\|PAG_WRITE\|PAG_COMMIT)) {
2b6ff23b PN	452	memcpy(retstr->strptr, str, len);
2b6ff23b PN	453	retstr->strlength = len;
764df951 IZ	454	} else
	455	ret = 1;
	456
	457	FREETMPS;
	458	LEAVE;
	459
	460	return ret;
	461	}
	462	}