/*
 * "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 */
