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