This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixup Perl_magic_freemglob()
[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
7766f137 47#include "perlhost.h"
0cb96387 48
222c300a
NIS
49void
50win32_checkTLS(PerlInterpreter *host_perl)
51{
52 dTHX;
53 if (host_perl != my_perl) {
1604cfb0
MS
54 int *nowhere = NULL;
55 abort();
222c300a
NIS
56 }
57}
58
32e30700
GS
59EXTERN_C void
60perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
1604cfb0
MS
61 struct IPerlMemInfo* perlMemSharedInfo,
62 struct IPerlMemInfo* perlMemParseInfo,
63 struct IPerlEnvInfo* perlEnvInfo,
64 struct IPerlStdIOInfo* perlStdIOInfo,
65 struct IPerlLIOInfo* perlLIOInfo,
66 struct IPerlDirInfo* perlDirInfo,
67 struct IPerlSockInfo* perlSockInfo,
68 struct IPerlProcInfo* perlProcInfo)
0cb96387 69{
7766f137 70 if (perlMemInfo) {
1604cfb0
MS
71 Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
72 perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
0cb96387 73 }
7766f137 74 if (perlMemSharedInfo) {
1604cfb0
MS
75 Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
76 perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
7766f137
GS
77 }
78 if (perlMemParseInfo) {
1604cfb0
MS
79 Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
80 perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
7766f137
GS
81 }
82 if (perlEnvInfo) {
1604cfb0
MS
83 Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
84 perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
0cb96387 85 }
7766f137 86 if (perlStdIOInfo) {
1604cfb0
MS
87 Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
88 perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
0cb96387 89 }
7766f137 90 if (perlLIOInfo) {
1604cfb0
MS
91 Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
92 perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
0cb96387 93 }
7766f137 94 if (perlDirInfo) {
1604cfb0
MS
95 Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
96 perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
0cb96387 97 }
7766f137 98 if (perlSockInfo) {
1604cfb0
MS
99 Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
100 perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
0cb96387 101 }
7766f137 102 if (perlProcInfo) {
1604cfb0
MS
103 Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
104 perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
0cb96387
GS
105 }
106}
107
7766f137
GS
108EXTERN_C PerlInterpreter*
109perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
1604cfb0
MS
110 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
111 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
112 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
113 struct IPerlProc** ppProc)
0cb96387 114{
7766f137 115 PerlInterpreter *my_perl = NULL;
8a85dc4e 116 CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
1604cfb0 117 ppStdIO, ppLIO, ppDir, ppSock, ppProc);
7766f137 118
8a85dc4e 119 if (pHost) {
1604cfb0
MS
120 my_perl = perl_alloc_using(pHost->m_pHostperlMem,
121 pHost->m_pHostperlMemShared,
122 pHost->m_pHostperlMemParse,
123 pHost->m_pHostperlEnv,
124 pHost->m_pHostperlStdIO,
125 pHost->m_pHostperlLIO,
126 pHost->m_pHostperlDir,
127 pHost->m_pHostperlSock,
128 pHost->m_pHostperlProc);
129 if (my_perl) {
130 w32_internal_host = pHost;
131 pHost->host_perl = my_perl;
132 }
0cb96387 133 }
7766f137 134 return my_perl;
0cb96387
GS
135}
136
7766f137
GS
137EXTERN_C PerlInterpreter*
138perl_alloc(void)
0cb96387 139{
7766f137 140 PerlInterpreter* my_perl = NULL;
8a85dc4e
GS
141 CPerlHost* pHost = new CPerlHost();
142 if (pHost) {
1604cfb0
MS
143 my_perl = perl_alloc_using(pHost->m_pHostperlMem,
144 pHost->m_pHostperlMemShared,
145 pHost->m_pHostperlMemParse,
146 pHost->m_pHostperlEnv,
147 pHost->m_pHostperlStdIO,
148 pHost->m_pHostperlLIO,
149 pHost->m_pHostperlDir,
150 pHost->m_pHostperlSock,
151 pHost->m_pHostperlProc);
152 if (my_perl) {
153 w32_internal_host = pHost;
222c300a 154 pHost->host_perl = my_perl;
1604cfb0 155 }
0cb96387 156 }
7766f137 157 return my_perl;
0cb96387
GS
158}
159
1c0ca838
GS
160EXTERN_C void
161win32_delete_internal_host(void *h)
162{
163 CPerlHost *host = (CPerlHost*)h;
164 delete host;
165}
166
32e30700
GS
167#endif /* PERL_IMPLICIT_SYS */
168
7766f137
GS
169EXTERN_C HANDLE w32_perldll_handle;
170
c5be433b 171EXTERN_C DllExport int
0cb96387 172RunPerl(int argc, char **argv, char **env)
0a753a76 173{
68dc0745 174 int exitstatus;
ed094faf 175 PerlInterpreter *my_perl, *new_perl = NULL;
dc0472e9 176 bool use_environ = (env == environ);
0cb96387 177
0a753a76
PP
178 PERL_SYS_INIT(&argc,&argv);
179
68dc0745 180 if (!(my_perl = perl_alloc()))
1604cfb0 181 return (1);
642f9deb 182 perl_construct(my_perl);
b28d0864 183 PL_perl_destruct_level = 0;
0a753a76 184
dc0472e9
JD
185 /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
186 * This may reallocate the RTL environment block. Therefore we need
187 * to make sure that `env` continues to have the same value as `environ`
188 * if we have been called this way. If we have been called with any
189 * other value for `env` then all environment munging by PERL_SYS_INIT()
190 * will be lost again.
191 */
192 if (use_environ)
193 env = environ;
194
fe2024f9 195 if (!perl_parse(my_perl, xs_init, argc, argv, env)) {
7766f137 196#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
1604cfb0
MS
197 new_perl = perl_clone(my_perl, 1);
198 (void) perl_run(new_perl);
199 PERL_SET_THX(my_perl);
d18c6117 200#else
1604cfb0 201 (void) perl_run(my_perl);
d18c6117 202#endif
0a753a76 203 }
c254be07 204
d4a50999 205 exitstatus = perl_destruct(my_perl);
432ce874 206 perl_free(my_perl);
432ce874
YO
207#ifdef USE_ITHREADS
208 if (new_perl) {
1604cfb0
MS
209 PERL_SET_THX(new_perl);
210 exitstatus = perl_destruct(new_perl);
211 perl_free(new_perl);
ed094faf
GS
212 }
213#endif
0a753a76 214
c254be07 215 PERL_SYS_TERM();
0a753a76 216
68dc0745 217 return (exitstatus);
0a753a76
PP
218}
219
2fa86c13
GS
220EXTERN_C void
221set_w32_module_name(void);
222
b73db59c
GS
223EXTERN_C void
224EndSockets(void);
225
226
f8fb7c90
GS
227#ifdef __MINGW32__
228EXTERN_C /* GCC in C++ mode mangles the name, otherwise */
229#endif
68dc0745 230BOOL APIENTRY
a5d1065d 231DllMain(HINSTANCE hModule, /* DLL module handle */
1604cfb0
MS
232 DWORD fdwReason, /* reason called */
233 LPVOID lpvReserved) /* reserved */
0a753a76 234{
68dc0745 235 switch (fdwReason) {
1604cfb0
MS
236 /* The DLL is attaching to a process due to process
237 * initialization or a call to LoadLibrary.
238 */
68dc0745 239 case DLL_PROCESS_ATTACH:
1604cfb0 240 DisableThreadLibraryCalls((HMODULE)hModule);
7bd379e8 241
1604cfb0
MS
242 w32_perldll_handle = hModule;
243 set_w32_module_name();
244 break;
0a753a76 245
1604cfb0
MS
246 /* The DLL is detaching from a process due to
247 * process termination or call to FreeLibrary.
248 */
68dc0745 249 case DLL_PROCESS_DETACH:
ce3e5b80
NIS
250 /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
251 anything here had better be harmless if:
252 A. Not called at all.
253 B. Called after memory allocation for Heap has been forcibly removed by OS.
254 PerlIO_cleanup() was done here but fails (B).
255 */
1604cfb0 256 EndSockets();
3db8f154 257#if defined(USE_ITHREADS)
1604cfb0
MS
258 if (PL_curinterp)
259 FREE_THREAD_KEY;
e1b5da64 260#endif
1604cfb0 261 break;
0a753a76 262
1604cfb0 263 /* The attached process creates a new thread. */
68dc0745 264 case DLL_THREAD_ATTACH:
1604cfb0 265 break;
0a753a76 266
1604cfb0 267 /* The thread of the attached process terminates. */
68dc0745 268 case DLL_THREAD_DETACH:
1604cfb0 269 break;
0a753a76 270
68dc0745 271 default:
1604cfb0 272 break;
68dc0745
PP
273 }
274 return TRUE;
0a753a76 275}
c43294b8 276
7bd379e8 277
9613994f 278#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
c43294b8
AB
279EXTERN_C PerlInterpreter *
280perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
acfe0abc 281 dTHX;
c43294b8
AB
282 CPerlHost *h;
283 h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
284 proto_perl = perl_clone_using(proto_perl, flags,
285 h->m_pHostperlMem,
286 h->m_pHostperlMemShared,
287 h->m_pHostperlMemParse,
288 h->m_pHostperlEnv,
289 h->m_pHostperlStdIO,
290 h->m_pHostperlLIO,
291 h->m_pHostperlDir,
292 h->m_pHostperlSock,
293 h->m_pHostperlProc
294 );
295 proto_perl->Isys_intern.internal_host = h;
222c300a 296 h->host_perl = proto_perl;
c43294b8 297 return proto_perl;
1604cfb0 298
c43294b8
AB
299}
300#endif