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