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