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