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 | 7 | |
96e4d5b1 | 8 | #include "XSUB.h" |
0a753a76 | 9 | |
32e30700 | 10 | #ifdef PERL_IMPLICIT_SYS |
0cb96387 GS |
11 | #include "win32iop.h" |
12 | #include <fcntl.h> | |
7766f137 | 13 | #endif /* PERL_IMPLICIT_SYS */ |
0cb96387 | 14 | |
0cb96387 | 15 | |
7766f137 GS |
16 | /* Register any extra external extensions */ |
17 | char *staticlinkmodules[] = { | |
18 | "DynaLoader", | |
d2b25974 VK |
19 | /* other similar records will be included from "perllibst.h" */ |
20 | #ifdef WITH_STATIC | |
21 | #define STATIC1 | |
22 | #include "perllibst.h" | |
23 | #endif | |
7766f137 | 24 | NULL, |
0cb96387 GS |
25 | }; |
26 | ||
acfe0abc | 27 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); |
d2b25974 VK |
28 | /* other similar records will be included from "perllibst.h" */ |
29 | #ifdef WITH_STATIC | |
30 | #define STATIC2 | |
31 | #include "perllibst.h" | |
32 | #endif | |
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 VK |
40 | /* other similar records will be included from "perllibst.h" */ |
41 | #ifdef WITH_STATIC | |
42 | #define STATIC3 | |
43 | #include "perllibst.h" | |
44 | #endif | |
0cb96387 GS |
45 | } |
46 | ||
7766f137 | 47 | #ifdef PERL_IMPLICIT_SYS |
0cb96387 | 48 | |
7766f137 | 49 | #include "perlhost.h" |
0cb96387 | 50 | |
222c300a NIS |
51 | void |
52 | win32_checkTLS(PerlInterpreter *host_perl) | |
53 | { | |
54 | dTHX; | |
55 | if (host_perl != my_perl) { | |
56 | int *nowhere = NULL; | |
57 | *nowhere = 0; | |
58 | abort(); | |
59 | } | |
60 | } | |
61 | ||
32e30700 GS |
62 | EXTERN_C void |
63 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, | |
7766f137 GS |
64 | struct IPerlMemInfo* perlMemSharedInfo, |
65 | struct IPerlMemInfo* perlMemParseInfo, | |
32e30700 GS |
66 | struct IPerlEnvInfo* perlEnvInfo, |
67 | struct IPerlStdIOInfo* perlStdIOInfo, | |
68 | struct IPerlLIOInfo* perlLIOInfo, | |
69 | struct IPerlDirInfo* perlDirInfo, | |
70 | struct IPerlSockInfo* perlSockInfo, | |
71 | struct IPerlProcInfo* perlProcInfo) | |
0cb96387 | 72 | { |
7766f137 | 73 | if (perlMemInfo) { |
0cb96387 GS |
74 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
75 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
76 | } | |
7766f137 GS |
77 | if (perlMemSharedInfo) { |
78 | Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); | |
79 | perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
80 | } | |
81 | if (perlMemParseInfo) { | |
82 | Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); | |
83 | perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); | |
84 | } | |
85 | if (perlEnvInfo) { | |
0cb96387 GS |
86 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
87 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); | |
88 | } | |
7766f137 | 89 | if (perlStdIOInfo) { |
0cb96387 GS |
90 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
91 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); | |
92 | } | |
7766f137 | 93 | if (perlLIOInfo) { |
0cb96387 GS |
94 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
95 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); | |
96 | } | |
7766f137 | 97 | if (perlDirInfo) { |
0cb96387 GS |
98 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
99 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); | |
100 | } | |
7766f137 | 101 | if (perlSockInfo) { |
0cb96387 GS |
102 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
103 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); | |
104 | } | |
7766f137 | 105 | if (perlProcInfo) { |
0cb96387 GS |
106 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
107 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); | |
108 | } | |
109 | } | |
110 | ||
7766f137 GS |
111 | EXTERN_C PerlInterpreter* |
112 | perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, | |
113 | struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, | |
114 | struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, | |
115 | struct IPerlDir** ppDir, struct IPerlSock** ppSock, | |
116 | struct IPerlProc** ppProc) | |
0cb96387 | 117 | { |
7766f137 | 118 | PerlInterpreter *my_perl = NULL; |
8a85dc4e GS |
119 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
120 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); | |
7766f137 | 121 | |
8a85dc4e GS |
122 | if (pHost) { |
123 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, | |
124 | pHost->m_pHostperlMemShared, | |
125 | pHost->m_pHostperlMemParse, | |
126 | pHost->m_pHostperlEnv, | |
127 | pHost->m_pHostperlStdIO, | |
128 | pHost->m_pHostperlLIO, | |
129 | pHost->m_pHostperlDir, | |
130 | pHost->m_pHostperlSock, | |
131 | pHost->m_pHostperlProc); | |
132 | if (my_perl) { | |
8a85dc4e | 133 | w32_internal_host = pHost; |
222c300a | 134 | pHost->host_perl = my_perl; |
7766f137 | 135 | } |
0cb96387 | 136 | } |
7766f137 | 137 | return my_perl; |
0cb96387 GS |
138 | } |
139 | ||
7766f137 GS |
140 | EXTERN_C PerlInterpreter* |
141 | perl_alloc(void) | |
0cb96387 | 142 | { |
7766f137 | 143 | PerlInterpreter* my_perl = NULL; |
8a85dc4e GS |
144 | CPerlHost* pHost = new CPerlHost(); |
145 | if (pHost) { | |
146 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, | |
147 | pHost->m_pHostperlMemShared, | |
148 | pHost->m_pHostperlMemParse, | |
149 | pHost->m_pHostperlEnv, | |
150 | pHost->m_pHostperlStdIO, | |
151 | pHost->m_pHostperlLIO, | |
152 | pHost->m_pHostperlDir, | |
153 | pHost->m_pHostperlSock, | |
154 | pHost->m_pHostperlProc); | |
155 | if (my_perl) { | |
8a85dc4e | 156 | w32_internal_host = pHost; |
222c300a | 157 | pHost->host_perl = my_perl; |
7766f137 | 158 | } |
0cb96387 | 159 | } |
7766f137 | 160 | return my_perl; |
0cb96387 GS |
161 | } |
162 | ||
1c0ca838 GS |
163 | EXTERN_C void |
164 | win32_delete_internal_host(void *h) | |
165 | { | |
166 | CPerlHost *host = (CPerlHost*)h; | |
167 | delete host; | |
168 | } | |
169 | ||
32e30700 GS |
170 | #endif /* PERL_IMPLICIT_SYS */ |
171 | ||
7766f137 GS |
172 | EXTERN_C HANDLE w32_perldll_handle; |
173 | ||
c5be433b | 174 | EXTERN_C DllExport int |
0cb96387 | 175 | RunPerl(int argc, char **argv, char **env) |
0a753a76 | 176 | { |
68dc0745 | 177 | int exitstatus; |
ed094faf | 178 | PerlInterpreter *my_perl, *new_perl = NULL; |
0a753a76 | 179 | |
0cb96387 GS |
180 | #ifndef __BORLANDC__ |
181 | /* XXX this _may_ be a problem on some compilers (e.g. Borland) that | |
182 | * want to free() argv after main() returns. As luck would have it, | |
183 | * Borland's CRT does the right thing to argv[0] already. */ | |
184 | char szModuleName[MAX_PATH]; | |
0cb96387 GS |
185 | |
186 | GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); | |
187 | (void)win32_longpath(szModuleName); | |
188 | argv[0] = szModuleName; | |
189 | #endif | |
190 | ||
22239a37 NIS |
191 | #ifdef PERL_GLOBAL_STRUCT |
192 | #define PERLVAR(var,type) /**/ | |
51371543 | 193 | #define PERLVARA(var,type) /**/ |
533c011a NIS |
194 | #define PERLVARI(var,type,init) PL_Vars.var = init; |
195 | #define PERLVARIC(var,type,init) PL_Vars.var = init; | |
22239a37 NIS |
196 | #include "perlvars.h" |
197 | #undef PERLVAR | |
51371543 | 198 | #undef PERLVARA |
22239a37 | 199 | #undef PERLVARI |
3fe35a81 | 200 | #undef PERLVARIC |
22239a37 NIS |
201 | #endif |
202 | ||
0a753a76 | 203 | PERL_SYS_INIT(&argc,&argv); |
204 | ||
68dc0745 | 205 | if (!(my_perl = perl_alloc())) |
206 | return (1); | |
642f9deb | 207 | perl_construct(my_perl); |
b28d0864 | 208 | PL_perl_destruct_level = 0; |
0a753a76 | 209 | |
4f63d024 | 210 | exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); |
0a753a76 | 211 | if (!exitstatus) { |
7766f137 | 212 | #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ |
7766f137 | 213 | new_perl = perl_clone(my_perl, 1); |
642f9deb | 214 | exitstatus = perl_run(new_perl); |
ba869deb | 215 | PERL_SET_THX(my_perl); |
d18c6117 | 216 | #else |
642f9deb | 217 | exitstatus = perl_run(my_perl); |
d18c6117 | 218 | #endif |
0a753a76 | 219 | } |
220 | ||
642f9deb GS |
221 | perl_destruct(my_perl); |
222 | perl_free(my_perl); | |
ed094faf GS |
223 | #ifdef USE_ITHREADS |
224 | if (new_perl) { | |
ba869deb | 225 | PERL_SET_THX(new_perl); |
ed094faf GS |
226 | perl_destruct(new_perl); |
227 | perl_free(new_perl); | |
228 | } | |
229 | #endif | |
0a753a76 | 230 | |
231 | PERL_SYS_TERM(); | |
232 | ||
68dc0745 | 233 | return (exitstatus); |
0a753a76 | 234 | } |
235 | ||
2fa86c13 GS |
236 | EXTERN_C void |
237 | set_w32_module_name(void); | |
238 | ||
b73db59c GS |
239 | EXTERN_C void |
240 | EndSockets(void); | |
241 | ||
242 | ||
f8fb7c90 GS |
243 | #ifdef __MINGW32__ |
244 | EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ | |
245 | #endif | |
68dc0745 | 246 | BOOL APIENTRY |
247 | DllMain(HANDLE hModule, /* DLL module handle */ | |
248 | DWORD fdwReason, /* reason called */ | |
249 | LPVOID lpvReserved) /* reserved */ | |
0a753a76 | 250 | { |
68dc0745 | 251 | switch (fdwReason) { |
252 | /* The DLL is attaching to a process due to process | |
253 | * initialization or a call to LoadLibrary. | |
254 | */ | |
255 | case DLL_PROCESS_ATTACH: | |
256 | /* #define DEFAULT_BINMODE */ | |
0a753a76 | 257 | #ifdef DEFAULT_BINMODE |
3e3baf6d TB |
258 | setmode( fileno( stdin ), O_BINARY ); |
259 | setmode( fileno( stdout ), O_BINARY ); | |
260 | setmode( fileno( stderr ), O_BINARY ); | |
261 | _fmode = O_BINARY; | |
0a753a76 | 262 | #endif |
5db10396 | 263 | DisableThreadLibraryCalls((HMODULE)hModule); |
2d7a9237 | 264 | w32_perldll_handle = hModule; |
2fa86c13 | 265 | set_w32_module_name(); |
68dc0745 | 266 | break; |
0a753a76 | 267 | |
68dc0745 | 268 | /* The DLL is detaching from a process due to |
269 | * process termination or call to FreeLibrary. | |
270 | */ | |
271 | case DLL_PROCESS_DETACH: | |
ce3e5b80 NIS |
272 | /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() |
273 | anything here had better be harmless if: | |
274 | A. Not called at all. | |
275 | B. Called after memory allocation for Heap has been forcibly removed by OS. | |
276 | PerlIO_cleanup() was done here but fails (B). | |
277 | */ | |
b73db59c | 278 | EndSockets(); |
3db8f154 | 279 | #if defined(USE_ITHREADS) |
e1b5da64 GS |
280 | if (PL_curinterp) |
281 | FREE_THREAD_KEY; | |
282 | #endif | |
68dc0745 | 283 | break; |
0a753a76 | 284 | |
68dc0745 | 285 | /* The attached process creates a new thread. */ |
286 | case DLL_THREAD_ATTACH: | |
287 | break; | |
0a753a76 | 288 | |
68dc0745 | 289 | /* The thread of the attached process terminates. */ |
290 | case DLL_THREAD_DETACH: | |
291 | break; | |
0a753a76 | 292 | |
68dc0745 | 293 | default: |
294 | break; | |
295 | } | |
296 | return TRUE; | |
0a753a76 | 297 | } |
c43294b8 | 298 | |
9613994f | 299 | #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) |
c43294b8 AB |
300 | EXTERN_C PerlInterpreter * |
301 | perl_clone_host(PerlInterpreter* proto_perl, UV flags) { | |
acfe0abc | 302 | dTHX; |
c43294b8 AB |
303 | CPerlHost *h; |
304 | h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); | |
305 | proto_perl = perl_clone_using(proto_perl, flags, | |
306 | h->m_pHostperlMem, | |
307 | h->m_pHostperlMemShared, | |
308 | h->m_pHostperlMemParse, | |
309 | h->m_pHostperlEnv, | |
310 | h->m_pHostperlStdIO, | |
311 | h->m_pHostperlLIO, | |
312 | h->m_pHostperlDir, | |
313 | h->m_pHostperlSock, | |
314 | h->m_pHostperlProc | |
315 | ); | |
316 | proto_perl->Isys_intern.internal_host = h; | |
222c300a | 317 | h->host_perl = proto_perl; |
c43294b8 AB |
318 | return proto_perl; |
319 | ||
320 | } | |
321 | #endif |