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 */ 22 char *staticlinkmodules[] = { 23 "DynaLoader", 24 NULL, 25 }; 26 27 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv); 28 29 static void 30 xs_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 41 EXTERN_C void 42 perl_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 90 EXTERN_C PerlInterpreter* 91 perl_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 121 EXTERN_C PerlInterpreter* 122 perl_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 146 EXTERN_C void 147 win32_delete_internal_host(void *h) 148 { 149 CPerlHost *host = (CPerlHost*)h; 150 delete host; 151 } 152 153 #ifdef PERL_OBJECT 154 155 EXTERN_C void 156 perl_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 171 EXTERN_C void 172 perl_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 188 EXTERN_C void 189 perl_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 208 EXTERN_C int 209 perl_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 229 EXTERN_C int 230 perl_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 257 EXTERN_C HANDLE w32_perldll_handle; 258 259 EXTERN_C DllExport int 260 RunPerl(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 338 EXTERN_C void 339 set_w32_module_name(void); 340 341 EXTERN_C void 342 EndSockets(void); 343 344 345 #ifdef __MINGW32__ 346 EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ 347 #endif 348 BOOL APIENTRY 349 DllMain(HANDLE hModule, /* DLL module handle */ 350 DWORD fdwReason, /* reason called */ 351 LPVOID lpvReserved) /* reserved */ 352 { 353 switch (fdwReason) { 354 /* The DLL is attaching to a process due to process 355 * initialization or a call to LoadLibrary. 356 */ 357 case DLL_PROCESS_ATTACH: 358 /* #define DEFAULT_BINMODE */ 359 #ifdef DEFAULT_BINMODE 360 setmode( fileno( stdin ), O_BINARY ); 361 setmode( fileno( stdout ), O_BINARY ); 362 setmode( fileno( stderr ), O_BINARY ); 363 _fmode = O_BINARY; 364 #endif 365 DisableThreadLibraryCalls((HMODULE)hModule); 366 w32_perldll_handle = hModule; 367 set_w32_module_name(); 368 break; 369 370 /* The DLL is detaching from a process due to 371 * process termination or call to FreeLibrary. 372 */ 373 case DLL_PROCESS_DETACH: 374 EndSockets(); 375 #if defined(USE_THREADS) || defined(USE_ITHREADS) 376 if (PL_curinterp) 377 FREE_THREAD_KEY; 378 #endif 379 break; 380 381 /* The attached process creates a new thread. */ 382 case DLL_THREAD_ATTACH: 383 break; 384 385 /* The thread of the attached process terminates. */ 386 case DLL_THREAD_DETACH: 387 break; 388 389 default: 390 break; 391 } 392 return TRUE; 393 } 394