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