[perl5.git] / win32 / perllib.c

/*
 *      The Road goes ever on and on
 *          Down from the door where it began.
 *
 *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
 *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
 */
#define PERLIO_NOT_STDIO 0
#include "EXTERN.h"
#include "perl.h"

#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",
    /* other similar records will be included from "perllibst.h" */
#define STATIC1
#include "perllibst.h"
    NULL,
};

EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
/* other similar records will be included from "perllibst.h" */
#define STATIC2
#include "perllibst.h"

static void
xs_init(pTHX)
{
    char *file = __FILE__;
    dXSUB_SYS;
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    /* other similar records will be included from "perllibst.h" */
#define STATIC3
#include "perllibst.h"
}

#ifdef PERL_IMPLICIT_SYS

/* WINCE: include replaced by:
extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
*/
#include "perlhost.h"

void
win32_checkTLS(PerlInterpreter *host_perl)
{
    dTHX;
    if (host_perl != my_perl) {
	int *nowhere = NULL;
#ifdef UNDER_CE
	printf(" ... bad in win32_checkTLS\n");
	printf("  %08X ne %08X\n",host_perl,my_perl);
#endif
	abort();
    }
}

#ifdef UNDER_CE
int GetLogicalDrives() {
    return 0; /* no logical drives on CE */
}
int GetLogicalDriveStrings(int size, char addr[]) {
    return 0; /* no logical drives on CE */
}
/* TBD */
DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf,  LPSTR *pfile) {
    return 0;
}
/* TBD */
DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf,  WCHAR **pfile) {
    return 0;
}
/* TBD */
DWORD SetCurrentDirectoryA(LPSTR pPath) {
    return 0;
}
/* TBD */
DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
    return 0;
}
int xcesetuid(uid_t id){return 0;}
int xceseteuid(uid_t id){  return 0;}
int xcegetuid() {return 0;}
int xcegeteuid(){ return 0;}
#endif

/* WINCE??: 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*));
    }
}

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;
    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) {
	    w32_internal_host = pHost;
	    pHost->host_perl  = my_perl;
	}
    }
    return my_perl;
}

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) {
	    w32_internal_host = pHost;
            pHost->host_perl  = my_perl;
	}
    }
    return my_perl;
}

EXTERN_C void
win32_delete_internal_host(void *h)
{
    CPerlHost *host = (CPerlHost*)h;
    delete host;
}

#endif /* PERL_IMPLICIT_SYS */

EXTERN_C HANDLE w32_perldll_handle;

EXTERN_C DllExport int
RunPerl(int argc, char **argv, char **env)
{
    int exitstatus;
    PerlInterpreter *my_perl, *new_perl = NULL;
    OSVERSIONINFO osver;
    char szModuleName[MAX_PATH];
    char *arg0 = argv[0];
    char *ansi = NULL;
    bool use_environ = (env == environ);

    osver.dwOSVersionInfoSize = sizeof(osver);
    GetVersionEx(&osver);

    if (osver.dwMajorVersion > 4) {
        WCHAR widename[MAX_PATH];
        GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
        argv[0] = ansi = win32_ansipath(widename);
    }
    else {
        Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
        (void)win32_longpath(szModuleName);
        argv[0] = szModuleName;
    }

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

    /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
     * This may reallocate the RTL environment block. Therefore we need
     * to make sure that `env` continues to have the same value as `environ`
     * if we have been called this way.  If we have been called with any
     * other value for `env` then all environment munging by PERL_SYS_INIT()
     * will be lost again.
     */
    if (use_environ)
        env = environ;

    exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
    if (!exitstatus) {
#if defined(TOP_CLONE) && defined(USE_ITHREADS)		/* XXXXXX testing */
	new_perl = perl_clone(my_perl, 1);
	exitstatus = perl_run(new_perl);
	PERL_SET_THX(my_perl);
#else
	exitstatus = perl_run(my_perl);
#endif
    }

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

    /* At least the Borland RTL wants to free argv[] after main() returns. */
    argv[0] = arg0;
    if (ansi)
        win32_free(ansi);

    PERL_SYS_TERM();

    return (exitstatus);
}

EXTERN_C void
set_w32_module_name(void);

EXTERN_C void
EndSockets(void);


