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