[p5sagit/p5-mst-13.2.git] / win32 / perllib.c

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


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

#ifdef PERL_OBJECT
#define NO_XSLOCKS
#endif

#include "XSUB.h"

#ifdef PERL_IMPLICIT_SYS
#include "win32iop.h"
#include <fcntl.h>
#endif /* PERL_IMPLICIT_SYS */


/* Register any extra external extensions */
char *staticlinkmodules[] = {
    "DynaLoader",
    NULL,
};

EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);

static void
xs_init(pTHXo)
{
    char *file = __FILE__;
    dXSUB_SYS;
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}

#ifdef PERL_IMPLICIT_SYS

#include "perlhost.h"

EXTERN_C void
perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
		   struct IPerlMemInfo* perlMemSharedInfo,
		   struct IPerlMemInfo* perlMemParseInfo,
		   struct IPerlEnvInfo* perlEnvInfo,
		   struct IPerlStdIOInfo* perlStdIOInfo,
		   struct IPerlLIOInfo* perlLIOInfo,
		   struct IPerlDirInfo* perlDirInfo,
		   struct IPerlSockInfo* perlSockInfo,
		   struct IPerlProcInfo* perlProcInfo)
{
    if (perlMemInfo) {
	Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
	perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlMemSharedInfo) {
	Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
	perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlMemParseInfo) {
	Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
	perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlEnvInfo) {
	Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
	perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
    }
    if (perlStdIOInfo) {
	Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
	perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
    }
    if (perlLIOInfo) {
	Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
	perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
    }
    if (perlDirInfo) {
	Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
	perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
    }
    if (perlSockInfo) {
	Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
	perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
    }
    if (perlProcInfo) {
	Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
	perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
    }
}

#ifdef PERL_OBJECT

EXTERN_C PerlInterpreter*
perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
		 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
		 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
		 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
		 struct IPerlProc** ppProc)
{
    PerlInterpreter *my_perl = NULL;
    try
    {
	CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
					 ppStdIO, ppLIO, ppDir, ppSock, ppProc);

	if (pHost) {
	    my_perl = perl_alloc_using(pHost->m_pHostperlMem,
				       pHost->m_pHostperlMemShared,
				       pHost->m_pHostperlMemParse,
				       pHost->m_pHostperlEnv,
				       pHost->m_pHostperlStdIO,
				       pHost->m_pHostperlLIO,
				       pHost->m_pHostperlDir,
				       pHost->m_pHostperlSock,
				       pHost->m_pHostperlProc);
	    if (my_perl) {
		CPerlObj* pPerl = (CPerlObj*)my_perl;
		w32_internal_host = pHost;
	    }
	}
    }
    catch(...)
    {
	win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
	my_perl = NULL;
    }

    return my_perl;
}

EXTERN_C PerlInterpreter*
perl_alloc(void)
{
    PerlInterpreter* my_perl = NULL;
    try
    {
	CPerlHost* pHost = new CPerlHost();
	if (pHost) {
	    my_perl = perl_alloc_using(pHost->m_pHostperlMem,
				       pHost->m_pHostperlMemShared,
				       pHost->m_pHostperlMemParse,
				       pHost->m_pHostperlEnv,
				       pHost->m_pHostperlStdIO,
				       pHost->m_pHostperlLIO,
				       pHost->m_pHostperlDir,
				       pHost->m_pHostperlSock,
				       pHost->m_pHostperlProc);
	    if (my_perl) {
		CPerlObj* pPerl = (CPerlObj*)my_perl;
		w32_internal_host = pHost;
	    }
	}
    }
    catch(...)
    {
	win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
	my_perl = NULL;
    }

    return my_perl;
}

EXTERN_C void
perl_construct(PerlInterpreter* my_perl)
{
    CPerlObj* pPerl = (CPerlObj*)my_perl;
    try
    {
	Perl_construct();
    }
    catch(...)
    {
	win32_fprintf(stderr, "%s\n",
		      "Error: Unable to construct data structures");
	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
	Perl_free();
	delete pHost;
	SetPerlInterpreter(NULL);
    }
}

EXTERN_C void
perl_destruct(PerlInterpreter* my_perl)
{
    CPerlObj* pPerl = (CPerlObj*)my_perl;
#ifdef DEBUGGING
    Perl_destruct();
#else
    try
    {
	Perl_destruct();
    }
    catch(...)
    {
    }
#endif
}

