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