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