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