1 #define INCL_DOSPROCESS
2 #define INCL_DOSSEMAPHORES
3 #define INCL_DOSMODULEMGR
5 #define INCL_DOSEXCEPTIONS
11 * The Road goes ever on and on
12 * Down from the door where it began.
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"]
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))
23 #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
31 static void xs_init (pTHX);
32 static PerlInterpreter *my_perl;
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);
38 /* Register any extra external extensions */
40 /* Do not delete this line--writemain depends on it */
41 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
46 char *file = __FILE__;
48 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
51 int perlos2_is_inited;
56 /* static char *env[1] = {NULL}; */
58 Perl_OS2_init3(0, 0, 0);
62 init_perl(int doparse)
65 char *argv[3] = {"perl_in_REXX", "-e", ""};
67 if (!perlos2_is_inited) {
68 perlos2_is_inited = 1;
74 my_perl = perl_alloc();
77 perl_construct(my_perl);
78 PL_perl_destruct_level = 1;
82 exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
86 static char last_error[4096];
89 seterr(char *format, ...)
98 snprintf(s, sizeof(last_error) - (s - last_error), "\n");
102 vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
106 /* The REXX-callable entrypoints ... */
108 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
109 PCSZ queuename, PRXSTRING retstr)
113 char *argv[3] = {"perl_from_REXX", "-e", buf};
117 return seterr("one argument expected, got %ld", rargc);
118 if (rargv[0].strlength >= sizeof(buf))
119 return seterr("length of the argument %ld exceeds the maximum %ld",
120 rargv[0].strlength, (long)sizeof(buf) - 1);
125 memcpy(buf, rargv[0].strptr, rargv[0].strlength);
126 buf[rargv[0].strlength] = 0;
128 exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
130 exitstatus = perl_run(my_perl);
133 perl_destruct(my_perl);
141 sprintf(retstr->strptr, "%s", "ok");
142 retstr->strlength = strlen (retstr->strptr);
148 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
149 PCSZ queuename, PRXSTRING retstr)
152 return seterr("no arguments expected, got %ld", rargc);
157 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
158 PCSZ queuename, PRXSTRING retstr)
161 return seterr("no arguments expected, got %ld", rargc);
163 return seterr("no perl interpreter present");
164 perl_destruct(my_perl);
168 sprintf(retstr->strptr, "%s", "ok");
169 retstr->strlength = strlen (retstr->strptr);
174 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
175 PCSZ queuename, PRXSTRING retstr)
178 return seterr("no argument expected, got %ld", rargc);
182 sprintf(retstr->strptr, "%s", "ok");
183 retstr->strlength = strlen (retstr->strptr);
188 PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
190 int len = strlen(last_error);
192 if (len <= 256 /* Default buffer is 256-char long */
193 || !DosAllocMem((PPVOID)&retstr->strptr, len,
194 PAG_READ|PAG_WRITE|PAG_COMMIT)) {
195 memcpy(retstr->strptr, last_error, len);
196 retstr->strlength = len;
198 strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
199 retstr->strlength = strlen(retstr->strptr);
205 PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
213 return seterr("one argument expected, got %ld", rargc);
216 return seterr("error initializing perl");
226 in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
227 eval_sv(in, G_SCALAR);
234 ret = seterr(SvPV(ERRSV, n_a));
236 ret = seterr("undefined value returned by Perl-in-REXX");
237 str = SvPV(res, len);
238 if (len <= 256 /* Default buffer is 256-char long */
239 || !DosAllocMem((PPVOID)&retstr->strptr, len,
240 PAG_READ|PAG_WRITE|PAG_COMMIT)) {
241 memcpy(retstr->strptr, str, len);
242 retstr->strlength = len;
244 ret = seterr("Not enough memory for the return string of Perl-in-REXX");
255 const RXSTRING *command, /* command to issue */
256 PUSHORT flags, /* error/failure flags */
257 PRXSTRING retstr ) /* return code */
259 ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
262 *flags = RXSUBCOM_ERROR; /* raise error condition */
264 return 0; /* finished */
267 #define ArrLength(a) (sizeof(a)/sizeof(*(a)))
269 static const struct {
271 RexxFunctionHandler *f;
273 {"PERL", (RexxFunctionHandler *)&PERL},
274 {"PERLTERM", (RexxFunctionHandler *)&PERLTERM},
275 {"PERLINIT", (RexxFunctionHandler *)&PERLINIT},
276 {"PERLEXIT", (RexxFunctionHandler *)&PERLEXIT},
277 {"PERLEVAL", (RexxFunctionHandler *)&PERLEVAL},
278 {"PERLLASTERROR", (RexxFunctionHandler *)&PERLLASTERROR},
279 {"PERLDROPALL", (RexxFunctionHandler *)&PERLDROPALL},
280 {"PERLDROPALLEXIT", (RexxFunctionHandler *)&PERLDROPALLEXIT},
281 /* Should be the last entry */
282 {"PERLEXPORTALL", (RexxFunctionHandler *)&PERLEXPORTALL}
286 PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
290 while (++i < ArrLength(funcs) - 1)
291 RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
292 RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
293 retstr->strlength = 0;
298 PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
302 while (++i < ArrLength(funcs))
303 RexxDeregisterFunction(funcs[i].name);
304 RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
305 retstr->strlength = 0;
310 PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
314 while (++i < ArrLength(funcs))
315 RexxDeregisterFunction(funcs[i].name);
316 RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
318 retstr->strlength = 0;