windows build fixups from uniform DLL name change to perl56.dll
[p5sagit/p5-mst-13.2.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         SetPerlInterpreter(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     SetPerlInterpreter(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 static DWORD g_TlsAllocIndex;
258
259 EXTERN_C DllExport bool
260 SetPerlInterpreter(void *interp)
261 {
262     return TlsSetValue(g_TlsAllocIndex, interp);
263 }
264
265 EXTERN_C DllExport void*
266 GetPerlInterpreter(void)
267 {
268     return TlsGetValue(g_TlsAllocIndex);
269 }
270
271 EXTERN_C DllExport int
272 RunPerl(int argc, char **argv, char **env)
273 {
274     int exitstatus;
275     PerlInterpreter *my_perl, *new_perl = NULL;
276     struct perl_thread *thr;
277
278 #ifndef __BORLANDC__
279     /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
280      * want to free() argv after main() returns.  As luck would have it,
281      * Borland's CRT does the right thing to argv[0] already. */
282     char szModuleName[MAX_PATH];
283     char *ptr;
284
285     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
286     (void)win32_longpath(szModuleName);
287     argv[0] = szModuleName;
288 #endif
289
290 #ifdef PERL_GLOBAL_STRUCT
291 #define PERLVAR(var,type) /**/
292 #define PERLVARA(var,type) /**/
293 #define PERLVARI(var,type,init) PL_Vars.var = init;
294 #define PERLVARIC(var,type,init) PL_Vars.var = init;
295 #include "perlvars.h"
296 #undef PERLVAR
297 #undef PERLVARA
298 #undef PERLVARI
299 #undef PERLVARIC
300 #endif
301
302     PERL_SYS_INIT(&argc,&argv);
303
304     if (!(my_perl = perl_alloc()))
305         return (1);
306     perl_construct( my_perl );
307     PL_perl_destruct_level = 0;
308
309     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
310     if (!exitstatus) {
311 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
312 #  ifdef PERL_OBJECT
313         CPerlHost *h = new CPerlHost();
314         new_perl = perl_clone_using(my_perl, 1,
315                                     h->m_pHostperlMem,
316                                     h->m_pHostperlMemShared,
317                                     h->m_pHostperlMemParse,
318                                     h->m_pHostperlEnv,
319                                     h->m_pHostperlStdIO,
320                                     h->m_pHostperlLIO,
321                                     h->m_pHostperlDir,
322                                     h->m_pHostperlSock,
323                                     h->m_pHostperlProc
324                                     );
325         CPerlObj *pPerl = (CPerlObj*)new_perl;
326 #  else
327         new_perl = perl_clone(my_perl, 1);
328 #  endif
329         exitstatus = perl_run( new_perl );
330         SetPerlInterpreter(my_perl);
331 #else
332         exitstatus = perl_run( my_perl );
333 #endif
334     }
335
336     perl_destruct( my_perl );
337     perl_free( my_perl );
338 #ifdef USE_ITHREADS
339     if (new_perl) {
340         SetPerlInterpreter(new_perl);
341         perl_destruct(new_perl);
342         perl_free(new_perl);
343     }
344 #endif
345
346     PERL_SYS_TERM();
347
348     return (exitstatus);
349 }
350
351 BOOL APIENTRY
352 DllMain(HANDLE hModule,         /* DLL module handle */
353         DWORD fdwReason,        /* reason called */
354         LPVOID lpvReserved)     /* reserved */
355
356     switch (fdwReason) {
357         /* The DLL is attaching to a process due to process
358          * initialization or a call to LoadLibrary.
359          */
360     case DLL_PROCESS_ATTACH:
361 /* #define DEFAULT_BINMODE */
362 #ifdef DEFAULT_BINMODE
363         setmode( fileno( stdin  ), O_BINARY );
364         setmode( fileno( stdout ), O_BINARY );
365         setmode( fileno( stderr ), O_BINARY );
366         _fmode = O_BINARY;
367 #endif
368         g_TlsAllocIndex = TlsAlloc();
369         DisableThreadLibraryCalls((HMODULE)hModule);
370         w32_perldll_handle = hModule;
371         break;
372
373         /* The DLL is detaching from a process due to
374          * process termination or call to FreeLibrary.
375          */
376     case DLL_PROCESS_DETACH:
377         TlsFree(g_TlsAllocIndex);
378         break;
379
380         /* The attached process creates a new thread. */
381     case DLL_THREAD_ATTACH:
382         break;
383
384         /* The thread of the attached process terminates. */
385     case DLL_THREAD_DETACH:
386         break;
387
388     default:
389         break;
390     }
391     return TRUE;
392 }