1 #include "EXTERN.h" 2 #include "perl.h" 3 #include "XSUB.h" 4 5 #define INCL_BASE 6 #define INCL_REXXSAA 7 #include <os2emx.h> 8 9 #if 0 10 #define INCL_REXXSAA 11 #pragma pack(1) 12 #define _Packed 13 #include <rexxsaa.h> 14 #pragma pack() 15 #endif 16 17 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, 18 EXCEPTIONREGISTRATIONRECORD *, 19 CONTEXTRECORD *, 20 void *); 21 22 static RXSTRING * strs; 23 static int nstrs; 24 static SHVBLOCK * vars; 25 static int nvars; 26 static char * trace; 27 28 /* 29 static RXSTRING rxcommand = { 9, "RXCOMMAND" }; 30 static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; 31 static RXSTRING rxfunction = { 11, "RXFUNCTION" }; 32 */ 33 34 static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); 35 static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); 36 static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); 37 static RexxSubcomHandler SubCommandPerlEval; 38 39 #if 1 40 #define Set RXSHV_SET 41 #define Fetch RXSHV_FETCH 42 #define Drop RXSHV_DROPV 43 #else 44 #define Set RXSHV_SYSET 45 #define Fetch RXSHV_SYFET 46 #define Drop RXSHV_SYDRO 47 #endif 48 49 static long incompartment; /* May be used to unload the REXX */ 50 51 static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, 52 PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); 53 static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, 54 RexxFunctionHandler *); 55 static APIRET APIENTRY (*pRexxRegisterSubcomExe) (PCSZ pszEnvName, PFN pfnEntryPoint, 56 PUCHAR pUserArea); 57 static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); 58 59 static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest); 60 61 static SV* exec_cv; 62 63 /* Create a REXX compartment, 64 register `n' callbacks `handlers' with the REXX names `handlerNames', 65 evaluate the REXX expression `cmd'. 66 */ 67 static SV* 68 exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers) 69 { 70 RXSTRING args[1]; 71 RXSTRING inst[2]; 72 RXSTRING result; 73 USHORT retcode; 74 LONG rc; 75 SV *res; 76 char *subs = 0; 77 int n = c, have_nl = 0; 78 char *ocmd = cmd, *s, *t; 79 80 incompartment++; 81 82 if (c) 83 Newxz(subs, c, char); 84 while (n--) { 85 rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]); 86 if (rc == RXFUNC_DEFINED) 87 subs[n] = 1; 88 } 89 90 s = cmd; 91 while (*s) { 92 if (*s == '\n') { /* Is not preceded by \r! */ 93 Newx(cmd, 2*strlen(cmd)+1, char); 94 s = ocmd; 95 t = cmd; 96 while (*s) { 97 if (*s == '\n') 98 *t++ = '\r'; 99 *t++ = *s++; 100 } 101 *t = 0; 102 break; 103 } else if (*s == '\r') 104 s++; 105 s++; 106 } 107 MAKERXSTRING(args[0], NULL, 0); 108 MAKERXSTRING(inst[0], cmd, strlen(cmd)); 109 MAKERXSTRING(inst[1], NULL, 0); 110 MAKERXSTRING(result, NULL, 0); 111 rc = pRexxStart(0, args, /* No arguments */ 112 "REXX_in_Perl", /* Returned on REXX' PARSE SOURCE, 113 and the "macrospace function name" */ 114 inst, /* inst[0] - the code to execute, 115 inst[1] will contain tokens. */ 116 "Perl", /* Pass string-cmds to this callback */ 117 RXSUBROUTINE, /* Many arguments, maybe result */ 118 NULL, /* No callbacks/exits to register */ 119 &retcode, &result); 120 121 incompartment--; 122 n = c; 123 while (n--) 124 if (!subs[n]) 125 pRexxDeregisterFunction(handlerNames[n]); 126 if (c) 127 Safefree(subs); 128 if (cmd != ocmd) 129 Safefree(cmd); 130 #if 0 /* Do we want to restore these? */ 131 DosFreeModule(hRexxAPI); 132 DosFreeModule(hRexx); 133 #endif 134 135 if (RXSTRPTR(inst[1])) /* Free the tokenized version */ 136 DosFreeMem(RXSTRPTR(inst[1])); 137 if (!RXNULLSTRING(result)) { 138 res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); 139 DosFreeMem(RXSTRPTR(result)); 140 } else { 141 res = newSV(0); 142 } 143 if (rc || SvTRUE(GvSV(PL_errgv))) { 144 if (SvTRUE(GvSV(PL_errgv))) { 145 STRLEN n_a; 146 Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ; 147 } 148 Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc); 149 } 150 151 return res; 152 } 153 154 /* Call the Perl function given by name, or if name=0, by cv, 155 with the given arguments. Return the stringified result to REXX. */ 156 static ULONG 157 PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) 158 { 159 dTHX; 160 EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; 161 int i, rc; 162 unsigned long len; 163 char *str; 164 SV *res; 165 dSP; 166 167 DosSetExceptionHandler(&xreg); 168 169 ENTER; 170 SAVETMPS; 171 PUSHMARK(SP); 172 173 #if 0 174 if (!my_perl) { 175 DosUnsetExceptionHandler(&xreg); 176 return 1; 177 } 178 #endif 179 180 for (i = 0; i < argc; ++i) 181 XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength))); 182 PUTBACK; 183 if (name) 184 rc = perl_call_pv(name, G_SCALAR | G_EVAL); 185 else if (cv) 186 rc = perl_call_sv(cv, G_SCALAR | G_EVAL); 187 else 188 rc = -1; 189 190 SPAGAIN; 191 192 if (rc == 1) /* must be! */ 193 res = POPs; 194 if (rc == 1 && SvOK(res)) { 195 str = SvPVx(res, len); 196 if (len <= 256 /* Default buffer is 256-char long */ 197 || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len, 198 PAG_READ|PAG_WRITE|PAG_COMMIT))) { 199 memcpy(ret->strptr, str, len); 200 ret->strlength = len; 201 } else 202 rc = 0; 203 } else 204 rc = 0; 205 206 PUTBACK ; 207 FREETMPS ; 208 LEAVE ; 209 210 DosUnsetExceptionHandler(&xreg); 211 return rc == 1 ? 0 : 1; /* 0 means SUCCESS */ 212 } 213 214 static ULONG 215 PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) 216 { 217 SV *cv = exec_cv; 218 219 exec_cv = NULL; 220 return PERLCALLcv(NULL, cv, argc, argv, queue, ret); 221 } 222 223 static ULONG 224 PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) 225 { 226 return PERLCALLcv(name, NULL, argc, argv, queue, ret); 227 } 228 229 RexxFunctionHandler* PF = &PERLSTART; 230 char* PF_name = "StartPerl"; 231 232 #define REXX_eval_with(cmd,name,cv) \ 233 ( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF)) 234 #define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv)) 235 #define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL)) 236 237 static ULONG 238 SubCommandPerlEval( 239 PRXSTRING command, /* command to issue */ 240 PUSHORT flags, /* error/failure flags */ 241 PRXSTRING retstr ) /* return code */ 242 { 243 dSP; 244 STRLEN len; 245 int ret; 246 char *str = 0; 247 SV *in, *res; 248 249 ENTER; 250 SAVETMPS; 251 252 PUSHMARK(SP); 253 in = sv_2mortal(newSVpvn(command->strptr, command->strlength)); 254 eval_sv(in, G_SCALAR); 255 SPAGAIN; 256 res = POPs; 257 PUTBACK; 258 259 ret = 0; 260 if (SvTRUE(ERRSV)) { 261 *flags = RXSUBCOM_ERROR; /* raise error condition */ 262 str = SvPV(ERRSV, len); 263 } else if (!SvOK(res)) { 264 *flags = RXSUBCOM_ERROR; /* raise error condition */ 265 str = "undefined value returned by Perl-in-REXX"; 266 len = strlen(str); 267 } else 268 str = SvPV(res, len); 269 if (len <= 256 /* Default buffer is 256-char long */ 270 || !DosAllocMem((PPVOID)&retstr->strptr, len, 271 PAG_READ|PAG_WRITE|PAG_COMMIT)) { 272 memcpy(retstr->strptr, str, len); 273 retstr->strlength = len; 274 } else { 275 *flags = RXSUBCOM_ERROR; /* raise error condition */ 276 strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX"); 277 retstr->strlength = strlen(retstr->strptr); 278 } 279 280 FREETMPS; 281 LEAVE; 282 283 return 0; /* finished */ 284 } 285 286 static void 287 needstrs(int n) 288 { 289 if (n > nstrs) { 290 if (strs) 291 free(strs); 292 nstrs = 2 * n; 293 strs = malloc(nstrs * sizeof(RXSTRING)); 294 } 295 } 296 297 static void 298 needvars(int n) 299 { 300 if (n > nvars) { 301 if (vars) 302 free(vars); 303 nvars = 2 * n; 304 vars = malloc(nvars * sizeof(SHVBLOCK)); 305 } 306 } 307 308 static void 309 initialize(void) 310 { 311 ULONG rc; 312 *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1); 313 *(PFN *)&pRexxRegisterFunctionExe 314 = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1); 315 *(PFN *)&pRexxDeregisterFunction 316 = loadByOrdinal(ORD_RexxDeregisterFunction, 1); 317 *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1); 318 *(PFN *)&pRexxRegisterSubcomExe 319 = loadByOrdinal(ORD_RexxRegisterSubcomExe, 1); 320 needstrs(8); 321 needvars(8); 322 trace = getenv("PERL_REXX_DEBUG"); 323 324 rc = pRexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); 325 } 326 327 static int 328 constant(char *name, int arg) 329 { 330 errno = EINVAL; 331 return 0; 332 } 333 334 335 MODULE = OS2::REXX PACKAGE = OS2::REXX 336 337 BOOT: 338 initialize(); 339 340 int 341 constant(name,arg) 342 char * name 343 int arg 344 345 int 346 _set(name,value,...) 347 char * name 348 char * value 349 CODE: 350 { 351 int i; 352 int n = (items + 1) / 2; 353 ULONG rc; 354 needvars(n); 355 if (trace) 356 fprintf(stderr, "REXXCALL::_set"); 357 for (i = 0; i < n; ++i) { 358 SHVBLOCK * var = &vars[i]; 359 STRLEN namelen; 360 STRLEN valuelen; 361 name = SvPV(ST(2*i+0),namelen); 362 if (2*i+1 < items) { 363 value = SvPV(ST(2*i+1),valuelen); 364 } 365 else { 366 value = ""; 367 valuelen = 0; 368 } 369 var->shvcode = RXSHV_SET; 370 var->shvnext = &vars[i+1]; 371 var->shvnamelen = namelen; 372 var->shvvaluelen = valuelen; 373 MAKERXSTRING(var->shvname, name, namelen); 374 MAKERXSTRING(var->shvvalue, value, valuelen); 375 if (trace) 376 fprintf(stderr, " %.*s='%.*s'", 377 (int)var->shvname.strlength, var->shvname.strptr, 378 (int)var->shvvalue.strlength, var->shvvalue.strptr); 379 } 380 if (trace) 381 fprintf(stderr, "\n"); 382 vars[n-1].shvnext = NULL; 383 rc = pRexxVariablePool(vars); 384 if (trace) 385 fprintf(stderr, " rc=%#lX\n", rc); 386 RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; 387 } 388 OUTPUT: 389 RETVAL 390 391 void 392 _fetch(name, ...) 393 char * name 394 PPCODE: 395 { 396 int i; 397 ULONG rc; 398 EXTEND(SP, items); 399 needvars(items); 400 if (trace) 401 fprintf(stderr, "REXXCALL::_fetch"); 402 for (i = 0; i < items; ++i) { 403 SHVBLOCK * var = &vars[i]; 404 STRLEN namelen; 405 name = SvPV(ST(i),namelen); 406 var->shvcode = RXSHV_FETCH; 407 var->shvnext = &vars[i+1]; 408 var->shvnamelen = namelen; 409 var->shvvaluelen = 0; 410 MAKERXSTRING(var->shvname, name, namelen); 411 MAKERXSTRING(var->shvvalue, NULL, 0); 412 if (trace) 413 fprintf(stderr, " '%s'", name); 414 } 415 if (trace) 416 fprintf(stderr, "\n"); 417 vars[items-1].shvnext = NULL; 418 rc = pRexxVariablePool(vars); 419 if (!(rc & ~RXSHV_NEWV)) { 420 for (i = 0; i < items; ++i) { 421 int namelen; 422 SHVBLOCK * var = &vars[i]; 423 /* returned lengths appear to be swapped */ 424 /* but beware of "future bug fixes" */ 425 namelen = var->shvvalue.strlength; /* should be */ 426 if (var->shvvaluelen < var->shvvalue.strlength) 427 namelen = var->shvvaluelen; /* is */ 428 if (trace) 429 fprintf(stderr, " %.*s='%.*s'\n", 430 (int)var->shvname.strlength, var->shvname.strptr, 431 namelen, var->shvvalue.strptr); 432 if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) 433 PUSHs(&PL_sv_undef); 434 else 435 PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, 436 namelen))); 437 } 438 } else { 439 if (trace) 440 fprintf(stderr, " rc=%#lX\n", rc); 441 } 442 } 443 444 void 445 _next(stem) 446 char * stem 447 PPCODE: 448 { 449 SHVBLOCK sv; 450 BYTE name[4096]; 451 ULONG rc; 452 int len = strlen(stem), namelen, valuelen; 453 if (trace) 454 fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); 455 sv.shvcode = RXSHV_NEXTV; 456 sv.shvnext = NULL; 457 MAKERXSTRING(sv.shvvalue, NULL, 0); 458 do { 459 sv.shvnamelen = sizeof name; 460 sv.shvvaluelen = 0; 461 MAKERXSTRING(sv.shvname, name, sizeof name); 462 if (sv.shvvalue.strptr) { 463 DosFreeMem(sv.shvvalue.strptr); 464 MAKERXSTRING(sv.shvvalue, NULL, 0); 465 } 466 rc = pRexxVariablePool(&sv); 467 } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); 468 if (!rc) { 469 EXTEND(SP, 2); 470 /* returned lengths appear to be swapped */ 471 /* but beware of "future bug fixes" */ 472 namelen = sv.shvname.strlength; /* should be */ 473 if (sv.shvnamelen < sv.shvname.strlength) 474 namelen = sv.shvnamelen; /* is */ 475 valuelen = sv.shvvalue.strlength; /* should be */ 476 if (sv.shvvaluelen < sv.shvvalue.strlength) 477 valuelen = sv.shvvaluelen; /* is */ 478 if (trace) 479 fprintf(stderr, " %.*s='%.*s'\n", 480 namelen, sv.shvname.strptr, 481 valuelen, sv.shvvalue.strptr); 482 PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); 483 if (sv.shvvalue.strptr) { 484 PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); 485 DosFreeMem(sv.shvvalue.strptr); 486 } else 487 PUSHs(&PL_sv_undef); 488 } else if (rc != RXSHV_LVAR) { 489 die("Error %i when in _next", rc); 490 } else { 491 if (trace) 492 fprintf(stderr, " rc=%#lX\n", rc); 493 } 494 } 495 496 int 497 _drop(name,...) 498 char * name 499 CODE: 500 { 501 int i; 502 needvars(items); 503 for (i = 0; i < items; ++i) { 504 SHVBLOCK * var = &vars[i]; 505 STRLEN namelen; 506 name = SvPV(ST(i),namelen); 507 var->shvcode = RXSHV_DROPV; 508 var->shvnext = &vars[i+1]; 509 var->shvnamelen = namelen; 510 var->shvvaluelen = 0; 511 MAKERXSTRING(var->shvname, name, var->shvnamelen); 512 MAKERXSTRING(var->shvvalue, NULL, 0); 513 } 514 vars[items-1].shvnext = NULL; 515 RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; 516 } 517 OUTPUT: 518 RETVAL 519 520 int 521 _register(name) 522 char * name 523 CODE: 524 RETVAL = pRexxRegisterFunctionExe(name, PERLCALL); 525 OUTPUT: 526 RETVAL 527 528 SV* 529 REXX_call(cv) 530 SV *cv 531 PROTOTYPE: & 532 533 SV* 534 REXX_eval(cmd) 535 char *cmd 536 537 SV* 538 REXX_eval_with(cmd,name,cv) 539 char *cmd 540 char *name 541 SV *cv 542 543 #ifdef THIS_IS_NOT_FINISHED 544 545 SV* 546 _REXX_eval_with(cmd,...) 547 char *cmd 548 CODE: 549 { 550 int n = (items - 1)/2; 551 char **names; 552 SV **cvs; 553 554 if ((items % 2) == 0) 555 Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()"); 556 Newx(names, n, char*); 557 Newx(cvs, n, SV*); 558 /* XXX Unfinished... */ 559 RETVAL = NULL; 560 Safefree(names); 561 Safefree(cvs); 562 } 563 OUTPUT: 564 RETVAL 565 566 #endif 567