source: trunk/essentials/dev-lang/perl/os2/perlrexx.c@ 3187

Last change on this file since 3187 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 8.0 KB
Line 
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
27static void xs_init (pTHX);
28static PerlInterpreter *my_perl;
29
30ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
31ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
32ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
33
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. */
37long _stksize = 64 * 1024;
38#endif
39
40/* Register any extra external extensions */
41
42/* Do not delete this line--writemain depends on it */
43EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
44
45static void
46xs_init(pTHX)
47{
48 char *file = __FILE__;
49 dXSUB_SYS;
50 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
51}
52
53int perlos2_is_inited;
54
55static void
56init_perlos2(void)
57{
58/* static char *env[1] = {NULL}; */
59
60 Perl_OS2_init3(0, 0, 0);
61}
62
63static int
64init_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
88static char last_error[4096];
89
90static int
91seterr(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
108/* The REXX-callable entrypoints ... */
109
110ULONG 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
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);
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
150ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
151 PCSZ queuename, PRXSTRING retstr)
152{
153 if (rargc != 0)
154 return seterr("no arguments expected, got %ld", rargc);
155 PERL_SYS_TERM1(0);
156 return 0;
157}
158
159ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
160 PCSZ queuename, PRXSTRING retstr)
161{
162 if (rargc != 0)
163 return seterr("no arguments expected, got %ld", rargc);
164 if (!my_perl)
165 return seterr("no perl interpreter present");
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
176ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
177 PCSZ queuename, PRXSTRING retstr)
178{
179 if (rargc != 0)
180 return seterr("no argument expected, got %ld", rargc);
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
189ULONG
190PERLLASTERROR (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
206ULONG
207PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
208{
209 SV *res, *in;
210 STRLEN len, n_a;
211 char *str;
212
213 last_error[0] = 0;
214 if (rargc != 1)
215 return seterr("one argument expected, got %ld", rargc);
216
217 if (!init_perl(1))
218 return seterr("error initializing perl");
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;
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");
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
246 ret = seterr("Not enough memory for the return string of Perl-in-REXX");
247
248 FREETMPS;
249 LEAVE;
250
251 return ret;
252 }
253}
254
255ULONG
256PERLEVALSUBCOMMAND(
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
271static 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
287ULONG
288PERLEXPORTALL(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
299ULONG
300PERLDROPALL(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
311ULONG
312PERLDROPALLEXIT(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}
Note: See TracBrowser for help on using the repository browser.