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