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