This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH: perl@11564] introducing perlivp
[perl5.git] / win32 / perllib.c
1 /*
2  * "The Road goes ever on and on, down from the door where it began."
3  */
4 #define PERLIO_NOT_STDIO 0
5 #include "EXTERN.h"
6 #include "perl.h"
7
8 #ifdef PERL_OBJECT
9 #define NO_XSLOCKS
10 #endif
11
12 #include "XSUB.h"
13
14 #ifdef PERL_IMPLICIT_SYS
15 #include "win32iop.h"
16 #include <fcntl.h>
17 #endif /* PERL_IMPLICIT_SYS */
18
19
20 /* Register any extra external extensions */
21 char *staticlinkmodules[] = {
22     "DynaLoader",
23     NULL,
24 };
25
26 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
27
28 static void
29 xs_init(pTHXo)
30 {
31     char *file = __FILE__;
32     dXSUB_SYS;
33     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
34 }
35
36 #ifdef PERL_IMPLICIT_SYS
37
38 #include "perlhost.h"
39
40 EXTERN_C void
41 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
42                    struct IPerlMemInfo* perlMemSharedInfo,
43                    struct IPerlMemInfo* perlMemParseInfo,
44                    struct IPerlEnvInfo* perlEnvInfo,
45                    struct IPerlStdIOInfo* perlStdIOInfo,
46                    struct IPerlLIOInfo* perlLIOInfo,
47                    struct IPerlDirInfo* perlDirInfo,
48                    struct IPerlSockInfo* perlSockInfo,
49                    struct IPerlProcInfo* perlProcInfo)
50 {
51     if (perlMemInfo) {
52         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
53         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
54     }
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) {
64         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
65         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
66     }
67     if (perlStdIOInfo) {
68         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
69         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
70     }
71     if (perlLIOInfo) {
72         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
73         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
74     }
75     if (perlDirInfo) {
76         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
77         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
78     }
79     if (perlSockInfo) {
80         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
81         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
82     }
83     if (perlProcInfo) {
84         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
85         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
86     }
87 }
88
89 EXTERN_C PerlInterpreter*
90 perl_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)
95 {
96     PerlInterpreter *my_perl = NULL;
97     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
98                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
99
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;
115         }
116     }
117     return my_perl;
118 }
119
120 EXTERN_C PerlInterpreter*
121 perl_alloc(void)
122 {
123     PerlInterpreter* my_perl = NULL;
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;
140         }
141     }
142     return my_perl;
143 }
144
145 EXTERN_C void
146 win32_delete_internal_host(void *h)
147 {
148     CPerlHost *host = (CPerlHost*)h;
149     delete host;
150 }
151
152 #ifdef PERL_OBJECT
153
154 EXTERN_C void
155 perl_construct(PerlInterpreter* my_perl)
156 {
157     CPerlObj* pPerl = (CPerlObj*)my_perl;
158     try
159     {
160         Perl_construct();
161     }
162     catch(...)
163     {
164         win32_fprintf(stderr, "%s\n",
165                       "Error: Unable to construct data structures");
166         perl_free(my_perl);
167     }
168 }
169
170 EXTERN_C void
171 perl_destruct(PerlInterpreter* my_perl)
172 {
173     CPerlObj* pPerl = (CPerlObj*)my_perl;
174 #ifdef DEBUGGING
175     Perl_destruct();
176 #else
177     try
178     {
179         Perl_destruct();
180     }
181     catch(...)
182     {
183     }
184 #endif
185 }
186
187 EXTERN_C void
188 perl_free(PerlInterpreter* my_perl)
189 {
190     CPerlObj* pPerl = (CPerlObj*)my_perl;
191     void *host = w32_internal_host;
192 #ifdef DEBUGGING
193     Perl_free();
194 #else
195     try
196     {
197         Perl_free();
198     }
199     catch(...)
200     {
201     }
202 #endif
203     win32_delete_internal_host(host);
204     PERL_SET_THX(NULL);
205 }
206
207 EXTERN_C int
208 perl_run(PerlInterpreter* my_perl)
209 {
210     CPerlObj* pPerl = (CPerlObj*)my_perl;
211     int retVal;
212 #ifdef DEBUGGING
213     retVal = Perl_run();
214 #else
215     try
216     {
217         retVal = Perl_run();
218     }
219     catch(...)
220     {
221         win32_fprintf(stderr, "Error: Runtime exception\n");
222         retVal = -1;
223     }
224 #endif
225     return retVal;
226 }
227
228 EXTERN_C int
229 perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
230 {
231     int retVal;
232     CPerlObj* pPerl = (CPerlObj*)my_perl;
233 #ifdef DEBUGGING
234     retVal = Perl_parse(xsinit, argc, argv, env);
235 #else
236     try
237     {
238         retVal = Perl_parse(xsinit, argc, argv, env);
239     }
240     catch(...)
241     {
242         win32_fprintf(stderr, "Error: Parse exception\n");
243         retVal = -1;
244     }
245 #endif
246     *win32_errno() = 0;
247     return retVal;
248 }
249
250 #undef PL_perl_destruct_level
251 #define PL_perl_destruct_level int dummy
252
253 #endif /* PERL_OBJECT */
254 #endif /* PERL_IMPLICIT_SYS */
255
256 EXTERN_C HANDLE w32_perldll_handle;
257
258 EXTERN_C DllExport int
259 RunPerl(int argc, char **argv, char **env)
260 {
261     int exitstatus;
262     PerlInterpreter *my_perl, *new_perl = NULL;
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 EXTERN_C void
338 set_w32_module_name(void);
339
340 EXTERN_C void
341 EndSockets(void);
342
343
344 #ifdef __MINGW32__
345 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
346 #endif
347 BOOL APIENTRY
348 DllMain(HANDLE hModule,         /* DLL module handle */
349         DWORD fdwReason,        /* reason called */
350         LPVOID lpvReserved)     /* reserved */
351
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 */
358 #ifdef DEFAULT_BINMODE
359         setmode( fileno( stdin  ), O_BINARY );
360         setmode( fileno( stdout ), O_BINARY );
361         setmode( fileno( stderr ), O_BINARY );
362         _fmode = O_BINARY;
363 #endif
364         DisableThreadLibraryCalls((HMODULE)hModule);
365         w32_perldll_handle = hModule;
366         set_w32_module_name();
367         break;
368
369         /* The DLL is detaching from a process due to
370          * process termination or call to FreeLibrary.
371          */
372     case DLL_PROCESS_DETACH:
373         /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
374            anything here had better be harmless if:
375             A. Not called at all.
376             B. Called after memory allocation for Heap has been forcibly removed by OS.
377             PerlIO_cleanup() was done here but fails (B).
378          */     
379         EndSockets();
380 #if defined(USE_THREADS) || defined(USE_ITHREADS)
381         if (PL_curinterp)
382             FREE_THREAD_KEY;
383 #endif
384         break;
385
386         /* The attached process creates a new thread. */
387     case DLL_THREAD_ATTACH:
388         break;
389
390         /* The thread of the attached process terminates. */
391     case DLL_THREAD_DETACH:
392         break;
393
394     default:
395         break;
396     }
397     return TRUE;
398 }
399
400 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
401 EXTERN_C PerlInterpreter *
402 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
403     dTHXo;
404     CPerlHost *h;
405     h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
406     proto_perl = perl_clone_using(proto_perl, flags,
407                         h->m_pHostperlMem,
408                         h->m_pHostperlMemShared,
409                         h->m_pHostperlMemParse,
410                         h->m_pHostperlEnv,
411                         h->m_pHostperlStdIO,
412                         h->m_pHostperlLIO,
413                         h->m_pHostperlDir,
414                         h->m_pHostperlSock,
415                         h->m_pHostperlProc
416     );
417     proto_perl->Isys_intern.internal_host = h;
418     return proto_perl;
419         
420 }
421 #endif