home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
perl502b.zip
/
OS2
/
os2main.c
< prev
next >
Wrap
C/C++ Source or Header
|
1996-02-23
|
5KB
|
212 lines
/*
* "The Road goes ever on and on, down from the door where it began."
*/
#include "EXTERN.h"
#include "perl.h"
#ifdef __EMX__
#include "sys/emxload.h"
#endif
#define INCL_BASE
#include <os2.h>
#pragma pack(1)
#define _Packed
#define INCL_REXXSAA
#include <rexxsaa.h>
#pragma pack()
extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
EXCEPTIONREGISTRATIONRECORD *,
CONTEXTRECORD *,
void *);
#ifdef __cplusplus
# define EXTERN_C extern "C"
#else
# define EXTERN_C extern
#endif
static void xs_init _((void));
static PerlInterpreter *my_perl;
int
perl_init_i18nl14n(printwarn) /* XXX move to perl.c */
int printwarn;
{
int ok = 1;
/* returns
* 1 = set ok or not applicable,
* 0 = fallback to C locale,
* -1 = fallback to C locale failed
*/
#if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
char * lang = getenv("LANG");
char * lc_all = getenv("LC_ALL");
char * lc_ctype = getenv("LC_CTYPE");
int i;
if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
if (printwarn) {
fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n");
fprintf(stderr,
"warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
lc_all ? lc_all : "(null)",
lc_ctype ? lc_ctype : "(null)",
lang ? lang : "(null)"
);
fprintf(stderr, "warning: falling back to the \"C\" locale.\n");
}
ok = 0;
if (setlocale(LC_CTYPE, "C") == NULL)
ok = -1;
}
for (i = 0; i < 256; i++) {
if (isUPPER(i)) fold[i] = toLOWER(i);
else if (isLOWER(i)) fold[i] = toUPPER(i);
else fold[i] = i;
}
#endif
return ok;
}
static int argc0;
static char ** argv0;
static char ** envp0;
static int exit0;
static ULONG
StartPerl(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
int exitstatus;
EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
#ifndef HAS_FORK
DosSetExceptionHandler(&xreg);
#endif
if (!do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct( my_perl );
}
if ((exit0 = perl_parse( my_perl, xs_init, argc0, argv0, envp0 )) == 0) {
exit0 = perl_run( my_perl );
perl_destruct( my_perl );
perl_free( my_perl );
}
#ifndef HAS_FORK
DosUnsetExceptionHandler(&xreg);
#endif
MAKERXSTRING(*ret, NULL, 0);
return 0;
}
/*****************************************************************************/
int
main(argc, argv, envp)
int argc;
char **argv;
char **envp;
{
int useREXX = 0;
int i;
char *cp;
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
USHORT retcode;
static char cmd[] = "CALL StartPerl\r\n";
PERL_SYS_INIT(&argc,&argv);
tzset();
#ifdef __EMX__
_emxload_env("PERL5LOAD");
/*
* EMX 0.9b2 does not (yet?) know about Xx_XX locales.
*
* With basic Perl, locales seem to be used for character case mapping only,
* so silently fall back to LANG=C. POSIX is a different story, but has its
* own setlocale().
*/
perl_init_i18nl14n(0);
#else
perl_init_i18nl14n(1);
#endif
/* Look for REXX option. */
for (i = 1; i < argc && *argv[i] == '-'; )
if (cp = strchr(argv[i]+1, 'R')) {
++useREXX;
memmove(cp, cp+1, strlen(cp+1)+1);
if (!*(argv[i]+1)) {
while (++i < argc)
argv[i-1] = argv[i];
argv[--argc] = NULL;
}
} else
++i;
if (argc <= 1) {
usage(argv[0]);
exit(1);
}
DosError(FERR_DISABLEHARDERR | FERR_DISABLEEXCEPTION);
argc0 = argc;
argv0 = argv;
envp0 = envp;
#ifndef HAS_FORK
if (useREXX) {
HMODULE hRexx, hRexxAPI;
BYTE buf[200];
LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, PFN);
APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
|| DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
|| DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
|| DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", (PFN *)&pRexxRegisterFunctionExe)
|| DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", (PFN *)&pRexxDeregisterFunction)) {
fprintf(stderr, "REXX not available\n");
exit(1);
}
pRexxRegisterFunctionExe("StartPerl", (PFN)StartPerl);
MAKERXSTRING(args[0], NULL, 0);
MAKERXSTRING(inst[0], cmd, strlen(cmd));
MAKERXSTRING(inst[1], NULL, 0);
MAKERXSTRING(result, NULL, 0);
pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, &retcode, &result);
pRexxDeregisterFunction("StartPerl");
DosFreeModule(hRexxAPI);
DosFreeModule(hRexx);
} else
#endif
StartPerl(0, 0, 0, 0, &result);
return exit0;
}
/*****************************************************************************/
/* Register any extra external extensions */
/* Do not delete this line--writemain depends on it */