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