Commit | Line | Data |
0a753a76 |
1 | /* |
4ac71550 |
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 |
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 */ |
21 | char *staticlinkmodules[] = { |
22 | "DynaLoader", |
d2b25974 |
23 | /* other similar records will be included from "perllibst.h" */ |
d2b25974 |
24 | #define STATIC1 |
25 | #include "perllibst.h" |
7766f137 |
26 | NULL, |
0cb96387 |
27 | }; |
28 | |
acfe0abc |
29 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); |
d2b25974 |
30 | /* other similar records will be included from "perllibst.h" */ |
d2b25974 |
31 | #define STATIC2 |
32 | #include "perllibst.h" |
0cb96387 |
33 | |
7766f137 |
34 | static void |
acfe0abc |
35 | xs_init(pTHX) |
0cb96387 |
36 | { |
7766f137 |
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 |
41 | #define STATIC3 |
42 | #include "perllibst.h" |
0cb96387 |
43 | } |
44 | |
7766f137 |
45 | #ifdef PERL_IMPLICIT_SYS |
0cb96387 |
46 | |
7bd379e8 |
47 | /* WINCE: include replaced by: |
48 | extern "C" void win32_checkTLS(PerlInterpreter *host_perl); |
49 | */ |
7766f137 |
50 | #include "perlhost.h" |
0cb96387 |
51 | |
222c300a |
52 | void |
53 | win32_checkTLS(PerlInterpreter *host_perl) |
54 | { |
55 | dTHX; |
56 | if (host_perl != my_perl) { |
57 | int *nowhere = NULL; |
45496817 |
58 | #ifdef UNDER_CE |
7bd379e8 |
59 | printf(" ... bad in win32_checkTLS\n"); |
60 | printf(" %08X ne %08X\n",host_perl,my_perl); |
61 | #endif |
222c300a |
62 | abort(); |
63 | } |
64 | } |
65 | |
7bd379e8 |
66 | #ifdef UNDER_CE |
67 | int GetLogicalDrives() { |
68 | return 0; /* no logical drives on CE */ |
69 | } |
70 | int GetLogicalDriveStrings(int size, char addr[]) { |
71 | return 0; /* no logical drives on CE */ |
72 | } |
73 | /* TBD */ |
74 | DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) { |
75 | return 0; |
76 | } |
77 | /* TBD */ |
78 | DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) { |
79 | return 0; |
80 | } |
81 | /* TBD */ |
82 | DWORD SetCurrentDirectoryA(LPSTR pPath) { |
83 | return 0; |
84 | } |
85 | /* TBD */ |
86 | DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) { |
87 | return 0; |
88 | } |
89 | int xcesetuid(uid_t id){return 0;} |
90 | int xceseteuid(uid_t id){ return 0;} |
91 | int xcegetuid() {return 0;} |
92 | int xcegeteuid(){ return 0;} |
93 | #endif |
94 | |
95 | /* WINCE??: include "perlhost.h" */ |
96 | |
32e30700 |
97 | EXTERN_C void |
98 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, |
7766f137 |
99 | struct IPerlMemInfo* perlMemSharedInfo, |
100 | struct IPerlMemInfo* perlMemParseInfo, |
32e30700 |
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 |
109 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
110 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
111 | } |
7766f137 |
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 |
121 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
122 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); |
123 | } |
7766f137 |
124 | if (perlStdIOInfo) { |
0cb96387 |
125 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
126 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); |
127 | } |
7766f137 |
128 | if (perlLIOInfo) { |
0cb96387 |
129 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
130 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); |
131 | } |
7766f137 |
132 | if (perlDirInfo) { |
0cb96387 |
133 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
134 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); |
135 | } |
7766f137 |
136 | if (perlSockInfo) { |
0cb96387 |
137 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
138 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); |
139 | } |
7766f137 |
140 | if (perlProcInfo) { |
0cb96387 |
141 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
142 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); |
143 | } |
144 | } |
145 | |
7766f137 |
146 | EXTERN_C PerlInterpreter* |
147 | perl_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 |
154 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
155 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); |
7766f137 |
156 | |
8a85dc4e |
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 |
173 | } |
174 | |
7766f137 |
175 | EXTERN_C PerlInterpreter* |
176 | perl_alloc(void) |
0cb96387 |
177 | { |
7766f137 |
178 | PerlInterpreter* my_perl = NULL; |
8a85dc4e |
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 |
196 | } |
197 | |
1c0ca838 |
198 | EXTERN_C void |
199 | win32_delete_internal_host(void *h) |
200 | { |
201 | CPerlHost *host = (CPerlHost*)h; |
202 | delete host; |
203 | } |
204 | |
32e30700 |
205 | #endif /* PERL_IMPLICIT_SYS */ |
206 | |
7766f137 |
207 | EXTERN_C HANDLE w32_perldll_handle; |
208 | |
c5be433b |
209 | EXTERN_C DllExport int |
0cb96387 |
210 | RunPerl(int argc, char **argv, char **env) |
0a753a76 |
211 | { |
68dc0745 |
212 | int exitstatus; |
ed094faf |
213 | PerlInterpreter *my_perl, *new_perl = NULL; |
aa2b96ec |
214 | OSVERSIONINFO osver; |
0cb96387 |
215 | char szModuleName[MAX_PATH]; |
aa2b96ec |
216 | char *arg0 = argv[0]; |
217 | char *ansi = NULL; |
dc0472e9 |
218 | bool use_environ = (env == environ); |
0cb96387 |
219 | |
aa2b96ec |
220 | osver.dwOSVersionInfoSize = sizeof(osver); |
221 | GetVersionEx(&osver); |
222 | |
3839a0fa |
223 | if (osver.dwMajorVersion > 4) { |
aa2b96ec |
224 | WCHAR widename[MAX_PATH]; |
225 | GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR)); |
226 | argv[0] = ansi = win32_ansipath(widename); |
227 | } |
228 | else { |
229 | Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); |
230 | (void)win32_longpath(szModuleName); |
231 | argv[0] = szModuleName; |
232 | } |
0cb96387 |
233 | |
22239a37 |
234 | #ifdef PERL_GLOBAL_STRUCT |
235 | #define PERLVAR(var,type) /**/ |
51371543 |
236 | #define PERLVARA(var,type) /**/ |
533c011a |
237 | #define PERLVARI(var,type,init) PL_Vars.var = init; |
238 | #define PERLVARIC(var,type,init) PL_Vars.var = init; |
22239a37 |
239 | #include "perlvars.h" |
240 | #undef PERLVAR |
51371543 |
241 | #undef PERLVARA |
22239a37 |
242 | #undef PERLVARI |
3fe35a81 |
243 | #undef PERLVARIC |
22239a37 |
244 | #endif |
245 | |
0a753a76 |
246 | PERL_SYS_INIT(&argc,&argv); |
247 | |
68dc0745 |
248 | if (!(my_perl = perl_alloc())) |
249 | return (1); |
642f9deb |
250 | perl_construct(my_perl); |
b28d0864 |
251 | PL_perl_destruct_level = 0; |
0a753a76 |
252 | |
dc0472e9 |
253 | /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path(). |
254 | * This may reallocate the RTL environment block. Therefore we need |
255 | * to make sure that `env` continues to have the same value as `environ` |
256 | * if we have been called this way. If we have been called with any |
257 | * other value for `env` then all environment munging by PERL_SYS_INIT() |
258 | * will be lost again. |
259 | */ |
260 | if (use_environ) |
261 | env = environ; |
262 | |
4f63d024 |
263 | exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); |
0a753a76 |
264 | if (!exitstatus) { |
7766f137 |
265 | #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ |
7766f137 |
266 | new_perl = perl_clone(my_perl, 1); |
642f9deb |
267 | exitstatus = perl_run(new_perl); |
ba869deb |
268 | PERL_SET_THX(my_perl); |
d18c6117 |
269 | #else |
642f9deb |
270 | exitstatus = perl_run(my_perl); |
d18c6117 |
271 | #endif |
0a753a76 |
272 | } |
c254be07 |
273 | |
642f9deb |
274 | perl_destruct(my_perl); |
432ce874 |
275 | perl_free(my_perl); |
432ce874 |
276 | #ifdef USE_ITHREADS |
277 | if (new_perl) { |
278 | PERL_SET_THX(new_perl); |
c254be07 |
279 | perl_destruct(new_perl); |
ed094faf |
280 | perl_free(new_perl); |
281 | } |
282 | #endif |
0a753a76 |
283 | |
aa2b96ec |
284 | /* At least the Borland RTL wants to free argv[] after main() returns. */ |
285 | argv[0] = arg0; |
286 | if (ansi) |
287 | win32_free(ansi); |
288 | |
c254be07 |
289 | PERL_SYS_TERM(); |
0a753a76 |
290 | |
68dc0745 |
291 | return (exitstatus); |
0a753a76 |
292 | } |
293 | |
2fa86c13 |
294 | EXTERN_C void |
295 | set_w32_module_name(void); |
296 | |
b73db59c |
297 | EXTERN_C void |
298 | EndSockets(void); |
299 | |
300 | |
f8fb7c90 |
301 | #ifdef __MINGW32__ |
302 | EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ |
303 | #endif |
68dc0745 |
304 | BOOL APIENTRY |
305 | DllMain(HANDLE hModule, /* DLL module handle */ |
306 | DWORD fdwReason, /* reason called */ |
307 | LPVOID lpvReserved) /* reserved */ |
0a753a76 |
308 | { |
68dc0745 |
309 | switch (fdwReason) { |
310 | /* The DLL is attaching to a process due to process |
311 | * initialization or a call to LoadLibrary. |
312 | */ |
313 | case DLL_PROCESS_ATTACH: |
314 | /* #define DEFAULT_BINMODE */ |
0a753a76 |
315 | #ifdef DEFAULT_BINMODE |
3e3baf6d |
316 | setmode( fileno( stdin ), O_BINARY ); |
317 | setmode( fileno( stdout ), O_BINARY ); |
318 | setmode( fileno( stderr ), O_BINARY ); |
319 | _fmode = O_BINARY; |
0a753a76 |
320 | #endif |
7bd379e8 |
321 | |
322 | #ifndef UNDER_CE |
5db10396 |
323 | DisableThreadLibraryCalls((HMODULE)hModule); |
7bd379e8 |
324 | #endif |
325 | |
2d7a9237 |
326 | w32_perldll_handle = hModule; |
2fa86c13 |
327 | set_w32_module_name(); |
68dc0745 |
328 | break; |
0a753a76 |
329 | |
68dc0745 |
330 | /* The DLL is detaching from a process due to |
331 | * process termination or call to FreeLibrary. |
332 | */ |
333 | case DLL_PROCESS_DETACH: |
ce3e5b80 |
334 | /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() |
335 | anything here had better be harmless if: |
336 | A. Not called at all. |
337 | B. Called after memory allocation for Heap has been forcibly removed by OS. |
338 | PerlIO_cleanup() was done here but fails (B). |
339 | */ |
b73db59c |
340 | EndSockets(); |
3db8f154 |
341 | #if defined(USE_ITHREADS) |
e1b5da64 |
342 | if (PL_curinterp) |
343 | FREE_THREAD_KEY; |
344 | #endif |
68dc0745 |
345 | break; |
0a753a76 |
346 | |
68dc0745 |
347 | /* The attached process creates a new thread. */ |
348 | case DLL_THREAD_ATTACH: |
349 | break; |
0a753a76 |
350 | |
68dc0745 |
351 | /* The thread of the attached process terminates. */ |
352 | case DLL_THREAD_DETACH: |
353 | break; |
0a753a76 |
354 | |
68dc0745 |
355 | default: |
356 | break; |
357 | } |
358 | return TRUE; |
0a753a76 |
359 | } |
c43294b8 |
360 | |
7bd379e8 |
361 | |
9613994f |
362 | #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) |
c43294b8 |
363 | EXTERN_C PerlInterpreter * |
364 | perl_clone_host(PerlInterpreter* proto_perl, UV flags) { |
acfe0abc |
365 | dTHX; |
c43294b8 |
366 | CPerlHost *h; |
367 | h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); |
368 | proto_perl = perl_clone_using(proto_perl, flags, |
369 | h->m_pHostperlMem, |
370 | h->m_pHostperlMemShared, |
371 | h->m_pHostperlMemParse, |
372 | h->m_pHostperlEnv, |
373 | h->m_pHostperlStdIO, |
374 | h->m_pHostperlLIO, |
375 | h->m_pHostperlDir, |
376 | h->m_pHostperlSock, |
377 | h->m_pHostperlProc |
378 | ); |
379 | proto_perl->Isys_intern.internal_host = h; |
222c300a |
380 | h->host_perl = proto_perl; |
c43294b8 |
381 | return proto_perl; |
382 | |
383 | } |
384 | #endif |