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