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