This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
set PERL_EXIT_DESTRUCT_END in all embeddings
[perl5.git] / win32 / perllib.c
CommitLineData
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
PP
9#include "EXTERN.h"
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"
16#include <fcntl.h>
7766f137 17#endif /* PERL_IMPLICIT_SYS */
0cb96387 18
0cb96387 19
7766f137 20/* Register any extra external extensions */
fe1c5936 21const char * const staticlinkmodules[] = {
7766f137 22 "DynaLoader",
d2b25974 23 /* other similar records will be included from "perllibst.h" */
d2b25974
VK
24#define STATIC1
25#include "perllibst.h"
7766f137 26 NULL,
0cb96387
GS
27};
28
acfe0abc 29EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
d2b25974 30/* other similar records will be included from "perllibst.h" */
d2b25974
VK
31#define STATIC2
32#include "perllibst.h"
0cb96387 33
7766f137 34static void
acfe0abc 35xs_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
42#include "perllibst.h"
0cb96387
GS
43}
44
7766f137 45#ifdef PERL_IMPLICIT_SYS
0cb96387 46
7bd379e8
YO
47/* WINCE: include replaced by:
48extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
49*/
7766f137 50#include "perlhost.h"
0cb96387 51
222c300a
NIS
52void
53win32_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
67int GetLogicalDrives() {
68 return 0; /* no logical drives on CE */
69}
70int GetLogicalDriveStrings(int size, char addr[]) {
71 return 0; /* no logical drives on CE */
72}
73/* TBD */
74DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) {
75 return 0;
76}
77/* TBD */
78DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) {
79 return 0;
80}
81/* TBD */
82DWORD SetCurrentDirectoryA(LPSTR pPath) {
83 return 0;
84}
85/* TBD */
86DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
87 return 0;
88}
89int xcesetuid(uid_t id){return 0;}
90int xceseteuid(uid_t id){ return 0;}
91int xcegetuid() {return 0;}
92int xcegeteuid(){ return 0;}
93#endif
94
95/* WINCE??: include "perlhost.h" */
96
32e30700
GS
97EXTERN_C void
98perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
7766f137
GS
99 struct IPerlMemInfo* perlMemSharedInfo,
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
146EXTERN_C PerlInterpreter*
147perl_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,
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}
174
7766f137
GS
175EXTERN_C PerlInterpreter*
176perl_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}
197
1c0ca838
GS
198EXTERN_C void
199win32_delete_internal_host(void *h)
200{
201 CPerlHost *host = (CPerlHost*)h;
202 delete host;
203}
204
32e30700
GS
205#endif /* PERL_IMPLICIT_SYS */
206
7766f137
GS
207EXTERN_C HANDLE w32_perldll_handle;
208
c5be433b 209EXTERN_C DllExport int
0cb96387 210RunPerl(int argc, char **argv, char **env)
0a753a76 211{
68dc0745 212 int exitstatus;
ed094faf 213 PerlInterpreter *my_perl, *new_perl = NULL;
dc0472e9 214 bool use_environ = (env == environ);
0cb96387 215
22239a37 216#ifdef PERL_GLOBAL_STRUCT
115ff745
NC
217#define PERLVAR(prefix,var,type) /**/
218#define PERLVARA(prefix,var,type) /**/
219#define PERLVARI(prefix,var,type,init) PL_Vars.prefix##var = init;
220#define PERLVARIC(prefix,var,type,init) PL_Vars.prefix##var = init;
22239a37
NIS
221#include "perlvars.h"
222#undef PERLVAR
51371543 223#undef PERLVARA
22239a37 224#undef PERLVARI
3fe35a81 225#undef PERLVARIC
22239a37
NIS
226#endif
227
0a753a76
PP
228 PERL_SYS_INIT(&argc,&argv);
229
68dc0745
PP
230 if (!(my_perl = perl_alloc()))
231 return (1);
642f9deb 232 perl_construct(my_perl);
8e920bd3 233 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
b28d0864 234 PL_perl_destruct_level = 0;
0a753a76 235
dc0472e9
JD
236 /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
237 * This may reallocate the RTL environment block. Therefore we need
238 * to make sure that `env` continues to have the same value as `environ`
239 * if we have been called this way. If we have been called with any
240 * other value for `env` then all environment munging by PERL_SYS_INIT()
241 * will be lost again.
242 */
243 if (use_environ)
244 env = environ;
245
fe2024f9 246 if (!perl_parse(my_perl, xs_init, argc, argv, env)) {
7766f137 247#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
7766f137 248 new_perl = perl_clone(my_perl, 1);
fe2024f9 249 (void) perl_run(new_perl);
ba869deb 250 PERL_SET_THX(my_perl);
d18c6117 251#else
fe2024f9 252 (void) perl_run(my_perl);
d18c6117 253#endif
0a753a76 254 }
c254be07 255
d4a50999 256 exitstatus = perl_destruct(my_perl);
432ce874 257 perl_free(my_perl);
432ce874
YO
258#ifdef USE_ITHREADS
259 if (new_perl) {
260 PERL_SET_THX(new_perl);
fe2024f9 261 exitstatus = perl_destruct(new_perl);
ed094faf
GS
262 perl_free(new_perl);
263 }
264#endif
0a753a76 265
c254be07 266 PERL_SYS_TERM();
0a753a76 267
68dc0745 268 return (exitstatus);
0a753a76
PP
269}
270
2fa86c13
GS
271EXTERN_C void
272set_w32_module_name(void);
273
b73db59c
GS
274EXTERN_C void
275EndSockets(void);
276
277
f8fb7c90
GS
278#ifdef __MINGW32__
279EXTERN_C /* GCC in C++ mode mangles the name, otherwise */
280#endif
68dc0745 281BOOL APIENTRY
a5d1065d 282DllMain(HINSTANCE hModule, /* DLL module handle */
68dc0745
PP
283 DWORD fdwReason, /* reason called */
284 LPVOID lpvReserved) /* reserved */
0a753a76 285{
68dc0745
PP
286 switch (fdwReason) {
287 /* The DLL is attaching to a process due to process
288 * initialization or a call to LoadLibrary.
289 */
290 case DLL_PROCESS_ATTACH:
7bd379e8 291#ifndef UNDER_CE
5db10396 292 DisableThreadLibraryCalls((HMODULE)hModule);
7bd379e8
YO
293#endif
294
2d7a9237 295 w32_perldll_handle = hModule;
2fa86c13 296 set_w32_module_name();
68dc0745 297 break;
0a753a76 298
68dc0745
PP
299 /* The DLL is detaching from a process due to
300 * process termination or call to FreeLibrary.
301 */
302 case DLL_PROCESS_DETACH:
ce3e5b80
NIS
303 /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
304 anything here had better be harmless if:
305 A. Not called at all.
306 B. Called after memory allocation for Heap has been forcibly removed by OS.
307 PerlIO_cleanup() was done here but fails (B).
308 */
b73db59c 309 EndSockets();
3db8f154 310#if defined(USE_ITHREADS)
e1b5da64
GS
311 if (PL_curinterp)
312 FREE_THREAD_KEY;
313#endif
68dc0745 314 break;
0a753a76 315
68dc0745
PP
316 /* The attached process creates a new thread. */
317 case DLL_THREAD_ATTACH:
318 break;
0a753a76 319
68dc0745
PP
320 /* The thread of the attached process terminates. */
321 case DLL_THREAD_DETACH:
322 break;
0a753a76 323
68dc0745
PP
324 default:
325 break;
326 }
327 return TRUE;
0a753a76 328}
c43294b8 329
7bd379e8 330
9613994f 331#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
c43294b8
AB
332EXTERN_C PerlInterpreter *
333perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
acfe0abc 334 dTHX;
c43294b8
AB
335 CPerlHost *h;
336 h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
337 proto_perl = perl_clone_using(proto_perl, flags,
338 h->m_pHostperlMem,
339 h->m_pHostperlMemShared,
340 h->m_pHostperlMemParse,
341 h->m_pHostperlEnv,
342 h->m_pHostperlStdIO,
343 h->m_pHostperlLIO,
344 h->m_pHostperlDir,
345 h->m_pHostperlSock,
346 h->m_pHostperlProc
347 );
348 proto_perl->Isys_intern.internal_host = h;
222c300a 349 h->host_perl = proto_perl;
c43294b8
AB
350 return proto_perl;
351
352}
353#endif