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" |
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 | 21 | const 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 | 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 |
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 |
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 |
49 | void |
50 | win32_checkTLS(PerlInterpreter *host_perl) | |
51 | { | |
52 | dTHX; | |
53 | if (host_perl != my_perl) { | |
54 | int *nowhere = NULL; | |
222c300a NIS |
55 | abort(); |
56 | } | |
57 | } | |
58 | ||
32e30700 GS |
59 | EXTERN_C void |
60 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, | |
7766f137 GS |
61 | struct IPerlMemInfo* perlMemSharedInfo, |
62 | struct IPerlMemInfo* perlMemParseInfo, | |
32e30700 GS |
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) { |
0cb96387 GS |
71 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
72 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
73 | } | |
7766f137 GS |
74 | if (perlMemSharedInfo) { |
75 | Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); | |
76 | perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
77 | } | |
78 | if (perlMemParseInfo) { | |
79 | Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); | |
80 | perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
81 | } | |
82 | if (perlEnvInfo) { | |
0cb96387 GS |
83 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
84 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); | |
85 | } | |
7766f137 | 86 | if (perlStdIOInfo) { |
0cb96387 GS |
87 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
88 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); | |
89 | } | |
7766f137 | 90 | if (perlLIOInfo) { |
0cb96387 GS |
91 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
92 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); | |
93 | } | |
7766f137 | 94 | if (perlDirInfo) { |
0cb96387 GS |
95 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
96 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); | |
97 | } | |
7766f137 | 98 | if (perlSockInfo) { |
0cb96387 GS |
99 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
100 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); | |
101 | } | |
7766f137 | 102 | if (perlProcInfo) { |
0cb96387 GS |
103 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
104 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); | |
105 | } | |
106 | } | |
107 | ||
7766f137 GS |
108 | EXTERN_C PerlInterpreter* |
109 | perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, | |
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 GS |
116 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
117 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); | |
7766f137 | 118 | |
8a85dc4e GS |
119 | if (pHost) { |
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) { | |
8a85dc4e | 130 | w32_internal_host = pHost; |
222c300a | 131 | pHost->host_perl = my_perl; |
7766f137 | 132 | } |
0cb96387 | 133 | } |
7766f137 | 134 | return my_perl; |
0cb96387 GS |
135 | } |
136 | ||
7766f137 GS |
137 | EXTERN_C PerlInterpreter* |
138 | perl_alloc(void) | |
0cb96387 | 139 | { |
7766f137 | 140 | PerlInterpreter* my_perl = NULL; |
8a85dc4e GS |
141 | CPerlHost* pHost = new CPerlHost(); |
142 | if (pHost) { | |
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) { | |
8a85dc4e | 153 | w32_internal_host = pHost; |
222c300a | 154 | pHost->host_perl = my_perl; |
7766f137 | 155 | } |
0cb96387 | 156 | } |
7766f137 | 157 | return my_perl; |
0cb96387 GS |
158 | } |
159 | ||
1c0ca838 GS |
160 | EXTERN_C void |
161 | win32_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 |
169 | EXTERN_C HANDLE w32_perldll_handle; |
170 | ||
c5be433b | 171 | EXTERN_C DllExport int |
0cb96387 | 172 | RunPerl(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 | 178 | PERL_SYS_INIT(&argc,&argv); |
179 | ||
68dc0745 | 180 | if (!(my_perl = perl_alloc())) |
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 */ |
7766f137 | 197 | new_perl = perl_clone(my_perl, 1); |
fe2024f9 | 198 | (void) perl_run(new_perl); |
ba869deb | 199 | PERL_SET_THX(my_perl); |
d18c6117 | 200 | #else |
fe2024f9 | 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) { | |
209 | PERL_SET_THX(new_perl); | |
fe2024f9 | 210 | exitstatus = perl_destruct(new_perl); |
ed094faf GS |
211 | perl_free(new_perl); |
212 | } | |
213 | #endif | |
0a753a76 | 214 | |
c254be07 | 215 | PERL_SYS_TERM(); |
0a753a76 | 216 | |
68dc0745 | 217 | return (exitstatus); |
0a753a76 | 218 | } |
219 | ||
2fa86c13 GS |
220 | EXTERN_C void |
221 | set_w32_module_name(void); | |
222 | ||
b73db59c GS |
223 | EXTERN_C void |
224 | EndSockets(void); | |
225 | ||
226 | ||
f8fb7c90 GS |
227 | #ifdef __MINGW32__ |
228 | EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ | |
229 | #endif | |
68dc0745 | 230 | BOOL APIENTRY |
a5d1065d | 231 | DllMain(HINSTANCE hModule, /* DLL module handle */ |
68dc0745 | 232 | DWORD fdwReason, /* reason called */ |
233 | LPVOID lpvReserved) /* reserved */ | |
0a753a76 | 234 | { |
68dc0745 | 235 | switch (fdwReason) { |
236 | /* The DLL is attaching to a process due to process | |
237 | * initialization or a call to LoadLibrary. | |
238 | */ | |
239 | case DLL_PROCESS_ATTACH: | |
5db10396 | 240 | DisableThreadLibraryCalls((HMODULE)hModule); |
7bd379e8 | 241 | |
2d7a9237 | 242 | w32_perldll_handle = hModule; |
2fa86c13 | 243 | set_w32_module_name(); |
68dc0745 | 244 | break; |
0a753a76 | 245 | |
68dc0745 | 246 | /* The DLL is detaching from a process due to |
247 | * process termination or call to FreeLibrary. | |
248 | */ | |
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 | */ | |
b73db59c | 256 | EndSockets(); |
3db8f154 | 257 | #if defined(USE_ITHREADS) |
e1b5da64 GS |
258 | if (PL_curinterp) |
259 | FREE_THREAD_KEY; | |
260 | #endif | |
68dc0745 | 261 | break; |
0a753a76 | 262 | |
68dc0745 | 263 | /* The attached process creates a new thread. */ |
264 | case DLL_THREAD_ATTACH: | |
265 | break; | |
0a753a76 | 266 | |
68dc0745 | 267 | /* The thread of the attached process terminates. */ |
268 | case DLL_THREAD_DETACH: | |
269 | break; | |
0a753a76 | 270 | |
68dc0745 | 271 | default: |
272 | break; | |
273 | } | |
274 | return TRUE; | |
0a753a76 | 275 | } |
c43294b8 | 276 | |
7bd379e8 | 277 | |
9613994f | 278 | #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) |
c43294b8 AB |
279 | EXTERN_C PerlInterpreter * |
280 | perl_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 AB |
297 | return proto_perl; |
298 | ||
299 | } | |
300 | #endif |