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