support fetching current interpreter from TLS under useithreads
[perl.git] / win32 / perllib.c
1 /*
2  * "The Road goes ever on and on, down from the door where it began."
3  */
4
5
6 #include "EXTERN.h"
7 #include "perl.h"
8
9 #ifdef PERL_OBJECT
10 #define NO_XSLOCKS
11 #endif
12
13 #include "XSUB.h"
14
15 #ifdef PERL_IMPLICIT_SYS
16 #include "win32iop.h"
17 #include <fcntl.h>
18 #endif /* PERL_IMPLICIT_SYS */
19
20
21 /* Register any extra external extensions */
22 char *staticlinkmodules[] = {
23     "DynaLoader",
24     NULL,
25 };
26
27 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
28
29 static void
30 xs_init(pTHXo)
31 {
32     char *file = __FILE__;
33     dXSUB_SYS;
34     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
35 }
36
37 #ifdef PERL_IMPLICIT_SYS
38
39 #include "perlhost.h"
40
41 EXTERN_C void
42 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
43                    struct IPerlMemInfo* perlMemSharedInfo,
44                    struct IPerlMemInfo* perlMemParseInfo,
45                    struct IPerlEnvInfo* perlEnvInfo,
46                    struct IPerlStdIOInfo* perlStdIOInfo,
47                    struct IPerlLIOInfo* perlLIOInfo,
48                    struct IPerlDirInfo* perlDirInfo,
49                    struct IPerlSockInfo* perlSockInfo,
50                    struct IPerlProcInfo* perlProcInfo)
51 {
52     if (perlMemInfo) {
53         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
54         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
55     }
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) {
65         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
66         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
67     }
68     if (perlStdIOInfo) {
69         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
70         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
71     }
72     if (perlLIOInfo) {
73         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
74         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
75     }
76     if (perlDirInfo) {
77         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
78         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
79     }
80     if (perlSockInfo) {
81         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
82         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
83     }
84     if (perlProcInfo) {
85         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
86         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
87     }
88 }
89
90 EXTERN_C PerlInterpreter*
91 perl_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)
96 {
97     PerlInterpreter *my_perl = NULL;
98     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
99                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
100
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;
116         }
117     }
118     return my_perl;
119 }
120
121 EXTERN_C PerlInterpreter*
122 perl_alloc(void)
123 {
124     PerlInterpreter* my_perl = NULL;
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;
141         }
142     }
143     return my_perl;
144 }
145
146 #ifdef PERL_OBJECT
147
148 EXTERN_C void
149 perl_construct(PerlInterpreter* my_perl)
150 {
151     CPerlObj* pPerl = (CPerlObj*)my_perl;
152     try
153     {
154         Perl_construct();
155     }
156     catch(...)
157     {
158         win32_fprintf(stderr, "%s\n",
159                       "Error: Unable to construct data structures");
160         CPerlHost* pHost = (CPerlHost*)w32_internal_host;
161         Perl_free();
162         delete pHost;
163         PERL_SET_THX(NULL);
164     }
165 }
166
167 EXTERN_C void
168 perl_destruct(PerlInterpreter* my_perl)
169 {
170     CPerlObj* pPerl = (CPerlObj*)my_perl;
171 #ifdef DEBUGGING
172     Perl_destruct();
173 #else
174     try
175     {
176         Perl_destruct();
177     }
178     catch(...)
179     {
180     }
181 #endif
182 }
183
184 EXTERN_C void
185 perl_free(PerlInterpreter* my_perl)
186 {
187     CPerlObj* pPerl = (CPerlObj*)my_perl;
188 #ifdef DEBUGGING
189     CPerlHost* pHost = (CPerlHost*)w32_internal_host;
190     Perl_free();
191     delete pHost;
192 #else
193     try
194     {
195         CPerlHost* pHost = (CPerlHost*)w32_internal_host;
196         Perl_free();
197         delete pHost;
198     }
199     catch(...)
200     {
201     }
202 #endif
203     PERL_SET_THX(NULL);
204 }
205
206 EXTERN_C int
207 perl_run(PerlInterpreter* my_perl)
208 {
209     CPerlObj* pPerl = (CPerlObj*)my_perl;
210 #ifdef DEBUGGING
211     return Perl_run();
212 #else
213     int retVal;
214     try
215     {
216         retVal = Perl_run();
217     }
218     catch(...)
219     {
220         win32_fprintf(stderr, "Error: Runtime exception\n");
221         retVal = -1;
222     }
223     return retVal;
224 #endif
225 }
226
227 EXTERN_C int
228 perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
229 {
230     int retVal;
231     CPerlObj* pPerl = (CPerlObj*)my_perl;
232 #ifdef DEBUGGING
233     retVal = Perl_parse(xsinit, argc, argv, env);
234 #else
235     try
236     {
237         retVal = Perl_parse(xsinit, argc, argv, env);
238     }
239     catch(...)
240     {
241         win32_fprintf(stderr, "Error: Parse exception\n");
242         retVal = -1;
243     }
244 #endif
245     *win32_errno() = 0;
246     return retVal;
247 }
248
249 #undef PL_perl_destruct_level
250 #define PL_perl_destruct_level int dummy
251
252 #endif /* PERL_OBJECT */
253 #endif /* PERL_IMPLICIT_SYS */
254
255 EXTERN_C HANDLE w32_perldll_handle;
256
257 EXTERN_C DllExport int
258 RunPerl(int argc, char **argv, char **env)
259 {
260     int exitstatus;
261     PerlInterpreter *my_perl, *new_perl = NULL;
262     struct perl_thread *thr;
263
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
276 #ifdef PERL_GLOBAL_STRUCT
277 #define PERLVAR(var,type) /**/
278 #define PERLVARA(var,type) /**/
279 #define PERLVARI(var,type,init) PL_Vars.var = init;
280 #define PERLVARIC(var,type,init) PL_Vars.var = init;
281 #include "perlvars.h"
282 #undef PERLVAR
283 #undef PERLVARA
284 #undef PERLVARI
285 #undef PERLVARIC
286 #endif
287
288     PERL_SYS_INIT(&argc,&argv);
289
290     if (!(my_perl = perl_alloc()))
291         return (1);
292     perl_construct( my_perl );
293     PL_perl_destruct_level = 0;
294
295     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
296     if (!exitstatus) {
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
315         exitstatus = perl_run( new_perl );
316         PERL_SET_THX(my_perl);
317 #else
318         exitstatus = perl_run( my_perl );
319 #endif
320     }
321
322     perl_destruct( my_perl );
323     perl_free( my_perl );
324 #ifdef USE_ITHREADS
325     if (new_perl) {
326         PERL_SET_THX(new_perl);
327         perl_destruct(new_perl);
328         perl_free(new_perl);
329     }
330 #endif
331
332     PERL_SYS_TERM();
333
334     return (exitstatus);
335 }
336
337 BOOL APIENTRY
338 DllMain(HANDLE hModule,         /* DLL module handle */
339         DWORD fdwReason,        /* reason called */
340         LPVOID lpvReserved)     /* reserved */
341
342     switch (fdwReason) {
343         /* The DLL is attaching to a process due to process
344          * initialization or a call to LoadLibrary.
345          */
346     case DLL_PROCESS_ATTACH:
347 /* #define DEFAULT_BINMODE */
348 #ifdef DEFAULT_BINMODE
349         setmode( fileno( stdin  ), O_BINARY );
350         setmode( fileno( stdout ), O_BINARY );
351         setmode( fileno( stderr ), O_BINARY );
352         _fmode = O_BINARY;
353 #endif
354         DisableThreadLibraryCalls((HMODULE)hModule);
355         w32_perldll_handle = hModule;
356         break;
357
358         /* The DLL is detaching from a process due to
359          * process termination or call to FreeLibrary.
360          */
361     case DLL_PROCESS_DETACH:
362         break;
363
364         /* The attached process creates a new thread. */
365     case DLL_THREAD_ATTACH:
366         break;
367
368         /* The thread of the attached process terminates. */
369     case DLL_THREAD_DETACH:
370         break;
371
372     default:
373         break;
374     }
375     return TRUE;
376 }