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 ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  31 ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  32 ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr);
  33
  34 #if defined (__MINT__) || defined (atarist)
  35 /* The Atari operating system doesn't have a dynamic stack.  The
  36    stack size is determined from this value.  */
  37 long _stksize = 64 * 1024;
  38 #endif
  39
  40 /* Register any extra external extensions */
  41
  42 /* Do not delete this line--writemain depends on it */
  43 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  44
  45 static void
  46 xs_init(pTHX)
  47 {
  48     char *file = __FILE__;
  49     dXSUB_SYS;
  50         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  51 }
  52
  53 int perlos2_is_inited;
  54
  55 static void
  56 init_perlos2(void)
  57 {
  58 /*    static char *env[1] = {NULL};     */
  59
  60     Perl_OS2_init3(0, 0, 0);
  61 }
  62
  63 static int
  64 init_perl(int doparse)
  65 {
  66     int exitstatus;
  67     char *argv[3] = {"perl_in_REXX", "-e", ""};
  68
  69     if (!perlos2_is_inited) {
  70         perlos2_is_inited = 1;
  71         init_perlos2();
  72     }
  73     if (my_perl)
  74         return 1;
  75     if (!PL_do_undump) {
  76         my_perl = perl_alloc();
  77         if (!my_perl)
  78             return 0;
  79         perl_construct(my_perl);
  80         PL_perl_destruct_level = 1;
  81     }
  82     if (!doparse)
  83         return 1;
  84     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
  85     return !exitstatus;
  86 }
  87
  88 static char last_error[4096];
  89
  90 static int
  91 seterr(char *format, ...)
  92 {
  93         va_list va;
  94         char *s = last_error;
  95
  96         va_start(va, format);
  97         if (s[0]) {
  98             s += strlen(s);
  99             if (s[-1] != '\n') {
 100                 snprintf(s, sizeof(last_error) - (s - last_error), "\n");
 101                 s += strlen(s);
 102             }
 103         }
 104         vsnprintf(s, sizeof(last_error) - (s - last_error), format, va);
 105         return 1;
 106 }
 107
 108 /* The REXX-callable entrypoints ... */
 109
 110 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 111                     PCSZ queuename, PRXSTRING retstr)
 112 {
 113     int exitstatus;
 114     char buf[256];
 115     char *argv[3] = {"perl_from_REXX", "-e", buf};
 116     ULONG ret;
 117
 118     if (rargc != 1)
 119         return seterr("one argument expected, got %ld", rargc);
 120     if (rargv[0].strlength >= sizeof(buf))
 121         return seterr("length of the argument %ld exceeds the maximum %ld",
 122                       rargv[0].strlength, (long)sizeof(buf) - 1);
 123
 124     if (!init_perl(0))
 125         return 1;
 126
 127     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
 128     buf[rargv[0].strlength] = 0;
 129
 130     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 131     if (!exitstatus) {
 132         exitstatus = perl_run(my_perl);
 133     }
 134
 135     perl_destruct(my_perl);
 136     perl_free(my_perl);
 137     my_perl = 0;
 138
 139     if (exitstatus)
 140         ret = 1;
 141     else {
 142         ret = 0;
 143         sprintf(retstr->strptr, "%s", "ok");
 144         retstr->strlength = strlen (retstr->strptr);
 145     }
 146     PERL_SYS_TERM1(0);
 147     return ret;
 148 }
 149
 150 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 151                     PCSZ queuename, PRXSTRING retstr)
 152 {
 153     if (rargc != 0)
 154         return seterr("no arguments expected, got %ld", rargc);
 155     PERL_SYS_TERM1(0);
 156     return 0;
 157 }
 158
 159 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 160                     PCSZ queuename, PRXSTRING retstr)
 161 {
 162     if (rargc != 0)
 163         return seterr("no arguments expected, got %ld", rargc);
 164     if (!my_perl)
 165         return seterr("no perl interpreter present");
 166     perl_destruct(my_perl);
 167     perl_free(my_perl);
 168     my_perl = 0;
 169
 170     sprintf(retstr->strptr, "%s", "ok");
 171     retstr->strlength = strlen (retstr->strptr);
 172     return 0;
 173 }
 174
 175
 176 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 177                     PCSZ queuename, PRXSTRING retstr)
 178 {
 179     if (rargc != 0)
 180         return seterr("no argument expected, got %ld", rargc);
 181     if (!init_perl(1))
 182         return 1;
 183
 184     sprintf(retstr->strptr, "%s", "ok");
 185     retstr->strlength = strlen (retstr->strptr);
 186     return 0;
 187 }
 188
 189 ULONG
 190 PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 191 {
 192     int len = strlen(last_error);
 193
 194     if (len <= 256                      /* Default buffer is 256-char long */
 195         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 196                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 197             memcpy(retstr->strptr, last_error, len);
 198             retstr->strlength = len;
 199     } else {
 200         strcpy(retstr->strptr, "[Not enough memory to copy the errortext]");
 201         retstr->strlength = strlen(retstr->strptr);
 202     }
 203     return 0;
 204 }
 205
 206 ULONG
 207 PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 208 {
 209     SV *res, *in;
 210     STRLEN len, n_a;
 211     char *str;
 212
 213     last_error[0] = 0;
 214     if (rargc != 1)
 215         return seterr("one argument expected, got %ld", rargc);
 216
 217     if (!init_perl(1))
 218         return seterr("error initializing perl");
 219
 220   {
 221     dSP;
 222     int ret;
 223
 224     ENTER;
 225     SAVETMPS;
 226
 227     PUSHMARK(SP);
 228     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
 229     eval_sv(in, G_SCALAR);
 230     SPAGAIN;
 231     res = POPs;
 232     PUTBACK;
 233
 234     ret = 0;
 235     if (SvTRUE(ERRSV))
 236         ret = seterr(SvPV(ERRSV, n_a));
 237     if (!SvOK(res))
 238         ret = seterr("undefined value returned by Perl-in-REXX");
 239     str = SvPV(res, len);
 240     if (len <= 256                      /* Default buffer is 256-char long */
 241         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 242                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 243             memcpy(retstr->strptr, str, len);
 244             retstr->strlength = len;
 245     } else
 246         ret = seterr("Not enough memory for the return string of Perl-in-REXX");
 247
 248     FREETMPS;
 249     LEAVE;
 250
 251     return ret;
 252   }
 253 }
 254
 255 ULONG
 256 PERLEVALSUBCOMMAND(
 257   const RXSTRING    *command,          /* command to issue           */
 258   PUSHORT      flags,                  /* error/failure flags        */
 259   PRXSTRING    retstr )                /* return code                */
 260 {
 261     ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr);
 262
 263     if (rc)
 264         *flags = RXSUBCOM_ERROR;         /* raise error condition    */
 265
 266     return 0;                            /* finished                   */
 267 }
 268
 269 #define ArrLength(a) (sizeof(a)/sizeof(*(a)))
 270
 271 static const struct {
 272   char *name;
 273   RexxFunctionHandler *f;
 274 } funcs[] = {
 275              {"PERL",                   (RexxFunctionHandler *)&PERL},
 276              {"PERLTERM",               (RexxFunctionHandler *)&PERLTERM},
 277              {"PERLINIT",               (RexxFunctionHandler *)&PERLINIT},
 278              {"PERLEXIT",               (RexxFunctionHandler *)&PERLEXIT},
 279              {"PERLEVAL",               (RexxFunctionHandler *)&PERLEVAL},
 280              {"PERLLASTERROR",          (RexxFunctionHandler *)&PERLLASTERROR},
 281              {"PERLDROPALL",            (RexxFunctionHandler *)&PERLDROPALL},
 282              {"PERLDROPALLEXIT",        (RexxFunctionHandler *)&PERLDROPALLEXIT},
 283              /* Should be the last entry */
 284              {"PERLEXPORTALL",          (RexxFunctionHandler *)&PERLEXPORTALL}
 285           };
 286
 287 ULONG
 288 PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 289 {
 290    int i = -1;
 291
 292    while (++i < ArrLength(funcs) - 1)
 293         RexxRegisterFunctionExe(funcs[i].name, funcs[i].f);
 294    RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL);
 295    retstr->strlength = 0;
 296    return 0;
 297 }
 298
 299 ULONG
 300 PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 301 {
 302    int i = -1;
 303
 304    while (++i < ArrLength(funcs))
 305         RexxDeregisterFunction(funcs[i].name);
 306    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
 307    retstr->strlength = 0;
 308    return 0;
 309 }
 310
 311 ULONG
 312 PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr)
 313 {
 314    int i = -1;
 315
 316    while (++i < ArrLength(funcs))
 317         RexxDeregisterFunction(funcs[i].name);
 318    RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */);
 319    PERL_SYS_TERM1(0);
 320    retstr->strlength = 0;
 321    return 0;
 322 }
 323 #define INCL_DOSPROCESS
 324 #define INCL_DOSSEMAPHORES
 325 #define INCL_DOSMODULEMGR
 326 #define INCL_DOSMISC
 327 #define INCL_DOSEXCEPTIONS
 328 #define INCL_DOSERRORS
 329 #define INCL_REXXSAA
 330 #include <os2.h>
 331
 332 /*
 333  * "The Road goes ever on and on, down from the door where it began."
 334  */
 335
 336 #ifdef OEMVS
 337 #ifdef MYMALLOC
 338 /* sbrk is limited to first heap segement so make it big */
 339 #pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
 340 #else
 341 #pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON))
 342 #endif
 343 #endif
 344
 345
 346 #include "EXTERN.h"
 347 #include "perl.h"
 348
 349 static void xs_init (pTHX);
 350 static PerlInterpreter *my_perl;
 351
 352 #if defined (__MINT__) || defined (atarist)
 353 /* The Atari operating system doesn't have a dynamic stack.  The
 354    stack size is determined from this value.  */
 355 long _stksize = 64 * 1024;
 356 #endif
 357
 358 /* Register any extra external extensions */
 359
 360 /* Do not delete this line--writemain depends on it */
 361 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
 362
 363 static void
 364 xs_init(pTHX)
 365 {
 366     char *file = __FILE__;
 367     dXSUB_SYS;
 368         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 369 }
 370
 371 int perlos2_is_inited;
 372
 373 static void
 374 init_perlos2(void)
 375 {
 376 /*    static char *env[1] = {NULL};     */
 377
 378     Perl_OS2_init3(0, 0, 0);
 379 }
 380
 381 static int
 382 init_perl(int doparse)
 383 {
 384     int exitstatus;
 385     char *argv[3] = {"perl_in_REXX", "-e", ""};
 386
 387     if (!perlos2_is_inited) {
 388         perlos2_is_inited = 1;
 389         init_perlos2();
 390     }
 391     if (my_perl)
 392         return 1;
 393     if (!PL_do_undump) {
 394         my_perl = perl_alloc();
 395         if (!my_perl)
 396             return 0;
 397         perl_construct(my_perl);
 398         PL_perl_destruct_level = 1;
 399     }
 400     if (!doparse)
 401         return 1;
 402     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 403     return !exitstatus;
 404 }
 405
 406 /* The REXX-callable entrypoints ... */
 407
 408 ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 409                     PCSZ queuename, PRXSTRING retstr)
 410 {
 411     int exitstatus;
 412     char buf[256];
 413     char *argv[3] = {"perl_from_REXX", "-e", buf};
 414     ULONG ret;
 415
 416     if (rargc != 1) {
 417         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
 418         retstr->strlength = strlen (retstr->strptr);
 419         return 1;
 420     }
 421     if (rargv[0].strlength >= sizeof(buf)) {
 422         sprintf(retstr->strptr,
 423                 "length of the argument %ld exceeds the maximum %ld",
 424                 rargv[0].strlength, (long)sizeof(buf) - 1);
 425         retstr->strlength = strlen (retstr->strptr);
 426         return 1;
 427     }
 428
 429     if (!init_perl(0))
 430         return 1;
 431
 432     memcpy(buf, rargv[0].strptr, rargv[0].strlength);
 433     buf[rargv[0].strlength] = 0;
 434
 435     exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL);
 436     if (!exitstatus) {
 437         exitstatus = perl_run(my_perl);
 438     }
 439
 440     perl_destruct(my_perl);
 441     perl_free(my_perl);
 442     my_perl = 0;
 443
 444     if (exitstatus)
 445         ret = 1;
 446     else {
 447         ret = 0;
 448         sprintf(retstr->strptr, "%s", "ok");
 449         retstr->strlength = strlen (retstr->strptr);
 450     }
 451     PERL_SYS_TERM1(0);
 452     return ret;
 453 }
 454
 455 ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 456                     PCSZ queuename, PRXSTRING retstr)
 457 {
 458     if (rargc != 0) {
 459         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 460         retstr->strlength = strlen (retstr->strptr);
 461         return 1;
 462     }
 463     PERL_SYS_TERM1(0);
 464     return 0;
 465 }
 466
 467 ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv,
 468                     PCSZ queuename, PRXSTRING retstr)
 469 {
 470     if (rargc != 0) {
 471         sprintf(retstr->strptr, "no arguments expected, got %ld", rargc);
 472         retstr->strlength = strlen (retstr->strptr);
 473         return 1;
 474     }
 475     if (!my_perl) {
 476         sprintf(retstr->strptr, "no perl interpreter present");
 477         retstr->strlength = strlen (retstr->strptr);
 478         return 1;
 479     }
 480     perl_destruct(my_perl);
 481     perl_free(my_perl);
 482     my_perl = 0;
 483
 484     sprintf(retstr->strptr, "%s", "ok");
 485     retstr->strlength = strlen (retstr->strptr);
 486     return 0;
 487 }
 488
 489
 490 ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
 491                     PCSZ queuename, PRXSTRING retstr)
 492 {
 493     if (rargc != 0) {
 494         sprintf(retstr->strptr, "no argument expected, got %ld", rargc);
 495         retstr->strlength = strlen (retstr->strptr);
 496         return 1;
 497     }
 498     if (!init_perl(1))
 499         return 1;
 500
 501     sprintf(retstr->strptr, "%s", "ok");
 502     retstr->strlength = strlen (retstr->strptr);
 503     return 0;
 504 }
 505
 506 ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv,
 507                     PCSZ queuename, PRXSTRING retstr)
 508 {
 509     SV *res, *in;
 510     STRLEN len;
 511     char *str;
 512
 513     if (rargc != 1) {
 514         sprintf(retstr->strptr, "one argument expected, got %ld", rargc);
 515         retstr->strlength = strlen (retstr->strptr);
 516         return 1;
 517     }
 518
 519     if (!init_perl(1))
 520         return 1;
 521
 522   {
 523     dSP;
 524     int ret;
 525
 526     ENTER;
 527     SAVETMPS;
 528
 529     PUSHMARK(SP);
 530     in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength));
 531     eval_sv(in, G_SCALAR);
 532     SPAGAIN;
 533     res = POPs;
 534     PUTBACK;
 535
 536     ret = 0;
 537     if (SvTRUE(ERRSV) || !SvOK(res))
 538         ret = 1;
 539     str = SvPV(res, len);
 540     if (len <= 256                      /* Default buffer is 256-char long */
 541         || !DosAllocMem((PPVOID)&retstr->strptr, len,
 542                         PAG_READ|PAG_WRITE|PAG_COMMIT)) {
 543             memcpy(retstr->strptr, str, len);
 544             retstr->strlength = len;
 545     } else
 546         ret = 1;
 547
 548     FREETMPS;
 549     LEAVE;
 550
 551     return ret;
 552   }
 553 }