os2/OS2/REXX/REXX.xs

   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 preceeded 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(729,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, Nullsv, 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 = Nullsv;
 560         Safefree(names);
 561         Safefree(cvs);
 562    }
 563  OUTPUT:
 564     RETVAL
 565
 566 #endif