EXTERN_C void
perl_free(PerlInterpreter* my_perl)
{
    CPerlObj* pPerl = (CPerlObj*)my_perl;
#ifdef DEBUGGING
    CPerlHost* pHost = (CPerlHost*)w32_internal_host;
    Perl_free();
    delete pHost;
#else
    try
    {
	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
	Perl_free();
	delete pHost;
    }
    catch(...)
    {
    }
#endif
    SetPerlInterpreter(NULL);
}

EXTERN_C int
perl_run(PerlInterpreter* my_perl)
{
    CPerlObj* pPerl = (CPerlObj*)my_perl;
#ifdef DEBUGGING
    return Perl_run();
#else
    int retVal;
    try
    {
	retVal = Perl_run();
    }
    catch(...)
    {
	win32_fprintf(stderr, "Error: Runtime exception\n");
	retVal = -1;
    }
    return retVal;
#endif
}

EXTERN_C int
perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
{
    int retVal;
    CPerlObj* pPerl = (CPerlObj*)my_perl;
#ifdef DEBUGGING
    retVal = Perl_parse(xsinit, argc, argv, env);
#else
    try
    {
	retVal = Perl_parse(xsinit, argc, argv, env);
    }
    catch(...)
    {
	win32_fprintf(stderr, "Error: Parse exception\n");
	retVal = -1;
    }
#endif
    *win32_errno() = 0;
    return retVal;
}

#undef PL_perl_destruct_level
#define PL_perl_destruct_level int dummy

#else /* !PERL_OBJECT */

EXTERN_C PerlInterpreter*
perl_alloc(void)
{
    PerlInterpreter *my_perl = NULL;
    CPerlHost* pHost = new CPerlHost();
    if (pHost) {
	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
				   pHost->m_pHostperlMemShared,
				   pHost->m_pHostperlMemParse,
				   pHost->m_pHostperlEnv,
				   pHost->m_pHostperlStdIO,
				   pHost->m_pHostperlLIO,
				   pHost->m_pHostperlDir,
				   pHost->m_pHostperlSock,
				   pHost->m_pHostperlProc);
	if (my_perl) {
	    CPerlObj* pPerl = (CPerlObj*)my_perl;
	    w32_internal_host = pHost;
	}
    }
    return my_perl;
}

#endif /* PERL_OBJECT */
#endif /* PERL_IMPLICIT_SYS */

EXTERN_C HANDLE w32_perldll_handle;

static DWORD g_TlsAllocIndex;

EXTERN_C DllExport bool
SetPerlInterpreter(void *interp)
{
    return TlsSetValue(g_TlsAllocIndex, interp);
}

EXTERN_C DllExport void*
GetPerlInterpreter(void)
{
    return TlsGetValue(g_TlsAllocIndex);
}

EXTERN_C DllExport int
RunPerl(int argc, char **argv, char **env)
{
    int exitstatus;
    PerlInterpreter *my_perl, *new_perl = NULL;
    struct perl_thread *thr;

#ifndef __BORLANDC__
    /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
     * want to free() argv after main() returns.  As luck would have it,
     * Borland's CRT does the right thing to argv[0] already. */
    char szModuleName[MAX_PATH];
    char *ptr;

    GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
    (void)win32_longpath(szModuleName);
    argv[0] = szModuleName;
#endif

#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(var,type) /**/
#define PERLVARA(var,type) /**/
#define PERLVARI(var,type,init) PL_Vars.var = init;
#define PERLVARIC(var,type,init) PL_Vars.var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#endif

    PERL_SYS_INIT(&argc,&argv);

    if (!(my_perl = perl_alloc()))
	return (1);
    perl_construct( my_perl );
    PL_perl_destruct_level = 0;

    exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
    if (!exitstatus) {
#if defined(TOP_CLONE) && defined(USE_ITHREADS)		/* XXXXXX testing */
#  ifdef PERL_OBJECT
	CPerlHost *h = new CPerlHost();
	new_perl = perl_clone_using(my_perl, 1,
				    h->m_pHostperlMem,
				    h->m_pHostperlMemShared,
				    h->m_pHostperlMemParse,
				    h->m_pHostperlEnv,
				    h->m_pHostperlStdIO,
				    h->m_pHostperlLIO,
				    h->m_pHostperlDir,
				    h->m_pHostperlSock,
				    h->m_pHostperlProc
				    );
	CPerlObj *pPerl = (CPerlObj*)new_perl;
#  else
	new_perl = perl_clone(my_perl, 1);
#  endif
	exitstatus = perl_run( new_perl );
	SetPerlInterpreter(my_perl);
#else
	exitstatus = perl_run( my_perl );
#endif
    }

    perl_destruct( my_perl );
    perl_free( my_perl );
#ifdef USE_ITHREADS
    if (new_perl) {
	SetPerlInterpreter(new_perl);
	perl_destruct(new_perl);
	perl_free(new_perl);
    }
#endif

    PERL_SYS_TERM();

    return (exitstatus);
}

