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