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 (__MINT__) || 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 } 327