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