extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / os2 / perlrexx.c
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
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
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
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
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
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
150 ULONG 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
159 ULONG 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
176 ULONG 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
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)
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
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 }