os2/perlrexx.c

   1 #define INCL_DOSPROCESS
   2 #define INCL_DOSSEMAPHORES
   3 #define INCL_DOSMODULEMGR
   4 #define INCL_DOSMISC
   5 #define INCL_DOSEXCEPTIONS
   6 #define INCL_DOSERRORS
   7 #define INCL_REXXSAA
   8 #include <os2.h>
   9
  10 /*
  11  *      The Road goes ever on and on
  12  *          Down from the door where it began.
  13  *
  14  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  15  *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
  16  */
  17
  18 #ifdef OEMVS
  19 #ifdef MYMALLOC
  20 /* sbrk is limited to first heap segement so make it big */
  21 #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
  22 #else
  23 #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
  24 #endif
  25 #endif
  26
  27
  28 #include "EXTERN.h"
  29 #include "perl.h"
  30
  31 static void xs_init (pTHX);
  32 static PerlInterpreter *my_perl;
  33
  34 ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  35 ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  36 ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  37
  38 #if defined (atarist)
  39 /* The Atari operating system doesn't have a dynamic stack.  The
  40    stack size is determined from this value.  */
  41 long _stksize = 64 * 1024;
  42 #endif
  43
  44 /* Register any extra external extensions */
  45
  46 /* Do not delete this line--writemain depends on it */
  47 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  48
  49 static void
  50 xs_init(pTHX)
  51 {
  52     char *file = __FILE__;
  53     dXSUB_SYS;
  54         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  55 }
  56
  57 int perlos2_is_inited;
  58
  59 static void
  60 init_perlos2(void)
  61 {
  62 /*    static char *env[1] = {NULL};     */
  63
  64     Perl_OS2_init3(0, 0, 0);
  65 }
  66
  67 static int
  68 init_perl(int doparse)
  69 {
  70     int exitstatus;
  71     char *argv[3] = {"perl_in_REXX", "-e", ""};
  72
  73     if (!perlos2_is_inited) {
  74         perlos2_is_inited = 1;
  75         init_perlos2();
  76     }
  77     if (my_perl)
  78         return 1;
  79     if (!PL_do_undump) {
  80         my_perl = perl_alloc();
  81         if (!my_perl)
  82             return 0;
  83         perl_construct(my_perl);
  84         PL_perl_destruct_level = 1;
  85     }
  86     if (!doparse)
  87         return 1;
  88     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
  89     return !exitstatus;
  90 }
  91
  92 static char last_error[4096];
  93
  94 static int
  95 seterr(char *format, ...)
  96 {
  97         va_list va;
  98         char *s = last_error;
  99
 100         va_start(va, format);
 101         if (s[0]) {
 102             s += strlen(s);
 103             if (s[-1] != '\n') {
 104                 snprintf(s, sizeof(last_error) - (s - last_error), "\n");
 105                 s += strlen(s);
 106             }
 107         }
 108         vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
 109         return 1;
 110 }
 111
 112 /* The REXX-callable entrypoints ... */
 113
 114 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 115                     PCSZ queuename, PRXSTRING retstr)
 116 {
 117     int exitstatus;
 118     char buf[256];
 119     char *argv[3] = {"perl_from_REXX", "-e", buf};
 120     ULONG ret;
 121
 122     if (rargc != 1)
 123         return seterr("one argument expected, got %ld", rargc);
 124     if (rargv[0].strlength >= sizeof(buf))
 125         return seterr("length of the argument %ld exceeds the maximum %ld",
 126                       rargv[0].strlength, (long)sizeof(buf) - 1);
 127
 128     if (!init_perl(0))
 129         return 1;
 130
 131     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
 132     buf[rargv[0].strlength] = 0;
 133
 134     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 135     if (!exitstatus) {
 136         exitstatus = perl_run(my_perl);
 137     }
 138
 139     perl_destruct(my_perl);
 140     perl_free(my_perl);
 141     my_perl = 0;
 142
 143     if (exitstatus)
 144         ret = 1;
 145     else {
 146         ret = 0;
 147         sprintf(retstr->strptr, "%s", "ok");
 148         retstr->strlength = strlen (retstr->strptr);
 149     }
 150     PERL_SYS_TERM1(0);
 151     return ret;
 152 }
 153
 154 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 155                     PCSZ queuename, PRXSTRING retstr)
 156 {
 157     if (rargc != 0)
 158         return seterr("no arguments expected, got %ld", rargc);
 159     PERL_SYS_TERM1(0);
 160     return 0;
 161 }
 162
 163 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 164                     PCSZ queuename, PRXSTRING retstr)
 165 {
 166     if (rargc != 0)
 167         return seterr("no arguments expected, got %ld", rargc);
 168     if (!my_perl)
 169         return seterr("no perl interpreter present");
 170     perl_destruct(my_perl);
 171     perl_free(my_perl);
 172     my_perl = 0;
 173
 174     sprintf(retstr->strptr, "%s", "ok");
 175     retstr->strlength = strlen (retstr->strptr);
 176     return 0;
 177 }
 178
 179
 180 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 181                     PCSZ queuename, PRXSTRING retstr)
 182 {
 183     if (rargc != 0)
 184         return seterr("no argument expected, got %ld", rargc);
 185     if (!init_perl(1))
 186         return 1;
 187
 188     sprintf(retstr->strptr, "%s", "ok");
 189     retstr->strlength = strlen (retstr->strptr);
 190     return 0;
 191 }
 192
 193 ULONG
 194 PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 195 {
 196     int len = strlen(last_error);
 197
 198     if (len <= 256                      /* Default buffer is 256-char long */
 199         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 200                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 201             memcpy(retstr->strptr, last_error, len);
 202             retstr->strlength = len;
 203     } else {
 204         strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
 205         retstr->strlength = strlen(retstr->strptr);
 206     }
 207     return 0;
 208 }
 209
 210 ULONG
 211 PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 212 {
 213     SV *res, *in;
 214     STRLEN len, n_a;
 215     char *str;
 216
 217     last_error[0] = 0;
 218     if (rargc != 1)
 219         return seterr("one argument expected, got %ld", rargc);
 220
 221     if (!init_perl(1))
 222         return seterr("error initializing perl");
 223
 224   {
 225     dSP;
 226     int ret;
 227
 228     ENTER;
 229     SAVETMPS;
 230
 231     PUSHMARK(SP);
 232     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
 233     eval_sv(in, G_SCALAR);
 234     SPAGAIN;
 235     res = POPs;
 236     PUTBACK;
 237
 238     ret = 0;
 239     if (SvTRUE(ERRSV))
 240         ret = seterr(SvPV(ERRSV, n_a));
 241     if (!SvOK(res))
 242         ret = seterr("undefined value returned by Perl-in-REXX");
 243     str = SvPV(res, len);
 244     if (len <= 256                      /* Default buffer is 256-char long */
 245         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 246                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 247             memcpy(retstr->strptr, str, len);
 248             retstr->strlength = len;
 249     } else
 250         ret = seterr("Not enough memory for the return string of Perl-in-REXX");
 251
 252     FREETMPS;
 253     LEAVE;
 254
 255     return ret;
 256   }
 257 }
 258
 259 ULONG
 260 PERLEVALSUBCOMMAND(
 261   const RXSTRING    *command,          /* command to issue           */
 262   PUSHORT      flags,                  /* error/failure flags        */
 263   PRXSTRING    retstr )                /* return code                */
 264 {
 265     ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
 266
 267     if (rc)
 268         *flags = RXSUBCOM_ERROR;         /* raise error condition    */
 269
 270     return 0;                            /* finished                   */
 271 }
 272
 273 #define ArrLength(a) (sizeof(a)/sizeof(*(a)))
 274
 275 static const struct {
 276   char *name;
 277   RexxFunctionHandler *f;
 278 } funcs[] = {
 279              {"PERL",                   (RexxFunctionHandler *)&PERL},
 280              {"PERLTERM",               (RexxFunctionHandler *)&PERLTERM},
 281              {"PERLINIT",               (RexxFunctionHandler *)&PERLINIT},
 282              {"PERLEXIT",               (RexxFunctionHandler *)&PERLEXIT},
 283              {"PERLEVAL",               (RexxFunctionHandler *)&PERLEVAL},
 284              {"PERLLASTERROR",          (RexxFunctionHandler *)&PERLLASTERROR},
 285              {"PERLDROPALL",            (RexxFunctionHandler *)&PERLDROPALL},
 286              {"PERLDROPALLEXIT",        (RexxFunctionHandler *)&PERLDROPALLEXIT},
 287              /* Should be the last entry */
 288              {"PERLEXPORTALL",          (RexxFunctionHandler *)&PERLEXPORTALL}
 289           };
 290
 291 ULONG
 292 PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 293 {
 294    int i = -1;
 295
 296    while (++i < ArrLength(funcs) - 1)
 297         RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
 298    RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
 299    retstr->strlength = 0;
 300    return 0;
 301 }
 302
 303 ULONG
 304 PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 305 {
 306    int i = -1;
 307
 308    while (++i < ArrLength(funcs))
 309         RexxDeregisterFunction(funcs[i].name);
 310    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
 311    retstr->strlength = 0;
 312    return 0;
 313 }
 314
 315 ULONG
 316 PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 317 {
 318    int i = -1;
 319
 320    while (++i < ArrLength(funcs))
 321         RexxDeregisterFunction(funcs[i].name);
 322    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
 323    PERL_SYS_TERM1(0);
 324    retstr->strlength = 0;
 325    return 0;
 326 }