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