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