home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / OS2 / os2rexx.c < prev    next >
C/C++ Source or Header  |  1995-05-19  |  4KB  |  176 lines
  1. /*
  2.  * "The Road goes ever on and on, down from the door where it began."
  3.  */
  4.  
  5. #include "EXTERN.h"
  6. #include "perl.h"
  7.  
  8. #define INCL_BASE
  9. #include <os2.h>
  10.  
  11. #pragma pack(1)
  12. #define _Packed
  13. #define INCL_REXXSAA
  14. #include <rexxsaa.h>
  15. #pragma pack()
  16.  
  17. extern ULONG _emx_exception (    EXCEPTIONREPORTRECORD *,
  18.                 EXCEPTIONREGISTRATIONRECORD *,
  19.                                 CONTEXTRECORD *,
  20.                                 void *);
  21.  
  22. static PerlInterpreter *my_perl;
  23.  
  24. #if 0
  25. /* This value may be raised by extensions for testing purposes */
  26. int perl_destruct_level = 1; /* 0=none, 1=full, 2=full with checks */
  27. #endif
  28.  
  29. /* Register any extra external extensions */
  30.  
  31. static void
  32. xs_init()
  33. {
  34.     /* Do not delete this line--writemain depends on it */
  35.     char *file = __FILE__;
  36.     {   extern void boot_DynaLoader _((CV* cv));
  37.         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  38.     }
  39. }
  40.  
  41. ULONG
  42. PERLEXIT(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
  43. {
  44.     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
  45.  
  46.     if (!my_perl)
  47.     return 1;
  48.  
  49.     DosSetExceptionHandler(&xreg);
  50.  
  51.     perl_destruct( my_perl );
  52.     perl_free( my_perl );
  53.     my_perl = NULL;
  54.  
  55.     DosUnsetExceptionHandler(&xreg);
  56.  
  57.     ret->strptr[0] = '0';
  58.     ret->strlength = 1;
  59.     return 0;
  60. }
  61.  
  62. ULONG
  63. PERLINIT(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
  64. {
  65.     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
  66.  
  67.     if (my_perl)
  68.     PERLEXIT(name, argc, argv, queue, ret);
  69.  
  70.     DosSetExceptionHandler(&xreg);
  71.     my_perl = perl_alloc();
  72.     if (my_perl)
  73.         perl_construct(my_perl);
  74.     DosUnsetExceptionHandler(&xreg);
  75.  
  76.     ret->strptr[0] = my_perl ? '0' : '1';
  77.     ret->strlength = 1;
  78.     return 0;
  79. }
  80.  
  81. ULONG
  82. PERLLOAD(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
  83. {
  84.     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
  85.     int rc, ac, i;
  86.     char **av = alloca((argc + 2) * sizeof(char *));
  87.  
  88.     if (!my_perl) {
  89.     PERLINIT(name, argc, argv, queue, ret);
  90.     if (!my_perl)
  91.         return 1;
  92.     }
  93.  
  94.     DosSetExceptionHandler(&xreg);
  95.  
  96.     ac = 0;
  97.     av[ac++] = "REXX";
  98.     for (i = 0; i < argc; ++i)
  99.     av[ac++] = argv[i].strptr;
  100.     av[ac] = NULL;
  101.  
  102.     if ((rc = perl_parse(my_perl, xs_init, ac, av, environ)) == 0)
  103.     rc = perl_run( my_perl );
  104.     else
  105.         rc = 1;
  106.  
  107.     ret->strlength = sprintf(ret->strptr, "%d", rc);
  108.  
  109.     DosUnsetExceptionHandler(&xreg);
  110.     return 0;
  111. }
  112.  
  113. ULONG
  114. PERLCALL(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
  115. {
  116.     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
  117.     int i, rc, ac;
  118.     unsigned long len;
  119.     char *str;
  120.     char **av = alloca((argc + 1) * sizeof(char *));
  121.     dSP;
  122.  
  123.     DosSetExceptionHandler(&xreg);
  124.  
  125.     ac = 0;
  126.     for (i = 0; i < argc; ++i)
  127.     av[ac++] = argv[i].strptr;
  128.     av[ac] = NULL;
  129.  
  130.     ENTER;
  131.     SAVETMPS;
  132.  
  133.     if (!my_perl) {
  134.     DosUnsetExceptionHandler(&xreg);
  135.     return 1;
  136.     }
  137.  
  138.     rc = perl_call_argv(name, G_SCALAR, av);
  139.  
  140.     SPAGAIN;
  141.  
  142.     if (rc != 1)
  143.     return 1;
  144.  
  145.     str = SvPVx(POPs, len);
  146.     if (len > 256)
  147.     if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
  148.         DosUnsetExceptionHandler(&xreg);
  149.         return 1;
  150.     }
  151.     memcpy(ret->strptr, str, len);
  152.     ret->strlength = len;
  153.  
  154.     DosUnsetExceptionHandler(&xreg);
  155.     return 0;
  156. }
  157.  
  158. /*****************************************************************************/
  159.  
  160. ULONG
  161. PERLSUBCOM(PRXSTRING cmd, PUSHORT flags, PRXSTRING ret)
  162. {
  163.     RXSTRING av[2];
  164.     ULONG rc;
  165.  
  166.     av[0].strptr = "-e";
  167.     av[0].strlength = 2;
  168.     av[1] = *cmd;
  169.     rc = PERLLOAD("REXX", 2, av, "SESSION", ret);
  170.     *flags = RXSUBCOM_OK;
  171.     return 0;
  172. }
  173.  
  174.  
  175.  
  176.