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