perllib.c revision 1.3 
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}
385