BOOL APIENTRY
DllMain(HANDLE hModule,		/* DLL module handle */
	DWORD fdwReason,	/* reason called */
	LPVOID lpvReserved)	/* reserved */
{ 
    switch (fdwReason) {
	/* The DLL is attaching to a process due to process
	 * initialization or a call to LoadLibrary.
	 */
    case DLL_PROCESS_ATTACH:
/* #define DEFAULT_BINMODE */
#ifdef DEFAULT_BINMODE
	setmode( fileno( stdin  ), O_BINARY );
	setmode( fileno( stdout ), O_BINARY );
	setmode( fileno( stderr ), O_BINARY );
	_fmode = O_BINARY;
#endif
	g_TlsAllocIndex = TlsAlloc();
	DisableThreadLibraryCalls(hModule);
	w32_perldll_handle = hModule;
	break;

	/* The DLL is detaching from a process due to
	 * process termination or call to FreeLibrary.
	 */
    case DLL_PROCESS_DETACH:
	TlsFree(g_TlsAllocIndex);
	break;

	/* The attached process creates a new thread. */
    case DLL_THREAD_ATTACH:
	break;

	/* The thread of the attached process terminates. */
    case DLL_THREAD_DETACH:
	break;

    default:
	break;
    }
    return TRUE;
}
Commit	Line	Data
0a753a76	1	/*
	2	* "The Road goes ever on and on, down from the door where it began."
	3	*/
	4
0a753a76	5
	6	#include "EXTERN.h"
	7	#include "perl.h"
0cb96387	8
	9	#ifdef PERL_OBJECT
	10	#define NO_XSLOCKS
	11	#endif
	12
96e4d5b1	13	#include "XSUB.h"
0a753a76	14
32e30700	15	#ifdef PERL_IMPLICIT_SYS
0cb96387	16	#include "win32iop.h"
0cb96387	17	#include <fcntl.h>
7766f137	18	#endif /* PERL_IMPLICIT_SYS */
0cb96387	19
0cb96387	20
7766f137	21	/* Register any extra external extensions */
	22	char *staticlinkmodules[] = {
	23	"DynaLoader",
	24	NULL,
0cb96387	25	};
0cb96387	26
7766f137	27	EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
0cb96387	28
7766f137	29	static void
7766f137	30	xs_init(pTHXo)
0cb96387	31	{
7766f137	32	char *file = __FILE__;
	33	dXSUB_SYS;
	34	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
0cb96387	35	}
0cb96387	36
7766f137	37	#ifdef PERL_IMPLICIT_SYS
0cb96387	38
7766f137	39	#include "perlhost.h"
0cb96387	40
32e30700	41	EXTERN_C void
32e30700	42	perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
7766f137	43	struct IPerlMemInfo* perlMemSharedInfo,
7766f137	44	struct IPerlMemInfo* perlMemParseInfo,
32e30700	45	struct IPerlEnvInfo* perlEnvInfo,
	46	struct IPerlStdIOInfo* perlStdIOInfo,
	47	struct IPerlLIOInfo* perlLIOInfo,
	48	struct IPerlDirInfo* perlDirInfo,
	49	struct IPerlSockInfo* perlSockInfo,
	50	struct IPerlProcInfo* perlProcInfo)
0cb96387	51	{
7766f137	52	if (perlMemInfo) {
0cb96387	53	Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
	54	perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	55	}
7766f137	56	if (perlMemSharedInfo) {
	57	Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
	58	perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	59	}
	60	if (perlMemParseInfo) {
	61	Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
	62	perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	63	}
	64	if (perlEnvInfo) {
0cb96387	65	Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
	66	perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
	67	}
7766f137	68	if (perlStdIOInfo) {
0cb96387	69	Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
	70	perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
	71	}
7766f137	72	if (perlLIOInfo) {
0cb96387	73	Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
	74	perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
	75	}
7766f137	76	if (perlDirInfo) {
0cb96387	77	Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
	78	perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
	79	}
7766f137	80	if (perlSockInfo) {
0cb96387	81	Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
	82	perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
	83	}
7766f137	84	if (perlProcInfo) {
0cb96387	85	Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
	86	perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
	87	}
	88	}
	89
