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, down from the door where it began."
  12  */
  13
  14 #ifdef OEMVS
  15 #ifdef MYMALLOC
  16 /* sbrk is limited to first heap segement so make it big */
  17 #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
  18 #else
  19 #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
  20 #endif
  21 #endif
  22
  23
  24 #include "EXTERN.h"
  25 #include "perl.h"
  26
  27 static void xs_init (pTHX);
  28 static PerlInterpreter *my_perl;
  29
  30 #if defined (__MINT__) || defined (atarist)
  31 /* The Atari operating system doesn't have a dynamic stack.  The
  32    stack size is determined from this value.  */
  33 long _stksize = 64 * 1024;
  34 #endif
  35
  36 /* Register any extra external extensions */
  37
  38 /* Do not delete this line--writemain depends on it */
  39 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  40
  41 static void
  42 xs_init(pTHX)
  43 {
  44     char *file = __FILE__;
  45     dXSUB_SYS;
  46         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  47 }
  48
  49 int perlos2_is_inited;
  50
  51 static void
  52 init_perlos2(void)
  53 {
  54 /*    static char *env[1] = {NULL};     */
  55
  56     Perl_OS2_init3(0, 0, 0);
  57 }
  58
  59 static int
  60 init_perl(int doparse)
  61 {
  62     int exitstatus;
  63     char *argv[3] = {"perl_in_REXX", "-e", ""};
  64
  65     if (!perlos2_is_inited) {
  66         perlos2_is_inited = 1;
  67         init_perlos2();
  68     }
  69     if (my_perl)
  70         return 1;
  71     if (!PL_do_undump) {
  72         my_perl = perl_alloc();
  73         if (!my_perl)
  74             return 0;
  75         perl_construct(my_perl);
  76         PL_perl_destruct_level = 1;
  77     }
  78     if (!doparse)
  79         return 1;
  80     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
  81     return !exitstatus;
  82 }
  83
  84 /* The REXX-callable entrypoints ... */
  85
  86 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
  87                     PCSZ queuename, PRXSTRING retstr)
  88 {
  89     int exitstatus;
  90     char buf[256];
  91     char *argv[3] = {"perl_from_REXX", "-e", buf};
  92     ULONG ret;
  93
  94     if (rargc != 1) {
  95         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
  96         retstr->strlength = strlen (retstr->strptr);
  97         return 1;
  98     }
  99     if (rargv[0].strlength >= sizeof(buf)) {
 100         sprintf(retstr->strptr,
 101                 "length of the argument %ld exceeds the maximum %ld",
 102                 rargv[0].strlength, (long)sizeof(buf) - 1);
 103         retstr->strlength = strlen (retstr->strptr);
 104         return 1;
 105     }
 106
 107     if (!init_perl(0))
 108         return 1;
 109
 110     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
 111     buf[rargv[0].strlength] = 0;
 112
 113     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 114     if (!exitstatus) {
 115         exitstatus = perl_run(my_perl);
 116     }
 117
 118     perl_destruct(my_perl);
 119     perl_free(my_perl);
 120     my_perl = 0;
 121
 122     if (exitstatus)
 123         ret = 1;
 124     else {
 125         ret = 0;
 126         sprintf(retstr->strptr, "%s", "ok");
 127         retstr->strlength = strlen (retstr->strptr);
 128     }
 129     PERL_SYS_TERM1(0);
 130     return ret;
 131 }
 132
 133 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 134                     PCSZ queuename, PRXSTRING retstr)
 135 {
 136     if (rargc != 0) {
 137         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 138         retstr->strlength = strlen (retstr->strptr);
 139         return 1;
 140     }
 141     PERL_SYS_TERM1(0);
 142     return 0;
 143 }
 144
 145 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 146                     PCSZ queuename, PRXSTRING retstr)
 147 {
 148     if (rargc != 0) {
 149         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 150         retstr->strlength = strlen (retstr->strptr);
 151         return 1;
 152     }
 153     if (!my_perl) {
 154         sprintf(retstr->strptr, "no perl interpreter present");
 155         retstr->strlength = strlen (retstr->strptr);
 156         return 1;
 157     }
 158     perl_destruct(my_perl);
 159     perl_free(my_perl);
 160     my_perl = 0;
 161
 162     sprintf(retstr->strptr, "%s", "ok");
 163     retstr->strlength = strlen (retstr->strptr);
 164     return 0;
 165 }
 166
 167
 168 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 169                     PCSZ queuename, PRXSTRING retstr)
 170 {
 171     if (rargc != 0) {
 172         sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
 173         retstr->strlength = strlen (retstr->strptr);
 174         return 1;
 175     }
 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 PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 185                     PCSZ queuename, PRXSTRING retstr)
 186 {
 187     SV *res, *in;
 188     STRLEN len;
 189     char *str;
 190
 191     if (rargc != 1) {
 192         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
 193         retstr->strlength = strlen (retstr->strptr);
 194         return 1;
 195     }
 196
 197     if (!init_perl(1))
 198         return 1;
 199
 200   {
 201     dSP;
 202     int ret;
 203
 204     ENTER;
 205     SAVETMPS;
 206
 207     PUSHMARK(SP);
 208     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
 209     eval_sv(in, G_SCALAR);
 210     SPAGAIN;
 211     res = POPs;
 212     PUTBACK;
 213
 214     ret = 0;
 215     if (SvTRUE(ERRSV) || !SvOK(res))
 216         ret = 1;
 217     str = SvPV(res, len);
 218     if (len <= 256                      /* Default buffer is 256-char long */
 219         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 220                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 221             memcpy(retstr->strptr, str, len);
 222             retstr->strlength = len;
 223     } else
 224         ret = 1;
 225
 226     FREETMPS;
 227     LEAVE;
 228
 229     return ret;
 230   }
 231 }
 232 #define INCL_DOSPROCESS
 233 #define INCL_DOSSEMAPHORES
 234 #define INCL_DOSMODULEMGR
 235 #define INCL_DOSMISC
 236 #define INCL_DOSEXCEPTIONS
 237 #define INCL_DOSERRORS
 238 #define INCL_REXXSAA
 239 #include <os2.h>
 240
 241 /*
 242  * "The Road goes ever on and on, down from the door where it began."
 243  */
 244
 245 #ifdef OEMVS
 246 #ifdef MYMALLOC
 247 /* sbrk is limited to first heap segement so make it big */
 248 #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
 249 #else
 250 #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
 251 #endif
 252 #endif
 253
 254
 255 #include "EXTERN.h"
 256 #include "perl.h"
 257
 258 static void xs_init (pTHX);
 259 static PerlInterpreter *my_perl;
 260
 261 #if defined (__MINT__) || defined (atarist)
 262 /* The Atari operating system doesn't have a dynamic stack.  The
 263    stack size is determined from this value.  */
 264 long _stksize = 64 * 1024;
 265 #endif
 266
 267 /* Register any extra external extensions */
 268
 269 /* Do not delete this line--writemain depends on it */
 270 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
 271
 272 static void
 273 xs_init(pTHX)
 274 {
 275     char *file = __FILE__;
 276     dXSUB_SYS;
 277         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 278 }
 279
 280 int perlos2_is_inited;
 281
 282 static void
 283 init_perlos2(void)
 284 {
 285 /*    static char *env[1] = {NULL};     */
 286
 287     Perl_OS2_init3(0, 0, 0);
 288 }
 289
 290 static int
 291 init_perl(int doparse)
 292 {
 293     int exitstatus;
 294     char *argv[3] = {"perl_in_REXX", "-e", ""};
 295
 296     if (!perlos2_is_inited) {
 297         perlos2_is_inited = 1;
 298         init_perlos2();
 299     }
 300     if (my_perl)
 301         return 1;
 302     if (!PL_do_undump) {
 303         my_perl = perl_alloc();
 304         if (!my_perl)
 305             return 0;
 306         perl_construct(my_perl);
 307         PL_perl_destruct_level = 1;
 308     }
 309     if (!doparse)
 310         return 1;
 311     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 312     return !exitstatus;
 313 }
 314
 315 /* The REXX-callable entrypoints ... */
 316
 317 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 318                     PCSZ queuename, PRXSTRING retstr)
 319 {
 320     int exitstatus;
 321     char buf[256];
 322     char *argv[3] = {"perl_from_REXX", "-e", buf};
 323     ULONG ret;
 324
 325     if (rargc != 1) {
 326         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
 327         retstr->strlength = strlen (retstr->strptr);
 328         return 1;
 329     }
 330     if (rargv[0].strlength >= sizeof(buf)) {
 331         sprintf(retstr->strptr,
 332                 "length of the argument %ld exceeds the maximum %ld",
 333                 rargv[0].strlength, (long)sizeof(buf) - 1);
 334         retstr->strlength = strlen (retstr->strptr);
 335         return 1;
 336     }
 337
 338     if (!init_perl(0))
 339         return 1;
 340
 341     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
 342     buf[rargv[0].strlength] = 0;
 343
 344     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 345     if (!exitstatus) {
 346         exitstatus = perl_run(my_perl);
 347     }
 348
 349     perl_destruct(my_perl);
 350     perl_free(my_perl);
 351     my_perl = 0;
 352
 353     if (exitstatus)
 354         ret = 1;
 355     else {
 356         ret = 0;
 357         sprintf(retstr->strptr, "%s", "ok");
 358         retstr->strlength = strlen (retstr->strptr);
 359     }
 360     PERL_SYS_TERM1(0);
 361     return ret;
 362 }
 363
 364 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 365                     PCSZ queuename, PRXSTRING retstr)
 366 {
 367     if (rargc != 0) {
 368         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 369         retstr->strlength = strlen (retstr->strptr);
 370         return 1;
 371     }
 372     PERL_SYS_TERM1(0);
 373     return 0;
 374 }
 375
 376 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 377                     PCSZ queuename, PRXSTRING retstr)
 378 {
 379     if (rargc != 0) {
 380         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 381         retstr->strlength = strlen (retstr->strptr);
 382         return 1;
 383     }
 384     if (!my_perl) {
 385         sprintf(retstr->strptr, "no perl interpreter present");
 386         retstr->strlength = strlen (retstr->strptr);
 387         return 1;
 388     }
 389     perl_destruct(my_perl);
 390     perl_free(my_perl);
 391     my_perl = 0;
 392
 393     sprintf(retstr->strptr, "%s", "ok");
 394     retstr->strlength = strlen (retstr->strptr);
 395     return 0;
 396 }
 397
 398
 399 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 400                     PCSZ queuename, PRXSTRING retstr)
 401 {
 402     if (rargc != 0) {
 403         sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
 404         retstr->strlength = strlen (retstr->strptr);
 405         return 1;
 406     }
 407     if (!init_perl(1))
 408         return 1;
 409
 410     sprintf(retstr->strptr, "%s", "ok");
 411     retstr->strlength = strlen (retstr->strptr);
 412     return 0;
 413 }
 414
 415 ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 416                     PCSZ queuename, PRXSTRING retstr)
 417 {
 418     SV *res, *in;
 419     STRLEN len;
 420     char *str;
 421
 422     if (rargc != 1) {
 423         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
 424         retstr->strlength = strlen (retstr->strptr);
 425         return 1;
 426     }
 427
 428     if (!init_perl(1))
 429         return 1;
 430
 431   {
 432     dSP;
 433     int ret;
 434
 435     ENTER;
 436     SAVETMPS;
 437
 438     PUSHMARK(SP);
 439     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
 440     eval_sv(in, G_SCALAR);
 441     SPAGAIN;
 442     res = POPs;
 443     PUTBACK;
 444
 445     ret = 0;
 446     if (SvTRUE(ERRSV) || !SvOK(res))
 447         ret = 1;
 448     str = SvPV(res, len);
 449     if (len <= 256                      /* Default buffer is 256-char long */
 450         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 451                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 452             memcpy(retstr->strptr, str, len);
 453             retstr->strlength = len;
 454     } else
 455         ret = 1;
 456
 457     FREETMPS;
 458     LEAVE;
 459
 460     return ret;
 461   }
 462 }