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 NULL, 20 }; 21 22 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); 23 24 static void 25 xs_init(pTHX) 26 { 27 char *file = __FILE__; 28 dXSUB_SYS; 29 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 30 } 31 32 #ifdef PERL_IMPLICIT_SYS 33 34 #include "perlhost.h" 35 36 void 37 win32_checkTLS(PerlInterpreter *host_perl) 38 { 39 dTHX; 40 if (host_perl != my_perl) { 41 int *nowhere = NULL; 42 *nowhere = 0; 43 abort(); 44 } 45 } 46 47 EXTERN_C void 48 perl_get_host_info(struct IPerlMemInfo* perlMemInfo, 49 struct IPerlMemInfo* perlMemSharedInfo, 50 struct IPerlMemInfo* perlMemParseInfo, 51 struct IPerlEnvInfo* perlEnvInfo, 52 struct IPerlStdIOInfo* perlStdIOInfo, 53 struct IPerlLIOInfo* perlLIOInfo, 54 struct IPerlDirInfo* perlDirInfo, 55 struct IPerlSockInfo* perlSockInfo, 56 struct IPerlProcInfo* perlProcInfo) 57 { 58 if (perlMemInfo) { 59 Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); 60 perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 61 } 62 if (perlMemSharedInfo) { 63 Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); 64 perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 65 } 66 if (perlMemParseInfo) { 67 Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); 68 perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 69 } 70 if (perlEnvInfo) { 71 Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); 72 perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); 73 } 74 if (perlStdIOInfo) { 75 Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); 76 perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); 77 } 78 if (perlLIOInfo) { 79 Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); 80 perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); 81 } 82 if (perlDirInfo) { 83 Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); 84 perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); 85 } 86 if (perlSockInfo) { 87 Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); 88 perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); 89 } 90 if (perlProcInfo) { 91 Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); 92 perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); 93 } 94 } 95 96 EXTERN_C PerlInterpreter* 97 perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, 98 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, 99 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, 100 struct IPerlDir** ppDir, struct IPerlSock** ppSock, 101 struct IPerlProc** ppProc) 102 { 103 PerlInterpreter *my_perl = NULL; 104 CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, 105 ppStdIO, ppLIO, ppDir, ppSock, ppProc); 106 107 if (pHost) { 108 my_perl = perl_alloc_using(pHost->m_pHostperlMem, 109 pHost->m_pHostperlMemShared, 110 pHost->m_pHostperlMemParse, 111 pHost->m_pHostperlEnv, 112 pHost->m_pHostperlStdIO, 113 pHost->m_pHostperlLIO, 114 pHost->m_pHostperlDir, 115 pHost->m_pHostperlSock, 116 pHost->m_pHostperlProc); 117 if (my_perl) { 118 w32_internal_host = pHost; 119 pHost->host_perl = my_perl; 120 } 121 } 122 return my_perl; 123 } 124 125 EXTERN_C PerlInterpreter* 126 perl_alloc(void) 127 { 128 PerlInterpreter* my_perl = NULL; 129 CPerlHost* pHost = new CPerlHost(); 130 if (pHost) { 131 my_perl = perl_alloc_using(pHost->m_pHostperlMem, 132 pHost->m_pHostperlMemShared, 133 pHost->m_pHostperlMemParse, 134 pHost->m_pHostperlEnv, 135 pHost->m_pHostperlStdIO, 136 pHost->m_pHostperlLIO, 137 pHost->m_pHostperlDir, 138 pHost->m_pHostperlSock, 139 pHost->m_pHostperlProc); 140 if (my_perl) { 141 w32_internal_host = pHost; 142 pHost->host_perl = my_perl; 143 } 144 } 145 return my_perl; 146 } 147 148 EXTERN_C void 149 win32_delete_internal_host(void *h) 150 { 151 CPerlHost *host = (CPerlHost*)h; 152 delete host; 153 } 154 155 #endif /* PERL_IMPLICIT_SYS */ 156 157 EXTERN_C HANDLE w32_perldll_handle; 158 159 EXTERN_C DllExport int 160 RunPerl(int argc, char **argv, char **env) 161 { 162 int exitstatus; 163 PerlInterpreter *my_perl, *new_perl = NULL; 164 165 #ifndef __BORLANDC__ 166 /* XXX this _may_ be a problem on some compilers (e.g. Borland) that 167 * want to free() argv after main() returns. As luck would have it, 168 * Borland's CRT does the right thing to argv[0] already. */ 169 char szModuleName[MAX_PATH]; 170 171 GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); 172 (void)win32_longpath(szModuleName); 173 argv[0] = szModuleName; 174 #endif 175 176 #ifdef PERL_GLOBAL_STRUCT 177 #define PERLVAR(var,type) /**/ 178 #define PERLVARA(var,type) /**/ 179 #define PERLVARI(var,type,init) PL_Vars.var = init; 180 #define PERLVARIC(var,type,init) PL_Vars.var = init; 181 #include "perlvars.h" 182 #undef PERLVAR 183 #undef PERLVARA 184 #undef PERLVARI 185 #undef PERLVARIC 186 #endif 187 188 PERL_SYS_INIT(&argc,&argv); 189 190 if (!(my_perl = perl_alloc())) 191 return (1); 192 perl_construct(my_perl); 193 PL_perl_destruct_level = 0; 194 195 exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); 196 if (!exitstatus) { 197 #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ 198 new_perl = perl_clone(my_perl, 1); 199 exitstatus = perl_run(new_perl); 200 PERL_SET_THX(my_perl); 201 #else 202 exitstatus = perl_run(my_perl); 203 #endif 204 } 205 206 perl_destruct(my_perl); 207 perl_free(my_perl); 208 #ifdef USE_ITHREADS 209 if (new_perl) { 210 PERL_SET_THX(new_perl); 211 perl_destruct(new_perl); 212 perl_free(new_perl); 213 } 214 #endif 215 216 PERL_SYS_TERM(); 217 218 return (exitstatus); 219 } 220 221 EXTERN_C void 222 set_w32_module_name(void); 223 224 EXTERN_C void 225 EndSockets(void); 226 227 228 #ifdef __MINGW32__ 229 EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ 230 #endif 231 BOOL APIENTRY 232 DllMain(HANDLE 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 /* #define DEFAULT_BINMODE */ 242 #ifdef DEFAULT_BINMODE 243 setmode( fileno( stdin ), O_BINARY ); 244 setmode( fileno( stdout ), O_BINARY ); 245 setmode( fileno( stderr ), O_BINARY ); 246 _fmode = O_BINARY; 247 #endif 248 DisableThreadLibraryCalls((HMODULE)hModule); 249 w32_perldll_handle = hModule; 250 set_w32_module_name(); 251 break; 252 253 /* The DLL is detaching from a process due to 254 * process termination or call to FreeLibrary. 255 */ 256 case DLL_PROCESS_DETACH: 257 /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() 258 anything here had better be harmless if: 259 A. Not called at all. 260 B. Called after memory allocation for Heap has been forcibly removed by OS. 261 PerlIO_cleanup() was done here but fails (B). 262 */ 263 EndSockets(); 264 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 265 if (PL_curinterp) 266 FREE_THREAD_KEY; 267 #endif 268 break; 269 270 /* The attached process creates a new thread. */ 271 case DLL_THREAD_ATTACH: 272 break; 273 274 /* The thread of the attached process terminates. */ 275 case DLL_THREAD_DETACH: 276 break; 277 278 default: 279 break; 280 } 281 return TRUE; 282 } 283 284 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 285 EXTERN_C PerlInterpreter * 286 perl_clone_host(PerlInterpreter* proto_perl, UV flags) { 287 dTHX; 288 CPerlHost *h; 289 h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); 290 proto_perl = perl_clone_using(proto_perl, flags, 291 h->m_pHostperlMem, 292 h->m_pHostperlMemShared, 293 h->m_pHostperlMemParse, 294 h->m_pHostperlEnv, 295 h->m_pHostperlStdIO, 296 h->m_pHostperlLIO, 297 h->m_pHostperlDir, 298 h->m_pHostperlSock, 299 h->m_pHostperlProc 300 ); 301 proto_perl->Isys_intern.internal_host = h; 302 h->host_perl = proto_perl; 303 return proto_perl; 304 305 } 306 #endif 307