Regenerate META.yml
[p5sagit/p5-mst-13.2.git] / win32 / perllib.c
CommitLineData
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 */
17char *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 25EXTERN_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 30static void
acfe0abc 31xs_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
7bd379e8 43/* WINCE: include replaced by:
44extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
45*/
7766f137 46#include "perlhost.h"
0cb96387 47
222c300a 48void
49win32_checkTLS(PerlInterpreter *host_perl)
50{
51 dTHX;
52 if (host_perl != my_perl) {
53 int *nowhere = NULL;
45496817 54#ifdef UNDER_CE
7bd379e8 55 printf(" ... bad in win32_checkTLS\n");
56 printf(" %08X ne %08X\n",host_perl,my_perl);
57#endif
222c300a 58 abort();
59 }
60}
61
7bd379e8 62#ifdef UNDER_CE
63int GetLogicalDrives() {
64 return 0; /* no logical drives on CE */
65}
66int GetLogicalDriveStrings(int size, char addr[]) {
67 return 0; /* no logical drives on CE */
68}
69/* TBD */
70DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) {
71 return 0;
72}
73/* TBD */
74DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) {
75 return 0;
76}
77/* TBD */
78DWORD SetCurrentDirectoryA(LPSTR pPath) {
79 return 0;
80}
81/* TBD */
82DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
83 return 0;
84}
85int xcesetuid(uid_t id){return 0;}
86int xceseteuid(uid_t id){ return 0;}
87int xcegetuid() {return 0;}
88int xcegeteuid(){ return 0;}
89#endif
90
91/* WINCE??: include "perlhost.h" */
92
32e30700 93EXTERN_C void
94perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
7766f137 95 struct IPerlMemInfo* perlMemSharedInfo,
96 struct IPerlMemInfo* perlMemParseInfo,
32e30700 97 struct IPerlEnvInfo* perlEnvInfo,
98 struct IPerlStdIOInfo* perlStdIOInfo,
99 struct IPerlLIOInfo* perlLIOInfo,
100 struct IPerlDirInfo* perlDirInfo,
101 struct IPerlSockInfo* perlSockInfo,
102 struct IPerlProcInfo* perlProcInfo)
0cb96387 103{
7766f137 104 if (perlMemInfo) {
0cb96387 105 Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
106 perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
107 }
7766f137 108 if (perlMemSharedInfo) {
109 Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
110 perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
111 }
112 if (perlMemParseInfo) {
113 Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
114 perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
115 }
116 if (perlEnvInfo) {
0cb96387 117 Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
118 perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
119 }
7766f137 120 if (perlStdIOInfo) {
0cb96387 121 Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
122 perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
123 }
7766f137 124 if (perlLIOInfo) {
0cb96387 125 Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
126 perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
127 }
7766f137 128 if (perlDirInfo) {
0cb96387 129 Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
130 perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
131 }
7766f137 132 if (perlSockInfo) {
0cb96387 133 Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
134 perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
135 }
7766f137 136 if (perlProcInfo) {
0cb96387 137 Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
138 perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
139 }
140}
141
7766f137 142EXTERN_C PerlInterpreter*
143perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
144 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
145 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
146 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
147 struct IPerlProc** ppProc)
0cb96387 148{
7766f137 149 PerlInterpreter *my_perl = NULL;
8a85dc4e 150 CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
151 ppStdIO, ppLIO, ppDir, ppSock, ppProc);
7766f137 152
8a85dc4e 153 if (pHost) {
154 my_perl = perl_alloc_using(pHost->m_pHostperlMem,
155 pHost->m_pHostperlMemShared,
156 pHost->m_pHostperlMemParse,
157 pHost->m_pHostperlEnv,
158 pHost->m_pHostperlStdIO,
159 pHost->m_pHostperlLIO,
160 pHost->m_pHostperlDir,
161 pHost->m_pHostperlSock,
162 pHost->m_pHostperlProc);
163 if (my_perl) {
8a85dc4e 164 w32_internal_host = pHost;
222c300a 165 pHost->host_perl = my_perl;
7766f137 166 }
0cb96387 167 }
7766f137 168 return my_perl;
0cb96387 169}
170
7766f137 171EXTERN_C PerlInterpreter*
172perl_alloc(void)
0cb96387 173{
7766f137 174 PerlInterpreter* my_perl = NULL;
8a85dc4e 175 CPerlHost* pHost = new CPerlHost();
176 if (pHost) {
177 my_perl = perl_alloc_using(pHost->m_pHostperlMem,
178 pHost->m_pHostperlMemShared,
179 pHost->m_pHostperlMemParse,
180 pHost->m_pHostperlEnv,
181 pHost->m_pHostperlStdIO,
182 pHost->m_pHostperlLIO,
183 pHost->m_pHostperlDir,
184 pHost->m_pHostperlSock,
185 pHost->m_pHostperlProc);
186 if (my_perl) {
8a85dc4e 187 w32_internal_host = pHost;
222c300a 188 pHost->host_perl = my_perl;
7766f137 189 }
0cb96387 190 }
7766f137 191 return my_perl;
0cb96387 192}
193
1c0ca838 194EXTERN_C void
195win32_delete_internal_host(void *h)
196{
197 CPerlHost *host = (CPerlHost*)h;
198 delete host;
199}
200
32e30700 201#endif /* PERL_IMPLICIT_SYS */
202
7766f137 203EXTERN_C HANDLE w32_perldll_handle;
204
c5be433b 205EXTERN_C DllExport int
0cb96387 206RunPerl(int argc, char **argv, char **env)
0a753a76 207{
68dc0745 208 int exitstatus;
ed094faf 209 PerlInterpreter *my_perl, *new_perl = NULL;
aa2b96ec 210 OSVERSIONINFO osver;
0cb96387 211 char szModuleName[MAX_PATH];
aa2b96ec 212 char *arg0 = argv[0];
213 char *ansi = NULL;
dc0472e9 214 bool use_environ = (env == environ);
0cb96387 215
aa2b96ec 216 osver.dwOSVersionInfoSize = sizeof(osver);
217 GetVersionEx(&osver);
218
3839a0fa 219 if (osver.dwMajorVersion > 4) {
aa2b96ec 220 WCHAR widename[MAX_PATH];
221 GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
222 argv[0] = ansi = win32_ansipath(widename);
223 }
224 else {
225 Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
226 (void)win32_longpath(szModuleName);
227 argv[0] = szModuleName;
228 }
0cb96387 229
22239a37 230#ifdef PERL_GLOBAL_STRUCT
231#define PERLVAR(var,type) /**/
51371543 232#define PERLVARA(var,type) /**/
533c011a 233#define PERLVARI(var,type,init) PL_Vars.var = init;
234#define PERLVARIC(var,type,init) PL_Vars.var = init;
22239a37 235#include "perlvars.h"
236#undef PERLVAR
51371543 237#undef PERLVARA
22239a37 238#undef PERLVARI
3fe35a81 239#undef PERLVARIC
22239a37 240#endif
241
0a753a76 242 PERL_SYS_INIT(&argc,&argv);
243
68dc0745 244 if (!(my_perl = perl_alloc()))
245 return (1);
642f9deb 246 perl_construct(my_perl);
b28d0864 247 PL_perl_destruct_level = 0;
0a753a76 248
dc0472e9 249 /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
250 * This may reallocate the RTL environment block. Therefore we need
251 * to make sure that `env` continues to have the same value as `environ`
252 * if we have been called this way. If we have been called with any
253 * other value for `env` then all environment munging by PERL_SYS_INIT()
254 * will be lost again.
255 */
256 if (use_environ)
257 env = environ;
258
4f63d024 259 exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
0a753a76 260 if (!exitstatus) {
7766f137 261#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
7766f137 262 new_perl = perl_clone(my_perl, 1);
642f9deb 263 exitstatus = perl_run(new_perl);
ba869deb 264 PERL_SET_THX(my_perl);
d18c6117 265#else
642f9deb 266 exitstatus = perl_run(my_perl);
d18c6117 267#endif
0a753a76 268 }
c254be07 269
642f9deb 270 perl_destruct(my_perl);
432ce874 271 perl_free(my_perl);
432ce874 272#ifdef USE_ITHREADS
273 if (new_perl) {
274 PERL_SET_THX(new_perl);
c254be07 275 perl_destruct(new_perl);
ed094faf 276 perl_free(new_perl);
277 }
278#endif
0a753a76 279
aa2b96ec 280 /* At least the Borland RTL wants to free argv[] after main() returns. */
281 argv[0] = arg0;
282 if (ansi)
283 win32_free(ansi);
284
c254be07 285 PERL_SYS_TERM();
0a753a76 286
68dc0745 287 return (exitstatus);
0a753a76 288}
289
2fa86c13 290EXTERN_C void
291set_w32_module_name(void);
292
b73db59c 293EXTERN_C void
294EndSockets(void);
295
296
f8fb7c90 297#ifdef __MINGW32__
298EXTERN_C /* GCC in C++ mode mangles the name, otherwise */
299#endif
68dc0745 300BOOL APIENTRY
301DllMain(HANDLE hModule, /* DLL module handle */
302 DWORD fdwReason, /* reason called */
303 LPVOID lpvReserved) /* reserved */
0a753a76 304{
68dc0745 305 switch (fdwReason) {
306 /* The DLL is attaching to a process due to process
307 * initialization or a call to LoadLibrary.
308 */
309 case DLL_PROCESS_ATTACH:
310/* #define DEFAULT_BINMODE */
0a753a76 311#ifdef DEFAULT_BINMODE
3e3baf6d 312 setmode( fileno( stdin ), O_BINARY );
313 setmode( fileno( stdout ), O_BINARY );
314 setmode( fileno( stderr ), O_BINARY );
315 _fmode = O_BINARY;
0a753a76 316#endif
7bd379e8 317
318#ifndef UNDER_CE
5db10396 319 DisableThreadLibraryCalls((HMODULE)hModule);
7bd379e8 320#endif
321
2d7a9237 322 w32_perldll_handle = hModule;
2fa86c13 323 set_w32_module_name();
68dc0745 324 break;
0a753a76 325
68dc0745 326 /* The DLL is detaching from a process due to
327 * process termination or call to FreeLibrary.
328 */
329 case DLL_PROCESS_DETACH:
ce3e5b80 330 /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
331 anything here had better be harmless if:
332 A. Not called at all.
333 B. Called after memory allocation for Heap has been forcibly removed by OS.
334 PerlIO_cleanup() was done here but fails (B).
335 */
b73db59c 336 EndSockets();
3db8f154 337#if defined(USE_ITHREADS)
e1b5da64 338 if (PL_curinterp)
339 FREE_THREAD_KEY;
340#endif
68dc0745 341 break;
0a753a76 342
68dc0745 343 /* The attached process creates a new thread. */
344 case DLL_THREAD_ATTACH:
345 break;
0a753a76 346
68dc0745 347 /* The thread of the attached process terminates. */
348 case DLL_THREAD_DETACH:
349 break;
0a753a76 350
68dc0745 351 default:
352 break;
353 }
354 return TRUE;
0a753a76 355}
c43294b8 356
7bd379e8 357
9613994f 358#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
c43294b8 359EXTERN_C PerlInterpreter *
360perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
acfe0abc 361 dTHX;
c43294b8 362 CPerlHost *h;
363 h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
364 proto_perl = perl_clone_using(proto_perl, flags,
365 h->m_pHostperlMem,
366 h->m_pHostperlMemShared,
367 h->m_pHostperlMemParse,
368 h->m_pHostperlEnv,
369 h->m_pHostperlStdIO,
370 h->m_pHostperlLIO,
371 h->m_pHostperlDir,
372 h->m_pHostperlSock,
373 h->m_pHostperlProc
374 );
375 proto_perl->Isys_intern.internal_host = h;
222c300a 376 h->host_perl = proto_perl;
c43294b8 377 return proto_perl;
378
379}
380#endif