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