32e30700	90	#ifdef PERL_OBJECT
32e30700	91
7766f137	92	EXTERN_C PerlInterpreter*
	93	perl_alloc_override(struct IPerlMem ppMem, struct IPerlMem ppMemShared,
	94	struct IPerlMem ppMemParse, struct IPerlEnv ppEnv,
	95	struct IPerlStdIO ppStdIO, struct IPerlLIO ppLIO,
	96	struct IPerlDir ppDir, struct IPerlSock ppSock,
	97	struct IPerlProc** ppProc)
0cb96387	98	{
7766f137	99	PerlInterpreter *my_perl = NULL;
0cb96387	100	try
0cb96387	101	{
7766f137	102	CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
	103	ppStdIO, ppLIO, ppDir, ppSock, ppProc);
	104
	105	if (pHost) {
	106	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
	107	pHost->m_pHostperlMemShared,
	108	pHost->m_pHostperlMemParse,
	109	pHost->m_pHostperlEnv,
	110	pHost->m_pHostperlStdIO,
	111	pHost->m_pHostperlLIO,
	112	pHost->m_pHostperlDir,
	113	pHost->m_pHostperlSock,
	114	pHost->m_pHostperlProc);
	115	if (my_perl) {
	116	CPerlObj* pPerl = (CPerlObj*)my_perl;
	117	w32_internal_host = pHost;
	118	}
	119	}
0cb96387	120	}
	121	catch(...)
	122	{
	123	win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
7766f137	124	my_perl = NULL;
0cb96387	125	}
7766f137	126
7766f137	127	return my_perl;
0cb96387	128	}
0cb96387	129
7766f137	130	EXTERN_C PerlInterpreter*
7766f137	131	perl_alloc(void)
0cb96387	132	{
7766f137	133	PerlInterpreter* my_perl = NULL;
0cb96387	134	try
0cb96387	135	{
7766f137	136	CPerlHost* pHost = new CPerlHost();
	137	if (pHost) {
	138	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
	139	pHost->m_pHostperlMemShared,
	140	pHost->m_pHostperlMemParse,
	141	pHost->m_pHostperlEnv,
	142	pHost->m_pHostperlStdIO,
	143	pHost->m_pHostperlLIO,
	144	pHost->m_pHostperlDir,
	145	pHost->m_pHostperlSock,
	146	pHost->m_pHostperlProc);
	147	if (my_perl) {
	148	CPerlObj* pPerl = (CPerlObj*)my_perl;
	149	w32_internal_host = pHost;
	150	}
	151	}
0cb96387	152	}
	153	catch(...)
	154	{
	155	win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
7766f137	156	my_perl = NULL;
0cb96387	157	}
7766f137	158
7766f137	159	return my_perl;
0cb96387	160	}
0cb96387	161
7766f137	162	EXTERN_C void
7766f137	163	perl_construct(PerlInterpreter* my_perl)
0cb96387	164	{
7766f137	165	CPerlObj* pPerl = (CPerlObj*)my_perl;
0cb96387	166	try
0cb96387	167	{
7766f137	168	Perl_construct();
0cb96387	169	}
	170	catch(...)
	171	{
	172	win32_fprintf(stderr, "%s\n",
	173	"Error: Unable to construct data structures");
7766f137	174	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
	175	Perl_free();
	176	delete pHost;
0cb96387	177	SetPerlInterpreter(NULL);
	178	}
	179	}
	180
7766f137	181	EXTERN_C void
7766f137	182	perl_destruct(PerlInterpreter* my_perl)
0cb96387	183	{
7766f137	184	CPerlObj* pPerl = (CPerlObj*)my_perl;
	185	#ifdef DEBUGGING
	186	Perl_destruct();
	187	#else
0cb96387	188	try
0cb96387	189	{
7766f137	190	Perl_destruct();
0cb96387	191	}
	192	catch(...)
	193	{
	194	}
7766f137	195	#endif
0cb96387	196	}
0cb96387	197
7766f137	198	EXTERN_C void
7766f137	199	perl_free(PerlInterpreter* my_perl)
0cb96387	200	{
7766f137	201	CPerlObj* pPerl = (CPerlObj*)my_perl;
	202	#ifdef DEBUGGING
	203	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
	204	Perl_free();
	205	delete pHost;
	206	#else
0cb96387	207	try
0cb96387	208	{
7766f137	209	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
	210	Perl_free();
	211	delete pHost;
0cb96387	212	}
	213	catch(...)
	214	{
	215	}
7766f137	216	#endif
0cb96387	217	SetPerlInterpreter(NULL);
	218	}
	219
