/*
 * "The Road goes ever on and on, down from the door where it began."
 */

#include "EXTERN.h"
#include "perl.h"

#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 *);

static PerlInterpreter *my_perl;

#if 0
/* This value may be raised by extensions for testing purposes */
int perl_destruct_level = 1; /* 0=none, 1=full, 2=full with checks */
#endif

/* Register any extra external extensions */

static void
xs_init()
{
    /* Do not delete this line--writemain depends on it */
    char *file = __FILE__;
    {   extern void boot_DynaLoader _((CV* cv));
        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    }
}

ULONG
PERLEXIT(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };

    if (!my_perl)
	return 1;

    DosSetExceptionHandler(&xreg);

    perl_destruct( my_perl );
    perl_free( my_perl );
    my_perl = NULL;

    DosUnsetExceptionHandler(&xreg);

    ret->strptr[0] = '0';
    ret->strlength = 1;
    return 0;
}

ULONG
PERLINIT(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };

    if (my_perl)
	PERLEXIT(name, argc, argv, queue, ret);

    DosSetExceptionHandler(&xreg);
    my_perl = perl_alloc();
    if (my_perl)
        perl_construct(my_perl);
    DosUnsetExceptionHandler(&xreg);

    ret->strptr[0] = my_perl ? '0' : '1';
    ret->strlength = 1;
    return 0;
}

ULONG
PERLLOAD(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
    int rc, ac, i;
    char **av = alloca((argc + 2) * sizeof(char *));

    if (!my_perl) {
	PERLINIT(name, argc, argv, queue, ret);
	if (!my_perl)
	    return 1;
    }

    DosSetExceptionHandler(&xreg);

    ac = 0;
    av[ac++] = "REXX";
    for (i = 0; i < argc; ++i)
	av[ac++] = argv[i].strptr;
    av[ac] = NULL;

    if ((rc = perl_parse(my_perl, xs_init, ac, av, environ)) == 0)
	rc = perl_run( my_perl );
    else
        rc = 1;

    ret->strlength = sprintf(ret->strptr, "%d", rc);

    DosUnsetExceptionHandler(&xreg);
    return 0;
}

ULONG
PERLCALL(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
    int i, rc, ac;
    unsigned long len;
    char *str;
    char **av = alloca((argc + 1) * sizeof(char *));
    dSP;

    DosSetExceptionHandler(&xreg);

    ac = 0;
    for (i = 0; i < argc; ++i)
	av[ac++] = argv[i].strptr;
    av[ac] = NULL;

    ENTER;
    SAVETMPS;

    if (!my_perl) {
	DosUnsetExceptionHandler(&xreg);
	return 1;
    }

    rc = perl_call_argv(name, G_SCALAR, av);

    SPAGAIN;

    if (rc != 1)
	return 1;

    str = SvPVx(POPs, len);
    if (len > 256)
	if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
	    DosUnsetExceptionHandler(&xreg);
	    return 1;
	}
    memcpy(ret->strptr, str, len);
    ret->strlength = len;

    DosUnsetExceptionHandler(&xreg);
    return 0;
}

/*****************************************************************************/

ULONG
PERLSUBCOM(PRXSTRING cmd, PUSHORT flags, PRXSTRING ret)
{
    RXSTRING av[2];
    ULONG rc;

    av[0].strptr = "-e";
    av[0].strlength = 2;
    av[1] = *cmd;
    rc = PERLLOAD("REXX", 2, av, "SESSION", ret);
    *flags = RXSUBCOM_OK;
    return 0;
}



