perldelta for 67c3640a57440a
[perl.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
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"]
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
31 static void xs_init (pTHX);
32 static PerlInterpreter *my_perl;
33
34 ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
35 ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
36 ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
37
38 /* Register any extra external extensions */
39
40 /* Do not delete this line--writemain depends on it */
41 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
42
43 static void
44 xs_init(pTHX)
45 {
46     char *file = __FILE__;
47     dXSUB_SYS;
48         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
49 }
50
51 int perlos2_is_inited;
52
53 static void
54 init_perlos2(void)
55 {
56 /*    static char *env[1] = {NULL};     */
57
58     Perl_OS2_init3(0, 0, 0);
59 }
60
61 static int
62 init_perl(int doparse)
63 {
64     int exitstatus;
65     char *argv[3] = {"perl_in_REXX", "-e", ""};
66
67     if (!perlos2_is_inited) {
68         perlos2_is_inited = 1;
69         init_perlos2();
70     }
71     if (my_perl)
72         return 1;
73     if (!PL_do_undump) {
74         my_perl = perl_alloc();
75         if (!my_perl)
76             return 0;
77         perl_construct(my_perl);
78         PL_perl_destruct_level = 1;
79     }
80     if (!doparse)
81         return 1;
82     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
83     return !exitstatus;
84 }
85
86 static char last_error[4096];
87
88 static int
89 seterr(char *format, ...)
90 {
91         va_list va;
92         char *s = last_error;
93
94         va_start(va, format);
95         if (s[0]) {
96             s += strlen(s);
97             if (s[-1] != '\n') {
98                 snprintf(s, sizeof(last_error) - (s - last_error), "\n");
99                 s += strlen(s);
100             }
101         }
102         vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
103         return 1;
104 }
105
106 /* The REXX-callable entrypoints ... */
107
108 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
109                     PCSZ queuename, PRXSTRING retstr)
110 {
111     int exitstatus;
112     char buf[256];
113     char *argv[3] = {"perl_from_REXX", "-e", buf};
114     ULONG ret;
115
116     if (rargc != 1)
117         return seterr("one argument expected, got %ld", rargc);
118     if (rargv[0].strlength >= sizeof(buf))
119         return seterr("length of the argument %ld exceeds the maximum %ld",
120                       rargv[0].strlength, (long)sizeof(buf) - 1);
121
122     if (!init_perl(0))
123         return 1;
124
125     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
126     buf[rargv[0].strlength] = 0;
127     
128     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
129     if (!exitstatus) {
130         exitstatus = perl_run(my_perl);
131     }
132
133     perl_destruct(my_perl);
134     perl_free(my_perl);
135     my_perl = 0;
136
137     if (exitstatus)
138         ret = 1;
139     else {
140         ret = 0;
141         sprintf(retstr->strptr, "%s", "ok");
142         retstr->strlength = strlen (retstr->strptr);
143     }
144     PERL_SYS_TERM1(0);
145     return ret;
146 }
147
148 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
149                     PCSZ queuename, PRXSTRING retstr)
150 {
151     if (rargc != 0)
152         return seterr("no arguments expected, got %ld", rargc);
153     PERL_SYS_TERM1(0);
154     return 0;
155 }
156
157 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
158                     PCSZ queuename, PRXSTRING retstr)
159 {
160     if (rargc != 0)
161         return seterr("no arguments expected, got %ld", rargc);
162     if (!my_perl)
163         return seterr("no perl interpreter present");
164     perl_destruct(my_perl);
165     perl_free(my_perl);
166     my_perl = 0;
167
168     sprintf(retstr->strptr, "%s", "ok");
169     retstr->strlength = strlen (retstr->strptr);
170     return 0;
171 }
172
173
174 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
175                     PCSZ queuename, PRXSTRING retstr)
176 {
177     if (rargc != 0)
178         return seterr("no argument expected, got %ld", rargc);
179     if (!init_perl(1))
180         return 1;
181
182     sprintf(retstr->strptr, "%s", "ok");
183     retstr->strlength = strlen (retstr->strptr);
184     return 0;
185 }
186
187 ULONG
188 PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
189 {
190     int len = strlen(last_error);
191
192     if (len <= 256                      /* Default buffer is 256-char long */
193         || !DosAllocMem((PPVOID)&retstr->strptr, len,
194                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
195             memcpy(retstr->strptr, last_error, len);
196             retstr->strlength = len;
197     } else {
198         strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
199         retstr->strlength = strlen(retstr->strptr);
200     }
201     return 0;
202 }
203
204 ULONG
205 PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
206 {
207     SV *res, *in;
208     STRLEN len, n_a;
209     char *str;
210
211     last_error[0] = 0;
212     if (rargc != 1)
213         return seterr("one argument expected, got %ld", rargc);
214
215     if (!init_perl(1))
216         return seterr("error initializing perl");
217
218   {
219     dSP;
220     int ret;
221
222     ENTER;
223     SAVETMPS;
224
225     PUSHMARK(SP);
226     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
227     eval_sv(in, G_SCALAR);
228     SPAGAIN;
229     res = POPs;
230     PUTBACK;
231
232     ret = 0;
233     if (SvTRUE(ERRSV))
234         ret = seterr(SvPV(ERRSV, n_a));
235     if (!SvOK(res))
236         ret = seterr("undefined value returned by Perl-in-REXX");
237     str = SvPV(res, len);
238     if (len <= 256                      /* Default buffer is 256-char long */
239         || !DosAllocMem((PPVOID)&retstr->strptr, len,
240                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
241             memcpy(retstr->strptr, str, len);
242             retstr->strlength = len;
243     } else
244         ret = seterr("Not enough memory for the return string of Perl-in-REXX");
245
246     FREETMPS;
247     LEAVE;
248
249     return ret;
250   }
251 }
252
253 ULONG
254 PERLEVALSUBCOMMAND(
255   const RXSTRING    *command,          /* command to issue           */
256   PUSHORT      flags,                  /* error/failure flags        */
257   PRXSTRING    retstr )                /* return code                */
258 {
259     ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
260
261     if (rc)
262         *flags = RXSUBCOM_ERROR;         /* raise error condition    */
263
264     return 0;                            /* finished                   */
265 }
266
267 #define ArrLength(a) (sizeof(a)/sizeof(*(a)))
268
269 static const struct {
270   char *name;
271   RexxFunctionHandler *f;
272 } funcs[] = {
273              {"PERL",                   (RexxFunctionHandler *)&PERL},
274              {"PERLTERM",               (RexxFunctionHandler *)&PERLTERM},
275              {"PERLINIT",               (RexxFunctionHandler *)&PERLINIT},
276              {"PERLEXIT",               (RexxFunctionHandler *)&PERLEXIT},
277              {"PERLEVAL",               (RexxFunctionHandler *)&PERLEVAL},
278              {"PERLLASTERROR",          (RexxFunctionHandler *)&PERLLASTERROR},
279              {"PERLDROPALL",            (RexxFunctionHandler *)&PERLDROPALL},
280              {"PERLDROPALLEXIT",        (RexxFunctionHandler *)&PERLDROPALLEXIT},
281              /* Should be the last entry */
282              {"PERLEXPORTALL",          (RexxFunctionHandler *)&PERLEXPORTALL}
283           };
284
285 ULONG
286 PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
287 {
288    int i = -1;
289
290    while (++i < ArrLength(funcs) - 1)
291         RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
292    RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
293    retstr->strlength = 0;
294    return 0;
295 }
296
297 ULONG
298 PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
299 {
300    int i = -1;
301
302    while (++i < ArrLength(funcs))
303         RexxDeregisterFunction(funcs[i].name);
304    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
305    retstr->strlength = 0;
306    return 0;
307 }
308
309 ULONG
310 PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
311 {
312    int i = -1;
313
314    while (++i < ArrLength(funcs))
315         RexxDeregisterFunction(funcs[i].name);
316    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
317    PERL_SYS_TERM1(0);
318    retstr->strlength = 0;
319    return 0;
320 }