7766f137	220	EXTERN_C int
7766f137	221	perl_run(PerlInterpreter* my_perl)
0cb96387	222	{
7766f137	223	CPerlObj* pPerl = (CPerlObj*)my_perl;
	224	#ifdef DEBUGGING
	225	return Perl_run();
	226	#else
0cb96387	227	int retVal;
	228	try
	229	{
7766f137	230	retVal = Perl_run();
0cb96387	231	}
0cb96387	232	catch(...)
	233	{
	234	win32_fprintf(stderr, "Error: Runtime exception\n");
	235	retVal = -1;
	236	}
	237	return retVal;
7766f137	238	#endif
0cb96387	239	}
0cb96387	240
7766f137	241	EXTERN_C int
7766f137	242	perl_parse(PerlInterpreter* my_perl, void (xsinit)(CPerlObj), int argc, char argv, char env)
0cb96387	243	{
0cb96387	244	int retVal;
7766f137	245	CPerlObj* pPerl = (CPerlObj*)my_perl;
	246	#ifdef DEBUGGING
	247	retVal = Perl_parse(xsinit, argc, argv, env);
	248	#else
0cb96387	249	try
0cb96387	250	{
7766f137	251	retVal = Perl_parse(xsinit, argc, argv, env);
0cb96387	252	}
0cb96387	253	catch(...)
	254	{
	255	win32_fprintf(stderr, "Error: Parse exception\n");
	256	retVal = -1;
	257	}
7766f137	258	#endif
0cb96387	259	*win32_errno() = 0;
	260	return retVal;
	261	}
	262
	263	#undef PL_perl_destruct_level
	264	#define PL_perl_destruct_level int dummy
32e30700	265
	266	#else /* !PERL_OBJECT */
	267
	268	EXTERN_C PerlInterpreter*
	269	perl_alloc(void)
	270	{
7766f137	271	PerlInterpreter *my_perl = NULL;
	272	CPerlHost* pHost = new CPerlHost();
	273	if (pHost) {
	274	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
	275	pHost->m_pHostperlMemShared,
	276	pHost->m_pHostperlMemParse,
	277	pHost->m_pHostperlEnv,
	278	pHost->m_pHostperlStdIO,
	279	pHost->m_pHostperlLIO,
	280	pHost->m_pHostperlDir,
	281	pHost->m_pHostperlSock,
	282	pHost->m_pHostperlProc);
	283	if (my_perl) {
	284	CPerlObj* pPerl = (CPerlObj*)my_perl;
	285	w32_internal_host = pHost;
	286	}
	287	}
	288	return my_perl;
32e30700	289	}
32e30700	290
0cb96387	291	#endif /* PERL_OBJECT */
32e30700	292	#endif /* PERL_IMPLICIT_SYS */
32e30700	293
7766f137	294	EXTERN_C HANDLE w32_perldll_handle;
7766f137	295
c5be433b	296	static DWORD g_TlsAllocIndex;
	297
	298	EXTERN_C DllExport bool
	299	SetPerlInterpreter(void *interp)
	300	{
	301	return TlsSetValue(g_TlsAllocIndex, interp);
	302	}
	303
	304	EXTERN_C DllExport void*
	305	GetPerlInterpreter(void)
	306	{
	307	return TlsGetValue(g_TlsAllocIndex);
	308	}
	309
	310	EXTERN_C DllExport int
