This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
set PERL_EXIT_DESTRUCT_END in all embeddings
[perl5.git] / os2 / perlrexx.c
CommitLineData
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/*
4ac71550
TC
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
IZ
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
IZ
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
764df951
IZ
38/* Register any extra external extensions */
39
40/* Do not delete this line--writemain depends on it */
41EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
42
43static void
44xs_init(pTHX)
45{
46 char *file = __FILE__;
47 dXSUB_SYS;
48 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
49}
50
51int perlos2_is_inited;
52
53static void
54init_perlos2(void)
55{
56/* static char *env[1] = {NULL}; */
57
58 Perl_OS2_init3(0, 0, 0);
59}
60
61static int
62init_perl(int doparse)
63{
764df951
IZ
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);
8e920bd3 77 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
764df951
IZ
78 PL_perl_destruct_level = 1;
79 }
80 if (!doparse)
81 return 1;
fe2024f9 82 return !perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
764df951
IZ
83}
84
9e2a34c1
IZ
85static char last_error[4096];
86
87static int
88seterr(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
764df951
IZ
105/* The REXX-callable entrypoints ... */
106
107ULONG 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
9e2a34c1
IZ
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);
764df951
IZ
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
fe2024f9
Z
127 if (!perl_parse(my_perl, xs_init, 3, argv, (char **)NULL))
128 perl_run(my_perl);
764df951 129
fe2024f9 130 exitstatus = perl_destruct(my_perl);
764df951
IZ
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
145ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
146 PCSZ queuename, PRXSTRING retstr)
147{
9e2a34c1
IZ
148 if (rargc != 0)
149 return seterr("no arguments expected, got %ld", rargc);
764df951
IZ
150 PERL_SYS_TERM1(0);
151 return 0;
152}
153
154ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
155 PCSZ queuename, PRXSTRING retstr)
156{
9e2a34c1
IZ
157 if (rargc != 0)
158 return seterr("no arguments expected, got %ld", rargc);
159 if (!my_perl)
160 return seterr("no perl interpreter present");
764df951
IZ
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
171ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
172 PCSZ queuename, PRXSTRING retstr)
173{
9e2a34c1
IZ
174 if (rargc != 0)
175 return seterr("no argument expected, got %ld", rargc);
764df951
IZ
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
9e2a34c1
IZ
184ULONG
185PERLLASTERROR (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
201ULONG
202PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
764df951
IZ
203{
204 SV *res, *in;
9e2a34c1 205 STRLEN len, n_a;
764df951
IZ
206 char *str;
207
9e2a34c1
IZ
208 last_error[0] = 0;
209 if (rargc != 1)
210 return seterr("one argument expected, got %ld", rargc);
764df951
IZ
211
212 if (!init_perl(1))
9e2a34c1 213 return seterr("error initializing perl");
764df951
IZ
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;
9e2a34c1
IZ
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");
764df951
IZ
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
9e2a34c1 241 ret = seterr("Not enough memory for the return string of Perl-in-REXX");
764df951
IZ
242
243 FREETMPS;
244 LEAVE;
245
246 return ret;
247 }
248}
9e2a34c1
IZ
249
250ULONG
251PERLEVALSUBCOMMAND(
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
266static 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
282ULONG
283PERLEXPORTALL(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
294ULONG
295PERLDROPALL(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
306ULONG
307PERLDROPALLEXIT(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}