Optimize reversing an array in-place
[p5sagit/p5-mst-13.2.git] / os2 / perlrexx.c
CommitLineData
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
31static void xs_init (pTHX);
32static PerlInterpreter *my_perl;
33
9e2a34c1 34ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
35ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
36ULONG 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. */
41long _stksize = 64 * 1024;
42#endif
43
44/* Register any extra external extensions */
45
46/* Do not delete this line--writemain depends on it */
47EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
48
49static void
50xs_init(pTHX)
51{
52 char *file = __FILE__;
53 dXSUB_SYS;
54 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
55}
56
57int perlos2_is_inited;
58
59static void
60init_perlos2(void)
61{
62/* static char *env[1] = {NULL}; */
63
64 Perl_OS2_init3(0, 0, 0);
65}
66
67static int
68init_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 92static char last_error[4096];
93
94static int
95seterr(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
114ULONG 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
154ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
155 PCSZ queuename, PRXSTRING retstr)
156{
9e2a34c1 157 if (rargc != 0)
158 return seterr("no arguments expected, got %ld", rargc);
764df951 159 PERL_SYS_TERM1(0);
160 return 0;
161}
162
163ULONG 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
180ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
181 PCSZ queuename, PRXSTRING retstr)
182{
9e2a34c1 183 if (rargc != 0)
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 193ULONG
194PERLLASTERROR (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
210ULONG
211PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
764df951 212{
213 SV *res, *in;
9e2a34c1 214 STRLEN len, n_a;
764df951 215 char *str;
216
9e2a34c1 217 last_error[0] = 0;
218 if (rargc != 1)
219 return seterr("one argument expected, got %ld", rargc);
764df951 220
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
259ULONG
260PERLEVALSUBCOMMAND(
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
275static 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
291ULONG
292PERLEXPORTALL(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
303ULONG
304PERLDROPALL(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
315ULONG
316PERLDROPALLEXIT(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}