#ifdef __MINGW32__
EXTERN_C		/* GCC in C++ mode mangles the name, otherwise */
#endif
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

#ifndef UNDER_CE
	DisableThreadLibraryCalls((HMODULE)hModule);
#endif

	w32_perldll_handle = hModule;
	set_w32_module_name();
	break;

	/* The DLL is detaching from a process due to
	 * process termination or call to FreeLibrary.
	 */
    case DLL_PROCESS_DETACH:
        /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
           anything here had better be harmless if:
            A. Not called at all.
            B. Called after memory allocation for Heap has been forcibly removed by OS.
            PerlIO_cleanup() was done here but fails (B).
         */     
	EndSockets();
#if defined(USE_ITHREADS)
	if (PL_curinterp)
	    FREE_THREAD_KEY;
#endif
	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;
}


#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
EXTERN_C PerlInterpreter *
perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
    dTHX;
    CPerlHost *h;
    h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
    proto_perl = perl_clone_using(proto_perl, flags,
                        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
    );
    proto_perl->Isys_intern.internal_host = h;
    h->host_perl  = proto_perl;
    return proto_perl;
	
}
#endif
Commit	Line	Data
0a753a76	1	/*
4ac71550 TC	2	* The Road goes ever on and on
	3	* Down from the door where it began.
	4	*
	5	* [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
	6	* [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
0a753a76	7	*/
adb71456	8	#define PERLIO_NOT_STDIO 0
0a753a76	9	#include "EXTERN.h"
0a753a76	10	#include "perl.h"
0cb96387	11
96e4d5b1	12	#include "XSUB.h"
0a753a76	13
32e30700	14	#ifdef PERL_IMPLICIT_SYS
0cb96387 GS	15	#include "win32iop.h"
0cb96387 GS	16	#include <fcntl.h>
7766f137	17	#endif /* PERL_IMPLICIT_SYS */
0cb96387	18
0cb96387	19
7766f137 GS	20	/* Register any extra external extensions */
	21	char *staticlinkmodules[] = {
	22	"DynaLoader",
d2b25974	23	/* other similar records will be included from "perllibst.h" */
d2b25974 VK	24	#define STATIC1
d2b25974 VK	25	#include "perllibst.h"
7766f137	26	NULL,
0cb96387 GS	27	};
0cb96387 GS	28
acfe0abc	29	EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
d2b25974	30	/* other similar records will be included from "perllibst.h" */
d2b25974 VK	31	#define STATIC2
d2b25974 VK	32	#include "perllibst.h"
0cb96387	33
7766f137	34	static void
acfe0abc	35	xs_init(pTHX)
0cb96387	36	{
7766f137 GS	37	char *file = __FILE__;
	38	dXSUB_SYS;
	39	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
d2b25974	40	/* other similar records will be included from "perllibst.h" */
d2b25974 VK	41	#define STATIC3
d2b25974 VK	42	#include "perllibst.h"
0cb96387 GS	43	}
0cb96387 GS	44
7766f137	45	#ifdef PERL_IMPLICIT_SYS
0cb96387	46
7bd379e8 YO	47	/* WINCE: include replaced by:
	48	extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
	49	*/
7766f137	50	#include "perlhost.h"
0cb96387	51
222c300a NIS	52	void
	53	win32_checkTLS(PerlInterpreter *host_perl)
	54	{
	55	dTHX;
	56	if (host_perl != my_perl) {
	57	int *nowhere = NULL;
45496817	58	#ifdef UNDER_CE
7bd379e8 YO	59	printf(" ... bad in win32_checkTLS\n");
	60	printf(" %08X ne %08X\n",host_perl,my_perl);
	61	#endif
222c300a NIS	62	abort();
	63	}
	64	}
	65
