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