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 /* other similar records will be included from "perllibst.h" */ 20 #define STATIC1 21 #include "perllibst.h" 22 NULL, 23 }; 24 25 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); 26 /* other similar records will be included from "perllibst.h" */ 27 #define STATIC2 28 #include "perllibst.h" 29 30 static void 31 xs_init(pTHX) 32 { 33 char *file = __FILE__; 34 dXSUB_SYS; 35 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 36 /* other similar records will be included from "perllibst.h" */ 37 #define STATIC3 38 #include "perllibst.h" 39 } 40 41 #ifdef PERL_IMPLICIT_SYS 42 43 /* WINCE: include replaced by: 44 extern "C" void win32_checkTLS(PerlInterpreter *host_perl); 45 */ 46 #include "perlhost.h" 47 48 void 49 win32_checkTLS(PerlInterpreter *host_perl) 50 { 51 dTHX; 52 if (host_perl != my_perl) { 53 int *nowhere = NULL; 54 #ifdef UNDER_CE 55 printf(" ... bad in win32_checkTLS\n"); 56 printf(" %08X ne %08X\n",host_perl,my_perl); 57 #endif 58 abort(); 59 } 60 } 61 62 #ifdef UNDER_CE 63 int GetLogicalDrives() { 64 return 0; /* no logical drives on CE */ 65 } 66 int GetLogicalDriveStrings(int size, char addr[]) { 67 return 0; /* no logical drives on CE */ 68 } 69 /* TBD */ 70 DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) { 71 return 0; 72 } 73 /* TBD */ 74 DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) { 75 return 0; 76 } 77 /* TBD */ 78 DWORD SetCurrentDirectoryA(LPSTR pPath) { 79 return 0; 80 } 81 /* TBD */ 82 DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) { 83 return 0; 84 } 85 int xcesetuid(uid_t id){return 0;} 86 int xceseteuid(uid_t id){ return 0;} 87 int xcegetuid() {return 0;} 88 int xcegeteuid(){ return 0;} 89 #endif 90 91 /* WINCE??: include "perlhost.h" */ 92 93 EXTERN_C void 94 perl_get_host_info(struct IPerlMemInfo* perlMemInfo, 95 struct IPerlMemInfo* perlMemSharedInfo, 96 struct IPerlMemInfo* perlMemParseInfo, 97 struct IPerlEnvInfo* perlEnvInfo, 98 struct IPerlStdIOInfo* perlStdIOInfo, 99 struct IPerlLIOInfo* perlLIOInfo, 100 struct IPerlDirInfo* perlDirInfo, 101 struct IPerlSockInfo* perlSockInfo, 102 struct IPerlProcInfo* perlProcInfo) 103 { 104 if (perlMemInfo) { 105 Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); 106 perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 107 } 108 if (perlMemSharedInfo) { 109 Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); 110 perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 111 } 112 if (perlMemParseInfo) { 113 Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); 114 perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); 115 } 116 if (perlEnvInfo) { 117 Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); 118 perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); 119 } 120 if (perlStdIOInfo) { 121 Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); 122 perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); 123 } 124 if (perlLIOInfo) { 125 Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); 126 perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); 127 } 128 if (perlDirInfo) { 129 Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); 130 perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); 131 } 132 if (perlSockInfo) { 133 Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); 134 perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); 135 } 136 if (perlProcInfo) { 137 Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); 138 perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); 139 } 140 } 141 142 EXTERN_C PerlInterpreter* 143 perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, 144 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, 145 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, 146 struct IPerlDir** ppDir, struct IPerlSock** ppSock, 147 struct IPerlProc** ppProc) 148 { 149 PerlInterpreter *my_perl = NULL; 150 CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, 151 ppStdIO, ppLIO, ppDir, ppSock, ppProc); 152 153 if (pHost) { 154 my_perl = perl_alloc_using(pHost->m_pHostperlMem, 155 pHost->m_pHostperlMemShared, 156 pHost->m_pHostperlMemParse, 157 pHost->m_pHostperlEnv, 158 pHost->m_pHostperlStdIO, 159 pHost->m_pHostperlLIO, 160 pHost->m_pHostperlDir, 161 pHost->m_pHostperlSock, 162 pHost->m_pHostperlProc); 163 if (my_perl) { 164 w32_internal_host = pHost; 165 pHost->host_perl = my_perl; 166 } 167 } 168 return my_perl; 169 } 170 171 EXTERN_C PerlInterpreter* 172 perl_alloc(void) 173 { 174 PerlInterpreter* my_perl = NULL; 175 CPerlHost* pHost = new CPerlHost(); 176 if (pHost) { 177 my_perl = perl_alloc_using(pHost->m_pHostperlMem, 178 pHost->m_pHostperlMemShared, 179 pHost->m_pHostperlMemParse, 180 pHost->m_pHostperlEnv, 181 pHost->m_pHostperlStdIO, 182 pHost->m_pHostperlLIO, 183 pHost->m_pHostperlDir, 184 pHost->m_pHostperlSock, 185 pHost->m_pHostperlProc); 186 if (my_perl) { 187 w32_internal_host = pHost; 188 pHost->host_perl = my_perl; 189 } 190 } 191 return my_perl; 192 } 193 194 EXTERN_C void 195 win32_delete_internal_host(void *h) 196 { 197 CPerlHost *host = (CPerlHost*)h; 198 delete host; 199 } 200 201 #endif /* PERL_IMPLICIT_SYS */ 202 203 EXTERN_C HANDLE w32_perldll_handle; 204 205 EXTERN_C DllExport int 206 RunPerl(int argc, char **argv, char **env) 207 { 208 int exitstatus; 209 PerlInterpreter *my_perl, *new_perl = NULL; 210 OSVERSIONINFO osver; 211 char szModuleName[MAX_PATH]; 212 char *arg0 = argv[0]; 213 char *ansi = NULL; 214 bool use_environ = (env == environ); 215 216 osver.dwOSVersionInfoSize = sizeof(osver); 217 GetVersionEx(&osver); 218 219 if (osver.dwMajorVersion > 4) { 220 WCHAR widename[MAX_PATH]; 221 GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR)); 222 argv[0] = ansi = win32_ansipath(widename); 223 } 224 else { 225 Win_GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); 226 (void)win32_longpath(szModuleName); 227 argv[0] = szModuleName; 228 } 229 230 #ifdef PERL_GLOBAL_STRUCT 231 #define PERLVAR(var,type) /**/ 232 #define PERLVARA(var,type) /**/ 233 #define PERLVARI(var,type,init) PL_Vars.var = init; 234 #define PERLVARIC(var,type,init) PL_Vars.var = init; 235 #include "perlvars.h" 236 #undef PERLVAR 237 #undef PERLVARA 238 #undef PERLVARI 239 #undef PERLVARIC 240 #endif 241 242 PERL_SYS_INIT(&argc,&argv); 243 244 if (!(my_perl = perl_alloc())) 245 return (1); 246 perl_construct(my_perl); 247 PL_perl_destruct_level = 0; 248 249 /* PERL_SYS_INIT() may update the environment, e.g. via ansify_path(). 250 * This may reallocate the RTL environment block. Therefore we need 251 * to make sure that `env` continues to have the same value as `environ` 252 * if we have been called this way. If we have been called with any 253 * other value for `env` then all environment munging by PERL_SYS_INIT() 254 * will be lost again. 255 */ 256 if (use_environ) 257 env = environ; 258 259 exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); 260 if (!exitstatus) { 261 #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ 262 new_perl = perl_clone(my_perl, 1); 263 exitstatus = perl_run(new_perl); 264 PERL_SET_THX(my_perl); 265 #else 266 exitstatus = perl_run(my_perl); 267 #endif 268 } 269 270 perl_destruct(my_perl); 271 perl_free(my_perl); 272 #ifdef USE_ITHREADS 273 if (new_perl) { 274 PERL_SET_THX(new_perl); 275 perl_destruct(new_perl); 276 perl_free(new_perl); 277 } 278 #endif 279 280 /* At least the Borland RTL wants to free argv[] after main() returns. */ 281 argv[0] = arg0; 282 if (ansi) 283 win32_free(ansi); 284 285 PERL_SYS_TERM(); 286 287 return (exitstatus); 288 } 289 290 EXTERN_C void 291 set_w32_module_name(void); 292 293 EXTERN_C void 294 EndSockets(void); 295 296 297 #ifdef __MINGW32__ 298 EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ 299 #endif 300 BOOL APIENTRY 301 DllMain(HANDLE hModule, /* DLL module handle */ 302 DWORD fdwReason, /* reason called */ 303 LPVOID lpvReserved) /* reserved */ 304 { 305 switch (fdwReason) { 306 /* The DLL is attaching to a process due to process 307 * initialization or a call to LoadLibrary. 308 */ 309 case DLL_PROCESS_ATTACH: 310 /* #define DEFAULT_BINMODE */ 311 #ifdef DEFAULT_BINMODE 312 setmode( fileno( stdin ), O_BINARY ); 313 setmode( fileno( stdout ), O_BINARY ); 314 setmode( fileno( stderr ), O_BINARY ); 315 _fmode = O_BINARY; 316 #endif 317 318 #ifndef UNDER_CE 319 DisableThreadLibraryCalls((HMODULE)hModule); 320 #endif 321 322 w32_perldll_handle = hModule; 323 set_w32_module_name(); 324 break; 325 326 /* The DLL is detaching from a process due to 327 * process termination or call to FreeLibrary. 328 */ 329 case DLL_PROCESS_DETACH: 330 /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() 331 anything here had better be harmless if: 332 A. Not called at all. 333 B. Called after memory allocation for Heap has been forcibly removed by OS. 334 PerlIO_cleanup() was done here but fails (B). 335 */ 336 EndSockets(); 337 #if defined(USE_ITHREADS) 338 if (PL_curinterp) 339 FREE_THREAD_KEY; 340 #endif 341 break; 342 343 /* The attached process creates a new thread. */ 344 case DLL_THREAD_ATTACH: 345 break; 346 347 /* The thread of the attached process terminates. */ 348 case DLL_THREAD_DETACH: 349 break; 350 351 default: 352 break; 353 } 354 return TRUE; 355 } 356 357 358 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 359 EXTERN_C PerlInterpreter * 360 perl_clone_host(PerlInterpreter* proto_perl, UV flags) { 361 dTHX; 362 CPerlHost *h; 363 h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); 364 proto_perl = perl_clone_using(proto_perl, flags, 365 h->m_pHostperlMem, 366 h->m_pHostperlMemShared, 367 h->m_pHostperlMemParse, 368 h->m_pHostperlEnv, 369 h->m_pHostperlStdIO, 370 h->m_pHostperlLIO, 371 h->m_pHostperlDir, 372 h->m_pHostperlSock, 373 h->m_pHostperlProc 374 ); 375 proto_perl->Isys_intern.internal_host = h; 376 h->host_perl = proto_perl; 377 return proto_perl; 378 379 } 380 #endif 381