7bd379e8 YO	66	#ifdef UNDER_CE
	67	int GetLogicalDrives() {
	68	return 0; /* no logical drives on CE */
	69	}
	70	int GetLogicalDriveStrings(int size, char addr[]) {
	71	return 0; /* no logical drives on CE */
	72	}
	73	/* TBD */
	74	DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) {
	75	return 0;
	76	}
	77	/* TBD */
	78	DWORD GetFullPathNameW(CONST WCHAR fn, DWORD blen, WCHAR buf, WCHAR **pfile) {
	79	return 0;
	80	}
	81	/* TBD */
	82	DWORD SetCurrentDirectoryA(LPSTR pPath) {
	83	return 0;
	84	}
	85	/* TBD */
	86	DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
	87	return 0;
	88	}
	89	int xcesetuid(uid_t id){return 0;}
	90	int xceseteuid(uid_t id){ return 0;}
	91	int xcegetuid() {return 0;}
	92	int xcegeteuid(){ return 0;}
	93	#endif
	94
	95	/* WINCE??: include "perlhost.h" */
	96
32e30700 GS	97	EXTERN_C void
32e30700 GS	98	perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
7766f137 GS	99	struct IPerlMemInfo* perlMemSharedInfo,
7766f137 GS	100	struct IPerlMemInfo* perlMemParseInfo,
32e30700 GS	101	struct IPerlEnvInfo* perlEnvInfo,
	102	struct IPerlStdIOInfo* perlStdIOInfo,
	103	struct IPerlLIOInfo* perlLIOInfo,
	104	struct IPerlDirInfo* perlDirInfo,
	105	struct IPerlSockInfo* perlSockInfo,
	106	struct IPerlProcInfo* perlProcInfo)
0cb96387	107	{
7766f137	108	if (perlMemInfo) {
0cb96387 GS	109	Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
	110	perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	111	}
7766f137 GS	112	if (perlMemSharedInfo) {
	113	Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
	114	perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	115	}
	116	if (perlMemParseInfo) {
	117	Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
	118	perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
	119	}
	120	if (perlEnvInfo) {
0cb96387 GS	121	Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
	122	perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
	123	}
7766f137	124	if (perlStdIOInfo) {
0cb96387 GS	125	Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
	126	perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
	127	}
7766f137	128	if (perlLIOInfo) {
0cb96387 GS	129	Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
	130	perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
	131	}
7766f137	132	if (perlDirInfo) {
0cb96387 GS	133	Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
	134	perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
	135	}
7766f137	136	if (perlSockInfo) {
0cb96387 GS	137	Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
	138	perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
	139	}
7766f137	140	if (perlProcInfo) {
0cb96387 GS	141	Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
	142	perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
	143	}
	144	}
	145
7766f137 GS	146	EXTERN_C PerlInterpreter*
	147	perl_alloc_override(struct IPerlMem ppMem, struct IPerlMem ppMemShared,
	148	struct IPerlMem ppMemParse, struct IPerlEnv ppEnv,
	149	struct IPerlStdIO ppStdIO, struct IPerlLIO ppLIO,
	150	struct IPerlDir ppDir, struct IPerlSock ppSock,
	151	struct IPerlProc** ppProc)
0cb96387	152	{
7766f137	153	PerlInterpreter *my_perl = NULL;
8a85dc4e GS	154	CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
8a85dc4e GS	155	ppStdIO, ppLIO, ppDir, ppSock, ppProc);
7766f137	156
8a85dc4e GS	157	if (pHost) {
	158	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
	159	pHost->m_pHostperlMemShared,
	160	pHost->m_pHostperlMemParse,
	161	pHost->m_pHostperlEnv,
	162	pHost->m_pHostperlStdIO,
	163	pHost->m_pHostperlLIO,
	164	pHost->m_pHostperlDir,
	165	pHost->m_pHostperlSock,
	166	pHost->m_pHostperlProc);
	167	if (my_perl) {
8a85dc4e	168	w32_internal_host = pHost;
222c300a	169	pHost->host_perl = my_perl;
7766f137	170	}
0cb96387	171	}
7766f137	172	return my_perl;
0cb96387 GS	173	}
0cb96387 GS	174
7766f137 GS	175	EXTERN_C PerlInterpreter*
7766f137 GS	176	perl_alloc(void)
0cb96387	177	{
7766f137	178	PerlInterpreter* my_perl = NULL;
8a85dc4e GS	179	CPerlHost* pHost = new CPerlHost();
	180	if (pHost) {
	181	my_perl = perl_alloc_using(pHost->m_pHostperlMem,
	182	pHost->m_pHostperlMemShared,
	183	pHost->m_pHostperlMemParse,
	184	pHost->m_pHostperlEnv,
	185	pHost->m_pHostperlStdIO,
	186	pHost->m_pHostperlLIO,
	187	pHost->m_pHostperlDir,
	188	pHost->m_pHostperlSock,
	189	pHost->m_pHostperlProc);
	190	if (my_perl) {
8a85dc4e	191	w32_internal_host = pHost;
222c300a	192	pHost->host_perl = my_perl;
7766f137	193	}
0cb96387	194	}
7766f137	195	return my_perl;
0cb96387 GS	196	}
0cb96387 GS	197
1c0ca838 GS	198	EXTERN_C void
	199	win32_delete_internal_host(void *h)
	200	{
	201	CPerlHost host = (CPerlHost)h;
	202	delete host;
	203	}
	204