0cb96387	311	RunPerl(int argc, char argv, char env)
0a753a76	312	{
68dc0745	313	int exitstatus;
ed094faf	314	PerlInterpreter my_perl, new_perl = NULL;
4f63d024	315	struct perl_thread *thr;
0a753a76	316
0cb96387	317	#ifndef __BORLANDC__
	318	/* XXX this _may_ be a problem on some compilers (e.g. Borland) that
	319	* want to free() argv after main() returns. As luck would have it,
	320	* Borland's CRT does the right thing to argv[0] already. */
	321	char szModuleName[MAX_PATH];
	322	char *ptr;
	323
	324	GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
	325	(void)win32_longpath(szModuleName);
	326	argv[0] = szModuleName;
	327	#endif
	328
22239a37	329	#ifdef PERL_GLOBAL_STRUCT
22239a37	330	#define PERLVAR(var,type) /**/
51371543	331	#define PERLVARA(var,type) /**/
533c011a	332	#define PERLVARI(var,type,init) PL_Vars.var = init;
533c011a	333	#define PERLVARIC(var,type,init) PL_Vars.var = init;
22239a37	334	#include "perlvars.h"
22239a37	335	#undef PERLVAR
51371543	336	#undef PERLVARA
22239a37	337	#undef PERLVARI
3fe35a81	338	#undef PERLVARIC
22239a37	339	#endif
22239a37	340
0a753a76	341	PERL_SYS_INIT(&argc,&argv);
0a753a76	342
68dc0745	343	if (!(my_perl = perl_alloc()))
	344	return (1);
	345	perl_construct( my_perl );
b28d0864	346	PL_perl_destruct_level = 0;
0a753a76	347
4f63d024	348	exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
0a753a76	349	if (!exitstatus) {
7766f137	350	#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
	351	# ifdef PERL_OBJECT
	352	CPerlHost *h = new CPerlHost();
	353	new_perl = perl_clone_using(my_perl, 1,
	354	h->m_pHostperlMem,
	355	h->m_pHostperlMemShared,
	356	h->m_pHostperlMemParse,
	357	h->m_pHostperlEnv,
	358	h->m_pHostperlStdIO,
	359	h->m_pHostperlLIO,
	360	h->m_pHostperlDir,
	361	h->m_pHostperlSock,
	362	h->m_pHostperlProc
	363	);
	364	CPerlObj pPerl = (CPerlObj)new_perl;
	365	# else
	366	new_perl = perl_clone(my_perl, 1);
	367	# endif
d18c6117	368	exitstatus = perl_run( new_perl );
971a9dd3	369	SetPerlInterpreter(my_perl);
d18c6117	370	#else
0a753a76	371	exitstatus = perl_run( my_perl );
d18c6117	372	#endif
0a753a76	373	}
0a753a76	374
0a753a76	375	perl_destruct( my_perl );
0a753a76	376	perl_free( my_perl );
ed094faf	377	#ifdef USE_ITHREADS
	378	if (new_perl) {
	379	SetPerlInterpreter(new_perl);
	380	perl_destruct(new_perl);
	381	perl_free(new_perl);
	382	}
	383	#endif
0a753a76	384
	385	PERL_SYS_TERM();
	386
68dc0745	387	return (exitstatus);
0a753a76	388	}
0a753a76	389
68dc0745	390	BOOL APIENTRY
	391	DllMain(HANDLE hModule, /* DLL module handle */
	392	DWORD fdwReason, /* reason called */
	393	LPVOID lpvReserved) /* reserved */
0a753a76	394	{
68dc0745	395	switch (fdwReason) {
	396	/* The DLL is attaching to a process due to process
	397	* initialization or a call to LoadLibrary.
	398	*/
	399	case DLL_PROCESS_ATTACH:
	400	/* #define DEFAULT_BINMODE */
0a753a76	401	#ifdef DEFAULT_BINMODE
3e3baf6d	402	setmode( fileno( stdin ), O_BINARY );
	403	setmode( fileno( stdout ), O_BINARY );
	404	setmode( fileno( stderr ), O_BINARY );
	405	_fmode = O_BINARY;
0a753a76	406	#endif
0cb96387	407	g_TlsAllocIndex = TlsAlloc();
0cb96387	408	DisableThreadLibraryCalls(hModule);
2d7a9237	409	w32_perldll_handle = hModule;
68dc0745	410	break;
0a753a76	411
68dc0745	412	/* The DLL is detaching from a process due to
	413	* process termination or call to FreeLibrary.
	414	*/
	415	case DLL_PROCESS_DETACH:
0cb96387	416	TlsFree(g_TlsAllocIndex);
68dc0745	417	break;
0a753a76	418
68dc0745	419	/* The attached process creates a new thread. */
	420	case DLL_THREAD_ATTACH:
	421	break;
0a753a76	422
68dc0745	423	/* The thread of the attached process terminates. */
	424	case DLL_THREAD_DETACH:
	425	break;
0a753a76	426
68dc0745	427	default:
	428	break;
	429	}
	430	return TRUE;
0a753a76	431	}