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 | ||
9e2a34c1 IZ |
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 IZ |
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 IZ |
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 IZ |
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 IZ |
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 IZ |
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 IZ |
153 | if (rargc != 0) |
154 | return seterr("no arguments expected, got %ld", rargc); | |
764df951 IZ |
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 IZ |
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 IZ |
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 IZ |
179 | if (rargc != 0) |
180 | return seterr("no argument expected, got %ld", rargc); | |
764df951 IZ |
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 IZ |
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 IZ |
208 | { |
209 | SV *res, *in; | |
9e2a34c1 | 210 | STRLEN len, n_a; |
764df951 IZ |
211 | char *str; |
212 | ||
9e2a34c1 IZ |
213 | last_error[0] = 0; |
214 | if (rargc != 1) | |
215 | return seterr("one argument expected, got %ld", rargc); | |
764df951 IZ |
216 | |
217 | if (!init_perl(1)) | |
9e2a34c1 | 218 | return seterr("error initializing perl"); |
764df951 IZ |
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 IZ |
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 IZ |
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 IZ |
247 | |
248 | FREETMPS; | |
249 | LEAVE; | |
250 | ||
251 | return ret; | |
252 | } | |
253 | } | |
9e2a34c1 IZ |
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 | } |