perllib.c revision 1.17 
1/*
2 *      The Road goes ever on and on
3 *          Down from the door where it began.
4 *
5 *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
6 *     [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"]
7 */
8#define PERLIO_NOT_STDIO 0
9#include "EXTERN.h"
10#include "perl.h"
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 */
21const char * const staticlinkmodules[] = {
22    "DynaLoader",
23    /* other similar records will be included from "perllibst.h" */
24#define STATIC1
25#include "perllibst.h"
26    NULL,
27};
28
29EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
30/* other similar records will be included from "perllibst.h" */
31#define STATIC2
32#include "perllibst.h"
33
34static void
35xs_init(pTHX)
36{
37    const char *file = __FILE__;
38    dXSUB_SYS;
39    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
40    /* other similar records will be included from "perllibst.h" */
41#define STATIC3
42#include "perllibst.h"
43}
44
45#ifdef PERL_IMPLICIT_SYS
46
47#include "perlhost.h"
48
49void
50win32_checkTLS(PerlInterpreter *host_perl)
51{
52    dTHX;
53    if (host_perl != my_perl) {
54        int *nowhere = NULL;
55        abort();
56    }
57}
58
59EXTERN_C void
60perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
61                   struct IPerlMemInfo* perlMemSharedInfo,
62                   struct IPerlMemInfo* perlMemParseInfo,
63                   struct IPerlEnvInfo* perlEnvInfo,
64                   struct IPerlStdIOInfo* perlStdIOInfo,
65                   struct IPerlLIOInfo* perlLIOInfo,
66                   struct IPerlDirInfo* perlDirInfo,
67                   struct IPerlSockInfo* perlSockInfo,
68                   struct IPerlProcInfo* perlProcInfo)
69{
70    if (perlMemInfo) {
71        Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
72        perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
73    }
74    if (perlMemSharedInfo) {
75        Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
76        perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
77    }
78    if (perlMemParseInfo) {
79        Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
80        perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
81    }
82    if (perlEnvInfo) {
83        Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
84        perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
85    }
86    if (perlStdIOInfo) {
87        Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
88        perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
89    }
90    if (perlLIOInfo) {
91        Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
92        perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
93    }
94    if (perlDirInfo) {
95        Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
96        perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
97    }
98    if (perlSockInfo) {
99        Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
100        perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
101    }
102    if (perlProcInfo) {
103        Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
104        perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
105    }
106}
107
108EXTERN_C PerlInterpreter*
109perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
110                 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
111                 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
112                 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
113                 struct IPerlProc** ppProc)
114{
115    PerlInterpreter *my_perl = NULL;
116    CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
117                                     ppStdIO, ppLIO, ppDir, ppSock, ppProc);
118
119    if (pHost) {
120        my_perl = perl_alloc_using(pHost->m_pHostperlMem,
121                                   pHost->m_pHostperlMemShared,
122                                   pHost->m_pHostperlMemParse,
123                                   pHost->m_pHostperlEnv,
124                                   pHost->m_pHostperlStdIO,
125                                   pHost->m_pHostperlLIO,
126                                   pHost->m_pHostperlDir,
127                                   pHost->m_pHostperlSock,
128                                   pHost->m_pHostperlProc);
129        if (my_perl) {
130            w32_internal_host = pHost;
131            pHost->host_perl  = my_perl;
132        }
133    }
134    return my_perl;
135}
136
137EXTERN_C PerlInterpreter*
138perl_alloc(void)
139{
140    PerlInterpreter* my_perl = NULL;
141    CPerlHost* pHost = new CPerlHost();
142    if (pHost) {
143        my_perl = perl_alloc_using(pHost->m_pHostperlMem,
144                                   pHost->m_pHostperlMemShared,
145                                   pHost->m_pHostperlMemParse,
146                                   pHost->m_pHostperlEnv,
147                                   pHost->m_pHostperlStdIO,
148                                   pHost->m_pHostperlLIO,
149                                   pHost->m_pHostperlDir,
150                                   pHost->m_pHostperlSock,
151                                   pHost->m_pHostperlProc);
152        if (my_perl) {
153            w32_internal_host = pHost;
154            pHost->host_perl  = my_perl;
155        }
156    }
157    return my_perl;
158}
159
160EXTERN_C void
161win32_delete_internal_host(void *h)
162{
163    CPerlHost *host = (CPerlHost*)h;
164    delete host;
165}
166
167#endif /* PERL_IMPLICIT_SYS */
168
169EXTERN_C HANDLE w32_perldll_handle;
170
171EXTERN_C DllExport int
172RunPerl(int argc, char **argv, char **env)
173{
174    int exitstatus;
175    PerlInterpreter *my_perl, *new_perl = NULL;
176    bool use_environ = (env == environ);
177
178    PERL_SYS_INIT(&argc,&argv);
179
180    if (!(my_perl = perl_alloc()))
181        return (1);
182    perl_construct(my_perl);
183    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
184    PL_perl_destruct_level = 0;
185
186    /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path().
187     * This may reallocate the RTL environment block. Therefore we need
188     * to make sure that `env` continues to have the same value as `environ`
189     * if we have been called this way.  If we have been called with any
190     * other value for `env` then all environment munging by PERL_SYS_INIT()
191     * will be lost again.
192     */
193    if (use_environ)
194        env = environ;
195
196    if (!perl_parse(my_perl, xs_init, argc, argv, env)) {
197#if defined(TOP_CLONE) && defined(USE_ITHREADS)		/* XXXXXX testing */
198        new_perl = perl_clone(my_perl, 1);
199        (void) perl_run(new_perl);
200        PERL_SET_THX(my_perl);
201#else
202        (void) perl_run(my_perl);
203#endif
204    }
205
206    exitstatus = perl_destruct(my_perl);
207    perl_free(my_perl);
208#ifdef USE_ITHREADS
209    if (new_perl) {
210        PERL_SET_THX(new_perl);
211        exitstatus = perl_destruct(new_perl);
212        perl_free(new_perl);
213    }
214#endif
215
216    PERL_SYS_TERM();
217
218    return (exitstatus);
219}
220
221EXTERN_C void
222set_w32_module_name(void);
223
224EXTERN_C void
225EndSockets(void);
226
227
228#ifdef __MINGW32__
229EXTERN_C		/* GCC in C++ mode mangles the name, otherwise */
230#endif
231BOOL APIENTRY
232DllMain(HINSTANCE hModule,	/* DLL module handle */
233        DWORD fdwReason,	/* reason called */
234        LPVOID lpvReserved)	/* reserved */
235{
236    switch (fdwReason) {
237        /* The DLL is attaching to a process due to process
238         * initialization or a call to LoadLibrary.
239         */
240    case DLL_PROCESS_ATTACH:
241        DisableThreadLibraryCalls((HMODULE)hModule);
242
243        w32_perldll_handle = hModule;
244        set_w32_module_name();
245        break;
246
247        /* The DLL is detaching from a process due to
248         * process termination or call to FreeLibrary.
249         */
250    case DLL_PROCESS_DETACH:
251        /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicking kill()
252           anything here had better be harmless if:
253            A. Not called at all.
254            B. Called after memory allocation for Heap has been forcibly removed by OS.
255            PerlIO_cleanup() was done here but fails (B).
256         */
257        EndSockets();
258#if defined(USE_ITHREADS)
259        if (PL_curinterp)
260            FREE_THREAD_KEY;
261#endif
262        break;
263
264        /* The attached process creates a new thread. */
265    case DLL_THREAD_ATTACH:
266        break;
267
268        /* The thread of the attached process terminates. */
269    case DLL_THREAD_DETACH:
270        break;
271
272    default:
273        break;
274    }
275    return TRUE;
276}
277
278
279#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
280EXTERN_C PerlInterpreter *
281perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
282    dTHX;
283    CPerlHost *h;
284    h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
285    proto_perl = perl_clone_using(proto_perl, flags,
286                        h->m_pHostperlMem,
287                        h->m_pHostperlMemShared,
288                        h->m_pHostperlMemParse,
289                        h->m_pHostperlEnv,
290                        h->m_pHostperlStdIO,
291                        h->m_pHostperlLIO,
292                        h->m_pHostperlDir,
293                        h->m_pHostperlSock,
294                        h->m_pHostperlProc
295    );
296    proto_perl->Isys_intern.internal_host = h;
297    h->host_perl  = proto_perl;
298    return proto_perl;
299
300}
301#endif
302