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