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