32e30700 GS	205	#endif /* PERL_IMPLICIT_SYS */
32e30700 GS	206
7766f137 GS	207	EXTERN_C HANDLE w32_perldll_handle;
7766f137 GS	208
c5be433b	209	EXTERN_C DllExport int
0cb96387	210	RunPerl(int argc, char argv, char env)
0a753a76	211	{
68dc0745	212	int exitstatus;
ed094faf	213	PerlInterpreter my_perl, new_perl = NULL;
aa2b96ec	214	OSVERSIONINFO osver;
0cb96387	215	char szModuleName[MAX_PATH];
aa2b96ec JD	216	char *arg0 = argv[0];
aa2b96ec JD	217	char *ansi = NULL;
dc0472e9	218	bool use_environ = (env == environ);
0cb96387	219
aa2b96ec JD	220	osver.dwOSVersionInfoSize = sizeof(osver);
	221	GetVersionEx(&osver);
	222
3839a0fa	223	if (osver.dwMajorVersion > 4) {
aa2b96ec JD	224	WCHAR widename[MAX_PATH];
	225	GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
	226	argv[0] = ansi = win32_ansipath(widename);
	227	}
	228	else {
	229	Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
	230	(void)win32_longpath(szModuleName);
	231	argv[0] = szModuleName;
	232	}
0cb96387	233
22239a37 NIS	234	#ifdef PERL_GLOBAL_STRUCT
22239a37 NIS	235	#define PERLVAR(var,type) /**/
51371543	236	#define PERLVARA(var,type) /**/
533c011a NIS	237	#define PERLVARI(var,type,init) PL_Vars.var = init;
533c011a NIS	238	#define PERLVARIC(var,type,init) PL_Vars.var = init;
22239a37 NIS	239	#include "perlvars.h"
22239a37 NIS	240	#undef PERLVAR
51371543	241	#undef PERLVARA
22239a37	242	#undef PERLVARI
3fe35a81	243	#undef PERLVARIC
22239a37 NIS	244	#endif
22239a37 NIS	245
0a753a76	246	PERL_SYS_INIT(&argc,&argv);
0a753a76	247
68dc0745	248	if (!(my_perl = perl_alloc()))
68dc0745	249	return (1);
642f9deb	250	perl_construct(my_perl);
b28d0864	251	PL_perl_destruct_level = 0;
0a753a76	252
dc0472e9 JD	253	/* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
	254	* This may reallocate the RTL environment block. Therefore we need
	255	* to make sure that `env` continues to have the same value as `environ`
	256	* if we have been called this way. If we have been called with any
	257	* other value for `env` then all environment munging by PERL_SYS_INIT()
	258	* will be lost again.
	259	*/
	260	if (use_environ)
	261	env = environ;
	262
4f63d024	263	exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
0a753a76	264	if (!exitstatus) {
7766f137	265	#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
7766f137	266	new_perl = perl_clone(my_perl, 1);
642f9deb	267	exitstatus = perl_run(new_perl);
ba869deb	268	PERL_SET_THX(my_perl);
d18c6117	269	#else
642f9deb	270	exitstatus = perl_run(my_perl);
d18c6117	271	#endif
0a753a76	272	}
c254be07	273
642f9deb	274	perl_destruct(my_perl);
432ce874	275	perl_free(my_perl);
432ce874 YO	276	#ifdef USE_ITHREADS
	277	if (new_perl) {
	278	PERL_SET_THX(new_perl);
c254be07	279	perl_destruct(new_perl);
ed094faf GS	280	perl_free(new_perl);
	281	}
	282	#endif
0a753a76	283
aa2b96ec JD	284	/* At least the Borland RTL wants to free argv[] after main() returns. */
	285	argv[0] = arg0;
	286	if (ansi)
	287	win32_free(ansi);
	288
c254be07	289	PERL_SYS_TERM();
0a753a76	290
68dc0745	291	return (exitstatus);
0a753a76	292	}
0a753a76	293
2fa86c13 GS	294	EXTERN_C void
	295	set_w32_module_name(void);
	296
