source: trunk/third/perl/win32/perllib.c @ 14545

Revision 14545, 8.8 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
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 */
22char *staticlinkmodules[] = {
23    "DynaLoader",
24    NULL,
25};
26
27EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
28
29static void
30xs_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
41EXTERN_C void
42perl_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
90EXTERN_C PerlInterpreter*
91perl_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
121EXTERN_C PerlInterpreter*
122perl_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
146EXTERN_C void
147win32_delete_internal_host(void *h)
148{
149    CPerlHost *host = (CPerlHost*)h;
150    delete host;
151}
152
153#ifdef PERL_OBJECT
154
155EXTERN_C void
156perl_construct(PerlInterpreter* my_perl)
157{
158    CPerlObj* pPerl = (CPerlObj*)my_perl;
159    try
160    {
161        Perl_construct();
162    }
163    catch(...)
164    {
165        win32_fprintf(stderr, "%s\n",
166                      "Error: Unable to construct data structures");
167        perl_free(my_perl);
168    }
169}
170
171EXTERN_C void
172perl_destruct(PerlInterpreter* my_perl)
173{
174    CPerlObj* pPerl = (CPerlObj*)my_perl;
175#ifdef DEBUGGING
176    Perl_destruct();
177#else
178    try
179    {
180        Perl_destruct();
181    }
182    catch(...)
183    {
184    }
185#endif
186}
187
188EXTERN_C void
189perl_free(PerlInterpreter* my_perl)
190{
191    CPerlObj* pPerl = (CPerlObj*)my_perl;
192    void *host = w32_internal_host;
193#ifdef DEBUGGING
194    Perl_free();
195#else
196    try
197    {
198        Perl_free();
199    }
200    catch(...)
201    {
202    }
203#endif
204    win32_delete_internal_host(host);
205    PERL_SET_THX(NULL);
206}
207
208EXTERN_C int
209perl_run(PerlInterpreter* my_perl)
210{
211    CPerlObj* pPerl = (CPerlObj*)my_perl;
212    int retVal;
213#ifdef DEBUGGING
214    retVal = Perl_run();
215#else
216    try
217    {
218        retVal = Perl_run();
219    }
220    catch(...)
221    {
222        win32_fprintf(stderr, "Error: Runtime exception\n");
223        retVal = -1;
224    }
225#endif
226    return retVal;
227}
228
229EXTERN_C int
230perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
231{
232    int retVal;
233    CPerlObj* pPerl = (CPerlObj*)my_perl;
234#ifdef DEBUGGING
235    retVal = Perl_parse(xsinit, argc, argv, env);
236#else
237    try
238    {
239        retVal = Perl_parse(xsinit, argc, argv, env);
240    }
241    catch(...)
242    {
243        win32_fprintf(stderr, "Error: Parse exception\n");
244        retVal = -1;
245    }
246#endif
247    *win32_errno() = 0;
248    return retVal;
249}
250
251#undef PL_perl_destruct_level
252#define PL_perl_destruct_level int dummy
253
254#endif /* PERL_OBJECT */
255#endif /* PERL_IMPLICIT_SYS */
256
257EXTERN_C HANDLE w32_perldll_handle;
258
259EXTERN_C DllExport int
260RunPerl(int argc, char **argv, char **env)
261{
262    int exitstatus;
263    PerlInterpreter *my_perl, *new_perl = NULL;
264
265#ifndef __BORLANDC__
266    /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
267     * want to free() argv after main() returns.  As luck would have it,
268     * Borland's CRT does the right thing to argv[0] already. */
269    char szModuleName[MAX_PATH];
270    char *ptr;
271
272    GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
273    (void)win32_longpath(szModuleName);
274    argv[0] = szModuleName;
275#endif
276
277#ifdef PERL_GLOBAL_STRUCT
278#define PERLVAR(var,type) /**/
279#define PERLVARA(var,type) /**/
280#define PERLVARI(var,type,init) PL_Vars.var = init;
281#define PERLVARIC(var,type,init) PL_Vars.var = init;
282#include "perlvars.h"
283#undef PERLVAR
284#undef PERLVARA
285#undef PERLVARI
286#undef PERLVARIC
287#endif
288
289    PERL_SYS_INIT(&argc,&argv);
290
291    if (!(my_perl = perl_alloc()))
292        return (1);
293    perl_construct(my_perl);
294    PL_perl_destruct_level = 0;
295
296    exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
297    if (!exitstatus) {
298#if defined(TOP_CLONE) && defined(USE_ITHREADS)         /* XXXXXX testing */
299#  ifdef PERL_OBJECT
300        CPerlHost *h = new CPerlHost();
301        new_perl = perl_clone_using(my_perl, 1,
302                                    h->m_pHostperlMem,
303                                    h->m_pHostperlMemShared,
304                                    h->m_pHostperlMemParse,
305                                    h->m_pHostperlEnv,
306                                    h->m_pHostperlStdIO,
307                                    h->m_pHostperlLIO,
308                                    h->m_pHostperlDir,
309                                    h->m_pHostperlSock,
310                                    h->m_pHostperlProc
311                                    );
312        CPerlObj *pPerl = (CPerlObj*)new_perl;
313#  else
314        new_perl = perl_clone(my_perl, 1);
315#  endif
316        exitstatus = perl_run(new_perl);
317        PERL_SET_THX(my_perl);
318#else
319        exitstatus = perl_run(my_perl);
320#endif
321    }
322
323    perl_destruct(my_perl);
324    perl_free(my_perl);
325#ifdef USE_ITHREADS
326    if (new_perl) {
327        PERL_SET_THX(new_perl);
328        perl_destruct(new_perl);
329        perl_free(new_perl);
330    }
331#endif
332
333    PERL_SYS_TERM();
334
335    return (exitstatus);
336}
337
338EXTERN_C void
339set_w32_module_name(void);
340
341#ifdef __MINGW32__
342EXTERN_C                /* GCC in C++ mode mangles the name, otherwise */
343#endif
344BOOL APIENTRY
345DllMain(HANDLE hModule,         /* DLL module handle */
346        DWORD fdwReason,        /* reason called */
347        LPVOID lpvReserved)     /* reserved */
348{
349    switch (fdwReason) {
350        /* The DLL is attaching to a process due to process
351         * initialization or a call to LoadLibrary.
352         */
353    case DLL_PROCESS_ATTACH:
354/* #define DEFAULT_BINMODE */
355#ifdef DEFAULT_BINMODE
356        setmode( fileno( stdin  ), O_BINARY );
357        setmode( fileno( stdout ), O_BINARY );
358        setmode( fileno( stderr ), O_BINARY );
359        _fmode = O_BINARY;
360#endif
361        DisableThreadLibraryCalls((HMODULE)hModule);
362        w32_perldll_handle = hModule;
363        set_w32_module_name();
364        break;
365
366        /* The DLL is detaching from a process due to
367         * process termination or call to FreeLibrary.
368         */
369    case DLL_PROCESS_DETACH:
370        break;
371
372        /* The attached process creates a new thread. */
373    case DLL_THREAD_ATTACH:
374        break;
375
376        /* The thread of the attached process terminates. */
377    case DLL_THREAD_DETACH:
378        break;
379
380    default:
381        break;
382    }
383    return TRUE;
384}
Note: See TracBrowser for help on using the repository browser.