RE: How to load a "loadable object" that has a non-default file extension ?
[perl.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 #include "XSUB.h"
9
10 #ifdef PERL_IMPLICIT_SYS
11 #include "win32iop.h"
12 #include <fcntl.h>
13 #endif /* PERL_IMPLICIT_SYS */
14
15
16 /* Register any extra external extensions */
17 char *staticlinkmodules[] = {
18     "DynaLoader",
19     /* other similar records will be included from "perllibst.h" */
20 #define STATIC1
21 #include "perllibst.h"
22     NULL,
23 };
24
25 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
26 /* other similar records will be included from "perllibst.h" */
27 #define STATIC2
28 #include "perllibst.h"
29
30 static void
31 xs_init(pTHX)
32 {
33     char *file = __FILE__;
34     dXSUB_SYS;
35     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
36     /* other similar records will be included from "perllibst.h" */
37 #define STATIC3
38 #include "perllibst.h"
39 }
40
41 #ifdef PERL_IMPLICIT_SYS
42
43 /* WINCE: include replaced by:
44 extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
45 */
46 #include "perlhost.h"
47
48 void
49 win32_checkTLS(PerlInterpreter *host_perl)
50 {
51     dTHX;
52     if (host_perl != my_perl) {
53         int *nowhere = NULL;
54 #ifdef UNDER_CE
55         printf(" ... bad in win32_checkTLS\n");
56         printf("  %08X ne %08X\n",host_perl,my_perl);
57 #endif
58         abort();
59     }
60 }
61
62 #ifdef UNDER_CE
63 int GetLogicalDrives() {
64     return 0; /* no logical drives on CE */
65 }
66 int GetLogicalDriveStrings(int size, char addr[]) {
67     return 0; /* no logical drives on CE */
68 }
69 /* TBD */
70 DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf,  LPSTR *pfile) {
71     return 0;
72 }
73 /* TBD */
74 DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf,  WCHAR **pfile) {
75     return 0;
76 }
77 /* TBD */
78 DWORD SetCurrentDirectoryA(LPSTR pPath) {
79     return 0;
80 }
81 /* TBD */
82 DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
83     return 0;
84 }
85 int xcesetuid(uid_t id){return 0;}
86 int xceseteuid(uid_t id){  return 0;}
87 int xcegetuid() {return 0;}
88 int xcegeteuid(){ return 0;}
89 #endif
90
91 /* WINCE??: include "perlhost.h" */
92
93 EXTERN_C void
94 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
95                    struct IPerlMemInfo* perlMemSharedInfo,
96                    struct IPerlMemInfo* perlMemParseInfo,
97                    struct IPerlEnvInfo* perlEnvInfo,
98                    struct IPerlStdIOInfo* perlStdIOInfo,
99                    struct IPerlLIOInfo* perlLIOInfo,
100                    struct IPerlDirInfo* perlDirInfo,
101                    struct IPerlSockInfo* perlSockInfo,
102                    struct IPerlProcInfo* perlProcInfo)
103 {
104     if (perlMemInfo) {
105         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
106         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
107     }
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) {
117         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
118         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
119     }
120     if (perlStdIOInfo) {
121         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
122         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
123     }
124     if (perlLIOInfo) {
125         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
126         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
127     }
128     if (perlDirInfo) {
129         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
130         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
131     }
132     if (perlSockInfo) {
133         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
134         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
135     }
136     if (perlProcInfo) {
137         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
138         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
139     }
140 }
141
142 EXTERN_C PerlInterpreter*
143 perl_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)
148 {
149     PerlInterpreter *my_perl = NULL;
150     CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
151                                      ppStdIO, ppLIO, ppDir, ppSock, ppProc);
152
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) {
164             w32_internal_host = pHost;
165             pHost->host_perl  = my_perl;
166         }
167     }
168     return my_perl;
169 }
170
171 EXTERN_C PerlInterpreter*
172 perl_alloc(void)
173 {
174     PerlInterpreter* my_perl = NULL;
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) {
187             w32_internal_host = pHost;
188             pHost->host_perl  = my_perl;
189         }
190     }
191     return my_perl;
192 }
193
194 EXTERN_C void
195 win32_delete_internal_host(void *h)
196 {
197     CPerlHost *host = (CPerlHost*)h;
198     delete host;
199 }
200
201 #endif /* PERL_IMPLICIT_SYS */
202
203 EXTERN_C HANDLE w32_perldll_handle;
204
205 EXTERN_C DllExport int
206 RunPerl(int argc, char **argv, char **env)
207 {
208     int exitstatus;
209     PerlInterpreter *my_perl, *new_perl = NULL;
210     OSVERSIONINFO osver;
211     char szModuleName[MAX_PATH];
212     char *arg0 = argv[0];
213     char *ansi = NULL;
214     bool use_environ = (env == environ);
215
216     osver.dwOSVersionInfoSize = sizeof(osver);
217     GetVersionEx(&osver);
218
219     if (osver.dwMajorVersion > 4) {
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     }
229
230 #ifdef PERL_GLOBAL_STRUCT
231 #define PERLVAR(var,type) /**/
232 #define PERLVARA(var,type) /**/
233 #define PERLVARI(var,type,init) PL_Vars.var = init;
234 #define PERLVARIC(var,type,init) PL_Vars.var = init;
235 #include "perlvars.h"
236 #undef PERLVAR
237 #undef PERLVARA
238 #undef PERLVARI
239 #undef PERLVARIC
240 #endif
241
242     PERL_SYS_INIT(&argc,&argv);
243
244     if (!(my_perl = perl_alloc()))
245         return (1);
246     perl_construct(my_perl);
247     PL_perl_destruct_level = 0;
248
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
259     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
260     if (!exitstatus) {
261 #if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
262         new_perl = perl_clone(my_perl, 1);
263         exitstatus = perl_run(new_perl);
264         PERL_SET_THX(my_perl);
265 #else
266         exitstatus = perl_run(my_perl);
267 #endif
268     }
269
270     perl_destruct(my_perl);
271     perl_free(my_perl);
272 #ifdef USE_ITHREADS
273     if (new_perl) {
274         PERL_SET_THX(new_perl);
275         perl_destruct(new_perl);
276         perl_free(new_perl);
277     }
278 #endif
279
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
285     PERL_SYS_TERM();
286
287     return (exitstatus);
288 }
289
290 EXTERN_C void
291 set_w32_module_name(void);
292
293 EXTERN_C void
294 EndSockets(void);
295
296
297 #ifdef __MINGW32__
298 EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
299 #endif
300 BOOL APIENTRY
301 DllMain(HANDLE hModule,         /* DLL module handle */
302         DWORD fdwReason,        /* reason called */
303         LPVOID lpvReserved)     /* reserved */
304
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 */
311 #ifdef DEFAULT_BINMODE
312         setmode( fileno( stdin  ), O_BINARY );
313         setmode( fileno( stdout ), O_BINARY );
314         setmode( fileno( stderr ), O_BINARY );
315         _fmode = O_BINARY;
316 #endif
317
318 #ifndef UNDER_CE
319         DisableThreadLibraryCalls((HMODULE)hModule);
320 #endif
321
322         w32_perldll_handle = hModule;
323         set_w32_module_name();
324         break;
325
326         /* The DLL is detaching from a process due to
327          * process termination or call to FreeLibrary.
328          */
329     case DLL_PROCESS_DETACH:
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          */     
336         EndSockets();
337 #if defined(USE_ITHREADS)
338         if (PL_curinterp)
339             FREE_THREAD_KEY;
340 #endif
341         break;
342
343         /* The attached process creates a new thread. */
344     case DLL_THREAD_ATTACH:
345         break;
346
347         /* The thread of the attached process terminates. */
348     case DLL_THREAD_DETACH:
349         break;
350
351     default:
352         break;
353     }
354     return TRUE;
355 }
356
357
358 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
359 EXTERN_C PerlInterpreter *
360 perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
361     dTHX;
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;
376     h->host_perl  = proto_perl;
377     return proto_perl;
378         
379 }
380 #endif