home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl502b.zip / OS2 / os2main.c < prev    next >
C/C++ Source or Header  |  1996-02-23  |  5KB  |  212 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. #ifdef __EMX__
  9. #include "sys/emxload.h"
  10. #endif
  11.  
  12. #define INCL_BASE
  13. #include <os2.h>
  14.  
  15. #pragma pack(1)
  16. #define _Packed
  17. #define INCL_REXXSAA
  18. #include <rexxsaa.h>
  19. #pragma pack()
  20.  
  21. extern ULONG _emx_exception (    EXCEPTIONREPORTRECORD *,
  22.                 EXCEPTIONREGISTRATIONRECORD *,
  23.                                 CONTEXTRECORD *,
  24.                                 void *);
  25.  
  26. #ifdef __cplusplus
  27. #  define EXTERN_C extern "C"
  28. #else
  29. #  define EXTERN_C extern
  30. #endif
  31.  
  32. static void xs_init _((void));
  33. static PerlInterpreter *my_perl;
  34.  
  35. int
  36. perl_init_i18nl14n(printwarn)    /* XXX move to perl.c */
  37.     int printwarn;
  38. {
  39.     int ok = 1;
  40.     /* returns
  41.      *    1 = set ok or not applicable,
  42.      *    0 = fallback to C locale,
  43.      *   -1 = fallback to C locale failed
  44.      */
  45. #if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
  46.     char * lang     = getenv("LANG");
  47.     char * lc_all   = getenv("LC_ALL");
  48.     char * lc_ctype = getenv("LC_CTYPE");
  49.     int i;
  50.  
  51.     if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
  52.     if (printwarn) {
  53.         fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n");
  54.         fprintf(stderr,
  55.           "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
  56.           lc_all   ? lc_all   : "(null)",
  57.           lc_ctype ? lc_ctype : "(null)",
  58.           lang     ? lang     : "(null)"
  59.           );
  60.         fprintf(stderr, "warning: falling back to the \"C\" locale.\n");
  61.     }
  62.     ok = 0;
  63.     if (setlocale(LC_CTYPE, "C") == NULL)
  64.         ok = -1;
  65.     }
  66.  
  67.     for (i = 0; i < 256; i++) {
  68.     if (isUPPER(i)) fold[i] = toLOWER(i);
  69.     else if (isLOWER(i)) fold[i] = toUPPER(i);
  70.     else fold[i] = i;
  71.     }
  72. #endif
  73.     return ok;
  74. }
  75.  
  76. static int    argc0;
  77. static char **    argv0;
  78. static char **    envp0;
  79. static int    exit0;
  80.  
  81. static ULONG
  82. StartPerl(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
  83. {
  84.     int exitstatus;
  85.     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
  86.  
  87. #ifndef HAS_FORK
  88.     DosSetExceptionHandler(&xreg);
  89. #endif
  90.  
  91.     if (!do_undump) {
  92.     my_perl = perl_alloc();
  93.     if (!my_perl)
  94.         exit(1);
  95.     perl_construct( my_perl );
  96.     }
  97.  
  98.     if ((exit0 = perl_parse( my_perl, xs_init, argc0, argv0, envp0 )) == 0) {
  99.         exit0 = perl_run( my_perl );
  100.  
  101.         perl_destruct( my_perl );
  102.         perl_free( my_perl );
  103.     }
  104.  
  105. #ifndef HAS_FORK
  106.     DosUnsetExceptionHandler(&xreg);
  107. #endif
  108.  
  109.     MAKERXSTRING(*ret, NULL, 0);
  110.     return 0;
  111. }
  112.  
  113. /*****************************************************************************/
  114.  
  115. int
  116. main(argc, argv, envp)
  117. int argc;
  118. char **argv;
  119. char **envp;
  120. {
  121.     int useREXX = 0;
  122.     int i;
  123.     char *cp;
  124.     RXSTRING args[1];
  125.     RXSTRING inst[2];
  126.     RXSTRING result;
  127.     USHORT   retcode;
  128.     static char cmd[] = "CALL StartPerl\r\n";
  129.  
  130.     PERL_SYS_INIT(&argc,&argv);
  131.     tzset();
  132.  
  133. #ifdef __EMX__
  134.     _emxload_env("PERL5LOAD");
  135.  
  136.     /*
  137.      * EMX 0.9b2 does not (yet?) know about Xx_XX locales.
  138.      *
  139.      * With basic Perl, locales seem to be used for character case mapping only,
  140.      * so silently fall back to LANG=C. POSIX is a different story, but has its
  141.      * own setlocale().
  142.      */
  143.     perl_init_i18nl14n(0);
  144. #else
  145.     perl_init_i18nl14n(1);
  146. #endif
  147.  
  148.     /* Look for REXX option. */
  149.     for (i = 1; i < argc && *argv[i] == '-'; )
  150.         if (cp = strchr(argv[i]+1, 'R')) {
  151.             ++useREXX;
  152.             memmove(cp, cp+1, strlen(cp+1)+1);
  153.             if (!*(argv[i]+1)) {
  154.                 while (++i < argc)
  155.             argv[i-1] = argv[i];
  156.         argv[--argc] = NULL;
  157.             }
  158.         } else
  159.             ++i;
  160.  
  161.     if (argc <= 1) {
  162.         usage(argv[0]);
  163.         exit(1);
  164.     }
  165.  
  166.     DosError(FERR_DISABLEHARDERR | FERR_DISABLEEXCEPTION);
  167.  
  168.     argc0 = argc;
  169.     argv0 = argv;
  170.     envp0 = envp;
  171.  
  172. #ifndef HAS_FORK
  173.     if (useREXX) {
  174.     HMODULE hRexx, hRexxAPI;
  175.     BYTE    buf[200];
  176.     LONG    APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
  177.     APIRET  APIENTRY (*pRexxRegisterFunctionExe) (PSZ, PFN);
  178.     APIRET  APIENTRY (*pRexxDeregisterFunction) (PSZ);
  179.  
  180.     if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
  181.      || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
  182.      || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
  183.      || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", (PFN *)&pRexxRegisterFunctionExe)
  184.      || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", (PFN *)&pRexxDeregisterFunction)) {
  185.         fprintf(stderr, "REXX not available\n");
  186.         exit(1);
  187.     }
  188.  
  189.         pRexxRegisterFunctionExe("StartPerl", (PFN)StartPerl);
  190.  
  191.         MAKERXSTRING(args[0], NULL, 0);
  192.         MAKERXSTRING(inst[0], cmd,  strlen(cmd));
  193.         MAKERXSTRING(inst[1], NULL, 0);
  194.         MAKERXSTRING(result,  NULL, 0);
  195.         pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, &retcode, &result);
  196.  
  197.         pRexxDeregisterFunction("StartPerl");
  198.  
  199.     DosFreeModule(hRexxAPI);
  200.     DosFreeModule(hRexx);
  201.     } else
  202. #endif
  203.         StartPerl(0, 0, 0, 0, &result);
  204.  
  205.     return exit0;
  206. }
  207.  
  208. /*****************************************************************************/
  209. /* Register any extra external extensions */
  210.  
  211. /* Do not delete this line--writemain depends on it */
  212.