b73db59c GS	297	EXTERN_C void
	298	EndSockets(void);
	299
	300
f8fb7c90 GS	301	#ifdef __MINGW32__
	302	EXTERN_C /* GCC in C++ mode mangles the name, otherwise */
	303	#endif
68dc0745	304	BOOL APIENTRY
	305	DllMain(HANDLE hModule, /* DLL module handle */
	306	DWORD fdwReason, /* reason called */
	307	LPVOID lpvReserved) /* reserved */
0a753a76	308	{
68dc0745	309	switch (fdwReason) {
	310	/* The DLL is attaching to a process due to process
	311	* initialization or a call to LoadLibrary.
	312	*/
	313	case DLL_PROCESS_ATTACH:
	314	/* #define DEFAULT_BINMODE */
0a753a76	315	#ifdef DEFAULT_BINMODE
3e3baf6d TB	316	setmode( fileno( stdin ), O_BINARY );
	317	setmode( fileno( stdout ), O_BINARY );
	318	setmode( fileno( stderr ), O_BINARY );
	319	_fmode = O_BINARY;
0a753a76	320	#endif
7bd379e8 YO	321
7bd379e8 YO	322	#ifndef UNDER_CE
5db10396	323	DisableThreadLibraryCalls((HMODULE)hModule);
7bd379e8 YO	324	#endif
7bd379e8 YO	325
2d7a9237	326	w32_perldll_handle = hModule;
2fa86c13	327	set_w32_module_name();
68dc0745	328	break;
0a753a76	329
68dc0745	330	/* The DLL is detaching from a process due to
	331	* process termination or call to FreeLibrary.
	332	*/
	333	case DLL_PROCESS_DETACH:
ce3e5b80 NIS	334	/* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
	335	anything here had better be harmless if:
	336	A. Not called at all.
	337	B. Called after memory allocation for Heap has been forcibly removed by OS.
	338	PerlIO_cleanup() was done here but fails (B).
	339	*/
b73db59c	340	EndSockets();
3db8f154	341	#if defined(USE_ITHREADS)
e1b5da64 GS	342	if (PL_curinterp)
	343	FREE_THREAD_KEY;
	344	#endif
68dc0745	345	break;
0a753a76	346
68dc0745	347	/* The attached process creates a new thread. */
	348	case DLL_THREAD_ATTACH:
	349	break;
0a753a76	350
68dc0745	351	/* The thread of the attached process terminates. */
	352	case DLL_THREAD_DETACH:
	353	break;
0a753a76	354
68dc0745	355	default:
	356	break;
	357	}
	358	return TRUE;
0a753a76	359	}
c43294b8	360
7bd379e8	361
9613994f	362	#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
c43294b8 AB	363	EXTERN_C PerlInterpreter *
c43294b8 AB	364	perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
acfe0abc	365	dTHX;
c43294b8 AB	366	CPerlHost *h;
	367	h = new CPerlHost((CPerlHost)PL_sys_intern.internal_host);
	368	proto_perl = perl_clone_using(proto_perl, flags,
	369	h->m_pHostperlMem,
	370	h->m_pHostperlMemShared,
	371	h->m_pHostperlMemParse,
	372	h->m_pHostperlEnv,
	373	h->m_pHostperlStdIO,
	374	h->m_pHostperlLIO,
	375	h->m_pHostperlDir,
	376	h->m_pHostperlSock,
	377	h->m_pHostperlProc
	378	);
	379	proto_perl->Isys_intern.internal_host = h;
222c300a	380	h->host_perl = proto_perl;
c43294b8 AB	381	return proto_perl;
	382
	383	}
	384	#endif