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 static RXSTRING   rxcommand    = {  9, "RXCOMMAND" };
  29 static RXSTRING   rxsubroutine = { 12, "RXSUBROUTINE" };
  30 static RXSTRING   rxfunction   = { 11, "RXFUNCTION" };
  31
  32 static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret);
  33
  34 #if 1
  35  #define Set    RXSHV_SET
  36  #define Fetch  RXSHV_FETCH
  37  #define Drop   RXSHV_DROPV
  38 #else
  39  #define Set    RXSHV_SYSET
  40  #define Fetch  RXSHV_SYFET
  41  #define Drop   RXSHV_SYDRO
  42 #endif
  43
  44 static long incompartment;
  45
  46 static SV*
  47 exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
  48 {
  49     dTHR;
  50     HMODULE hRexx, hRexxAPI;
  51     BYTE    buf[200];
  52     LONG    APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
  53                                     PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
  54     APIRET  APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
  55                                                   RexxFunctionHandler *);
  56     APIRET  APIENTRY (*pRexxDeregisterFunction) (PSZ);
  57     RXSTRING args[1];
  58     RXSTRING inst[2];
  59     RXSTRING result;
  60     USHORT   retcode;
  61     LONG rc;
  62     SV *res;
  63
  64     if (incompartment) die ("Attempt to reenter into REXX compartment");
  65     incompartment = 1;
  66
  67     if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
  68         || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
  69         || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
  70         || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
  71                             (PFN *)&pRexxRegisterFunctionExe)
  72         || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
  73                             (PFN *)&pRexxDeregisterFunction)) {
  74         die("REXX not available\n");
  75     }
  76
  77     if (handlerName)
  78         pRexxRegisterFunctionExe(handlerName, handler);
  79
  80     MAKERXSTRING(args[0], NULL, 0);
  81     MAKERXSTRING(inst[0], cmd,  strlen(cmd));
  82     MAKERXSTRING(inst[1], NULL, 0);
  83     MAKERXSTRING(result,  NULL, 0);
  84     rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
  85                     &retcode, &result);
  86
  87     incompartment = 0;
  88     pRexxDeregisterFunction("StartPerl");
  89     DosFreeModule(hRexxAPI);
  90     DosFreeModule(hRexx);
  91     if (!RXNULLSTRING(result)) {
  92         res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
  93         DosFreeMem(RXSTRPTR(result));
  94     } else {
  95         res = NEWSV(729,0);
  96     }
  97     if (rc || SvTRUE(GvSV(PL_errgv))) {
  98         if (SvTRUE(GvSV(PL_errgv))) {
  99             STRLEN n_a;
 100             die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
 101         }
 102         die ("REXX compartment returned non-zero status %li", rc);
 103     }
 104
 105     return res;
 106 }
 107
 108 static SV* exec_cv;
 109
 110 static ULONG
 111 PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
 112 {
 113     return PERLCALL(NULL, argc, argv, queue, ret);
 114 }
 115
 116 #define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \
 117                                            "StartPerl", PERLSTART)
 118 #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
 119 #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv),           \
 120                                       exec_in_REXX(cmd,name,PERLSTART))
 121 #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
 122
 123 static ULONG
 124 PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
 125 {
 126     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
 127     int i, rc;
 128     unsigned long len;
 129     char *str;
 130     char **arr;
 131     dSP;
 132
 133     DosSetExceptionHandler(&xreg);
 134
 135     ENTER;
 136     SAVETMPS;
 137     PUSHMARK(SP);
 138
 139 #if 0
 140     if (!my_perl) {
 141         DosUnsetExceptionHandler(&xreg);
 142         return 1;
 143     }
 144 #endif
 145
 146     if (name) {
 147         int ac = 0;
 148         char **arr = alloca((argc + 1) * sizeof(char *));
 149
 150         for (i = 0; i < argc; ++i)
 151             arr[ac++] = argv[i].strptr;
 152         arr[ac] = NULL;
 153
 154         rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr);
 155     } else if (exec_cv) {
 156         SV *cv = exec_cv;
 157
 158         exec_cv = NULL;
 159         rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
 160     } else rc = -1;
 161
 162     SPAGAIN;
 163
 164     if (rc == 1 && SvOK(TOPs)) {
 165         str = SvPVx(POPs, len);
 166         if (len > 256)
 167             if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 168                 DosUnsetExceptionHandler(&xreg);
 169                 return 1;
 170             }
 171         memcpy(ret->strptr, str, len);
 172         ret->strlength = len;
 173     }
 174
 175     PUTBACK ;
 176     FREETMPS ;
 177     LEAVE ;
 178
 179     if (rc != 1) {
 180         DosUnsetExceptionHandler(&xreg);
 181         return 1;
 182     }
 183
 184
 185     DosUnsetExceptionHandler(&xreg);
 186     return 0;
 187 }
 188
 189 static void
 190 needstrs(int n)
 191 {
 192     if (n > nstrs) {
 193         if (strs)
 194             free(strs);
 195         nstrs = 2 * n;
 196         strs = malloc(nstrs * sizeof(RXSTRING));
 197     }
 198 }
 199
 200 static void
 201 needvars(int n)
 202 {
 203     if (n > nvars) {
 204         if (vars)
 205             free(vars);
 206         nvars = 2 * n;
 207         vars = malloc(nvars * sizeof(SHVBLOCK));
 208     }
 209 }
 210
 211 static void
 212 initialize(void)
 213 {
 214     needstrs(8);
 215     needvars(8);
 216     trace = getenv("PERL_REXX_DEBUG");
 217 }
 218
 219 static int
 220 not_here(s)
 221 char *s;
 222 {
 223     croak("%s not implemented on this architecture", s);
 224     return -1;
 225 }
 226
 227 static int
 228 constant(name, arg)
 229 char *name;
 230 int arg;
 231 {
 232     errno = EINVAL;
 233     return 0;
 234 }
 235
 236
 237 MODULE = OS2::REXX              PACKAGE = OS2::REXX
 238
 239 BOOT:
 240         initialize();
 241
 242 int
 243 constant(name,arg)
 244         char *          name
 245         int             arg
 246
 247 SV *
 248 _call(name, address, queue="SESSION", ...)
 249         char *          name
 250         void *          address
 251         char *          queue
 252  CODE:
 253    {
 254        ULONG    rc;
 255        int      argc, i;
 256        RXSTRING result;
 257        UCHAR    resbuf[256];
 258        RexxFunctionHandler *fcn = address;
 259        argc = items-3;
 260        needstrs(argc);
 261        if (trace)
 262            fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
 263        for (i = 0; i < argc; ++i) {
 264            STRLEN len;
 265            char *ptr = SvPV(ST(3+i), len);
 266            MAKERXSTRING(strs[i], ptr, len);
 267            if (trace)
 268                fprintf(stderr, " '%.*s'", len, ptr);
 269        }
 270        if (!*queue)
 271            queue = "SESSION";
 272        if (trace)
 273            fprintf(stderr, "\n");
 274        MAKERXSTRING(result, resbuf, sizeof resbuf);
 275        rc = fcn(name, argc, strs, queue, &result);
 276        if (trace)
 277            fprintf(stderr, "  rc=%X, result='%.*s'\n", rc,
 278                    result.strlength, result.strptr);
 279        ST(0) = sv_newmortal();
 280        if (rc == 0) {
 281            if (result.strptr)
 282                sv_setpvn(ST(0), result.strptr, result.strlength);
 283            else
 284                sv_setpvn(ST(0), "", 0);
 285        }
 286        if (result.strptr && result.strptr != resbuf)
 287            DosFreeMem(result.strptr);
 288    }
 289
 290 int
 291 _set(name,value,...)
 292         char *          name
 293         char *          value
 294  CODE:
 295    {
 296        int   i;
 297        int   n = (items + 1) / 2;
 298        ULONG rc;
 299        needvars(n);
 300        if (trace)
 301            fprintf(stderr, "REXXCALL::_set");
 302        for (i = 0; i < n; ++i) {
 303            SHVBLOCK * var = &vars[i];
 304            STRLEN     namelen;
 305            STRLEN     valuelen;
 306            name = SvPV(ST(2*i+0),namelen);
 307            if (2*i+1 < items) {
 308                value = SvPV(ST(2*i+1),valuelen);
 309            }
 310            else {
 311                value = "";
 312                valuelen = 0;
 313            }
 314            var->shvcode = RXSHV_SET;
 315            var->shvnext = &vars[i+1];
 316            var->shvnamelen = namelen;
 317            var->shvvaluelen = valuelen;
 318            MAKERXSTRING(var->shvname, name, namelen);
 319            MAKERXSTRING(var->shvvalue, value, valuelen);
 320            if (trace)
 321                fprintf(stderr, " %.*s='%.*s'",
 322                        var->shvname.strlength, var->shvname.strptr,
 323                        var->shvvalue.strlength, var->shvvalue.strptr);
 324        }
 325        if (trace)
 326            fprintf(stderr, "\n");
 327        vars[n-1].shvnext = NULL;
 328        rc = RexxVariablePool(vars);
 329        if (trace)
 330            fprintf(stderr, "  rc=%X\n", rc);
 331        RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
 332    }
 333  OUTPUT:
 334     RETVAL
 335
 336 void
 337 _fetch(name, ...)
 338         char *          name
 339  PPCODE:
 340    {
 341        int   i;
 342        ULONG rc;
 343        EXTEND(SP, items);
 344        needvars(items);
 345        if (trace)
 346            fprintf(stderr, "REXXCALL::_fetch");
 347        for (i = 0; i < items; ++i) {
 348            SHVBLOCK * var = &vars[i];
 349            STRLEN     namelen;
 350            name = SvPV(ST(i),namelen);
 351            var->shvcode = RXSHV_FETCH;
 352            var->shvnext = &vars[i+1];
 353            var->shvnamelen = namelen;
 354            var->shvvaluelen = 0;
 355            MAKERXSTRING(var->shvname, name, namelen);
 356            MAKERXSTRING(var->shvvalue, NULL, 0);
 357            if (trace)
 358                fprintf(stderr, " '%s'", name);
 359        }
 360        if (trace)
 361            fprintf(stderr, "\n");
 362        vars[items-1].shvnext = NULL;
 363        rc = RexxVariablePool(vars);
 364        if (!(rc & ~RXSHV_NEWV)) {
 365            for (i = 0; i < items; ++i) {
 366                int namelen;
 367                SHVBLOCK * var = &vars[i];
 368                /* returned lengths appear to be swapped */
 369                /* but beware of "future bug fixes" */
 370                namelen = var->shvvalue.strlength; /* should be */
 371                if (var->shvvaluelen < var->shvvalue.strlength)
 372                    namelen = var->shvvaluelen; /* is */
 373                if (trace)
 374                    fprintf(stderr, "  %.*s='%.*s'\n",
 375                            var->shvname.strlength, var->shvname.strptr,
 376                            namelen, var->shvvalue.strptr);
 377                if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
 378                    PUSHs(&PL_sv_undef);
 379                else
 380                    PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
 381                                             namelen)));
 382            }
 383        } else {
 384            if (trace)
 385                fprintf(stderr, "  rc=%X\n", rc);
 386        }
 387    }
 388
 389 void
 390 _next(stem)
 391         char *  stem
 392  PPCODE:
 393    {
 394        SHVBLOCK sv;
 395        BYTE     name[4096];
 396        ULONG    rc;
 397        int      len = strlen(stem), namelen, valuelen;
 398        if (trace)
 399            fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
 400        sv.shvcode = RXSHV_NEXTV;
 401        sv.shvnext = NULL;
 402        MAKERXSTRING(sv.shvvalue, NULL, 0);
 403        do {
 404            sv.shvnamelen = sizeof name;
 405            sv.shvvaluelen = 0;
 406            MAKERXSTRING(sv.shvname, name, sizeof name);
 407            if (sv.shvvalue.strptr) {
 408                DosFreeMem(sv.shvvalue.strptr);
 409                MAKERXSTRING(sv.shvvalue, NULL, 0);
 410            }
 411            rc = RexxVariablePool(&sv);
 412        } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
 413        if (!rc) {
 414            EXTEND(SP, 2);
 415            /* returned lengths appear to be swapped */
 416            /* but beware of "future bug fixes" */
 417            namelen = sv.shvname.strlength; /* should be */
 418            if (sv.shvnamelen < sv.shvname.strlength)
 419                namelen = sv.shvnamelen; /* is */
 420            valuelen = sv.shvvalue.strlength; /* should be */
 421            if (sv.shvvaluelen < sv.shvvalue.strlength)
 422                valuelen = sv.shvvaluelen; /* is */
 423            if (trace)
 424                fprintf(stderr, "  %.*s='%.*s'\n",
 425                        namelen, sv.shvname.strptr,
 426                        valuelen, sv.shvvalue.strptr);
 427            PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
 428            if (sv.shvvalue.strptr) {
 429                PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
 430                                 DosFreeMem(sv.shvvalue.strptr);
 431            } else
 432                PUSHs(&PL_sv_undef);
 433        } else if (rc != RXSHV_LVAR) {
 434            die("Error %i when in _next", rc);
 435        } else {
 436            if (trace)
 437                fprintf(stderr, "  rc=%X\n", rc);
 438        }
 439    }
 440
 441 int
 442 _drop(name,...)
 443         char *          name
 444  CODE:
 445    {
 446        int i;
 447        needvars(items);
 448        for (i = 0; i < items; ++i) {
 449            SHVBLOCK * var = &vars[i];
 450            STRLEN     namelen;
 451            name = SvPV(ST(i),namelen);
 452            var->shvcode = RXSHV_DROPV;
 453            var->shvnext = &vars[i+1];
 454            var->shvnamelen = namelen;
 455            var->shvvaluelen = 0;
 456            MAKERXSTRING(var->shvname, name, var->shvnamelen);
 457            MAKERXSTRING(var->shvvalue, NULL, 0);
 458        }
 459        vars[items-1].shvnext = NULL;
 460        RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
 461    }
 462  OUTPUT:
 463     RETVAL
 464
 465 int
 466 _register(name)
 467         char *  name
 468  CODE:
 469     RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
 470  OUTPUT:
 471     RETVAL
 472
 473 SV*
 474 REXX_call(cv)
 475         SV *cv
 476   PROTOTYPE: &
 477
 478 SV*
 479 REXX_eval(cmd)
 480         char *cmd
 481
 482 SV*
 483 REXX_eval_with(cmd,name,cv)
 484         char *cmd
 485         char *name
 486         SV *cv