Commit | Line | Data |
e1caacb4 |
1 | // Time-stamp: <01/08/01 20:58:55 keuchel@w2k> |
2 | |
3 | #include "EXTERN.h" |
4 | #include "perl.h" |
5 | |
e1caacb4 |
6 | #include "XSUB.h" |
7 | |
8 | #ifdef PERL_IMPLICIT_SYS |
9 | #include "win32iop.h" |
10 | #include <fcntl.h> |
11 | #endif /* PERL_IMPLICIT_SYS */ |
12 | |
13 | |
14 | /* Register any extra external extensions */ |
15 | char *staticlinkmodules[] = { |
16 | "DynaLoader", |
17 | NULL, |
18 | }; |
19 | |
acfe0abc |
20 | EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); |
e1caacb4 |
21 | |
22 | static void |
acfe0abc |
23 | xs_init(pTHX) |
e1caacb4 |
24 | { |
25 | char *file = __FILE__; |
26 | dXSUB_SYS; |
27 | newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); |
28 | } |
29 | |
30 | #ifdef PERL_IMPLICIT_SYS |
31 | |
32 | #include "perlhost.h" |
33 | |
34 | EXTERN_C void |
35 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, |
36 | struct IPerlMemInfo* perlMemSharedInfo, |
37 | struct IPerlMemInfo* perlMemParseInfo, |
38 | struct IPerlEnvInfo* perlEnvInfo, |
39 | struct IPerlStdIOInfo* perlStdIOInfo, |
40 | struct IPerlLIOInfo* perlLIOInfo, |
41 | struct IPerlDirInfo* perlDirInfo, |
42 | struct IPerlSockInfo* perlSockInfo, |
43 | struct IPerlProcInfo* perlProcInfo) |
44 | { |
45 | if (perlMemInfo) { |
46 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
47 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
48 | } |
49 | if (perlMemSharedInfo) { |
50 | Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); |
51 | perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
52 | } |
53 | if (perlMemParseInfo) { |
54 | Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); |
55 | perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
56 | } |
57 | if (perlEnvInfo) { |
58 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
59 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); |
60 | } |
61 | if (perlStdIOInfo) { |
62 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
63 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); |
64 | } |
65 | if (perlLIOInfo) { |
66 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
67 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); |
68 | } |
69 | if (perlDirInfo) { |
70 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
71 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); |
72 | } |
73 | if (perlSockInfo) { |
74 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
75 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); |
76 | } |
77 | if (perlProcInfo) { |
78 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
79 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); |
80 | } |
81 | } |
82 | |
83 | EXTERN_C PerlInterpreter* |
84 | perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, |
85 | struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, |
86 | struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, |
87 | struct IPerlDir** ppDir, struct IPerlSock** ppSock, |
88 | struct IPerlProc** ppProc) |
89 | { |
90 | PerlInterpreter *my_perl = NULL; |
91 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
92 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); |
93 | |
94 | if (pHost) { |
95 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
96 | pHost->m_pHostperlMemShared, |
97 | pHost->m_pHostperlMemParse, |
98 | pHost->m_pHostperlEnv, |
99 | pHost->m_pHostperlStdIO, |
100 | pHost->m_pHostperlLIO, |
101 | pHost->m_pHostperlDir, |
102 | pHost->m_pHostperlSock, |
103 | pHost->m_pHostperlProc); |
104 | if (my_perl) { |
e1caacb4 |
105 | w32_internal_host = pHost; |
106 | } |
107 | } |
108 | return my_perl; |
109 | } |
110 | |
111 | EXTERN_C PerlInterpreter* |
112 | perl_alloc(void) |
113 | { |
114 | PerlInterpreter* my_perl = NULL; |
115 | CPerlHost* pHost = new CPerlHost(); |
116 | if (pHost) { |
117 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
118 | pHost->m_pHostperlMemShared, |
119 | pHost->m_pHostperlMemParse, |
120 | pHost->m_pHostperlEnv, |
121 | pHost->m_pHostperlStdIO, |
122 | pHost->m_pHostperlLIO, |
123 | pHost->m_pHostperlDir, |
124 | pHost->m_pHostperlSock, |
125 | pHost->m_pHostperlProc); |
126 | if (my_perl) { |
e1caacb4 |
127 | w32_internal_host = pHost; |
128 | } |
129 | } |
130 | return my_perl; |
131 | } |
132 | |
133 | EXTERN_C void |
134 | win32_delete_internal_host(void *h) |
135 | { |
136 | CPerlHost *host = (CPerlHost*)h; |
137 | delete host; |
138 | } |
139 | |
e1caacb4 |
140 | #endif /* PERL_IMPLICIT_SYS */ |
141 | |
142 | EXTERN_C HANDLE w32_perldll_handle; |
143 | |
144 | EXTERN_C DllExport int |
145 | RunPerl(int argc, char **argv, char **env) |
146 | { |
147 | int exitstatus; |
148 | PerlInterpreter *my_perl, *new_perl = NULL; |
149 | |
150 | #ifndef __BORLANDC__ |
151 | /* XXX this _may_ be a problem on some compilers (e.g. Borland) that |
152 | * want to free() argv after main() returns. As luck would have it, |
153 | * Borland's CRT does the right thing to argv[0] already. */ |
154 | char szModuleName[MAX_PATH]; |
155 | char *ptr; |
156 | |
157 | XCEGetModuleFileNameA(NULL, szModuleName, sizeof(szModuleName)); |
158 | (void)win32_longpath(szModuleName); |
159 | argv[0] = szModuleName; |
160 | #endif |
161 | |
162 | #ifdef PERL_GLOBAL_STRUCT |
163 | #define PERLVAR(var,type) /**/ |
164 | #define PERLVARA(var,type) /**/ |
165 | #define PERLVARI(var,type,init) PL_Vars.var = init; |
166 | #define PERLVARIC(var,type,init) PL_Vars.var = init; |
167 | #include "perlvars.h" |
168 | #undef PERLVAR |
169 | #undef PERLVARA |
170 | #undef PERLVARI |
171 | #undef PERLVARIC |
172 | #endif |
173 | |
174 | PERL_SYS_INIT(&argc,&argv); |
175 | |
176 | if (!(my_perl = perl_alloc())) |
177 | return (1); |
178 | perl_construct(my_perl); |
179 | PL_perl_destruct_level = 0; |
180 | |
181 | exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); |
182 | if (!exitstatus) { |
183 | #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ |
e1caacb4 |
184 | new_perl = perl_clone(my_perl, 1); |
e1caacb4 |
185 | exitstatus = perl_run(new_perl); |
186 | PERL_SET_THX(my_perl); |
187 | #else |
188 | exitstatus = perl_run(my_perl); |
189 | #endif |
190 | } |
191 | |
192 | perl_destruct(my_perl); |
193 | perl_free(my_perl); |
194 | #ifdef USE_ITHREADS |
195 | if (new_perl) { |
196 | PERL_SET_THX(new_perl); |
197 | perl_destruct(new_perl); |
198 | perl_free(new_perl); |
199 | } |
200 | #endif |
201 | |
202 | PERL_SYS_TERM(); |
203 | |
204 | return (exitstatus); |
205 | } |
206 | |
207 | EXTERN_C void |
208 | set_w32_module_name(void); |
209 | |
210 | #ifdef __MINGW32__ |
211 | EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ |
212 | #endif |
213 | BOOL APIENTRY |
214 | DllMain(HANDLE hModule, /* DLL module handle */ |
215 | DWORD fdwReason, /* reason called */ |
216 | LPVOID lpvReserved) /* reserved */ |
217 | { |
218 | switch (fdwReason) { |
219 | /* The DLL is attaching to a process due to process |
220 | * initialization or a call to LoadLibrary. |
221 | */ |
222 | case DLL_PROCESS_ATTACH: |
223 | /* #define DEFAULT_BINMODE */ |
224 | #ifdef DEFAULT_BINMODE |
225 | setmode( fileno( stdin ), O_BINARY ); |
226 | setmode( fileno( stdout ), O_BINARY ); |
227 | setmode( fileno( stderr ), O_BINARY ); |
228 | _fmode = O_BINARY; |
229 | #endif |
230 | |
231 | #ifndef UNDER_CE |
232 | DisableThreadLibraryCalls((HMODULE)hModule); |
233 | #endif |
234 | |
235 | w32_perldll_handle = hModule; |
236 | set_w32_module_name(); |
237 | break; |
238 | |
239 | /* The DLL is detaching from a process due to |
240 | * process termination or call to FreeLibrary. |
241 | */ |
242 | case DLL_PROCESS_DETACH: |
243 | break; |
244 | |
245 | /* The attached process creates a new thread. */ |
246 | case DLL_THREAD_ATTACH: |
247 | break; |
248 | |
249 | /* The thread of the attached process terminates. */ |
250 | case DLL_THREAD_DETACH: |
251 | break; |
252 | |
253 | default: |
254 | break; |
255 | } |
256 | return TRUE; |
257 | } |
258 | |