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