perllib.c revision 1.8
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 */ 17char *staticlinkmodules[] = { 18 "DynaLoader", 19 /* other similar records will be included from "perllibst.h" */ 20#define STATIC1 21#include "perllibst.h" 22 NULL, 23}; 24 25EXTERN_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 30static void 31xs_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: 44extern "C" void win32_checkTLS(PerlInterpreter *host_perl); 45*/ 46#include "perlhost.h" 47 48void 49win32_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 63int GetLogicalDrives() { 64 return 0; /* no logical drives on CE */ 65} 66int GetLogicalDriveStrings(int size, char addr[]) { 67 return 0; /* no logical drives on CE */ 68} 69/* TBD */ 70DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) { 71 return 0; 72} 73/* TBD */ 74DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) { 75 return 0; 76} 77/* TBD */ 78DWORD SetCurrentDirectoryA(LPSTR pPath) { 79 return 0; 80} 81/* TBD */ 82DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) { 83 return 0; 84} 85int xcesetuid(uid_t id){return 0;} 86int xceseteuid(uid_t id){ return 0;} 87int xcegetuid() {return 0;} 88int xcegeteuid(){ return 0;} 89#endif 90 91/* WINCE??: include "perlhost.h" */ 92 93EXTERN_C void 94perl_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 142EXTERN_C PerlInterpreter* 143perl_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 171EXTERN_C PerlInterpreter* 172perl_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 194EXTERN_C void 195win32_delete_internal_host(void *h) 196{ 197 CPerlHost *host = (CPerlHost*)h; 198 delete host; 199} 200 201#endif /* PERL_IMPLICIT_SYS */ 202 203EXTERN_C HANDLE w32_perldll_handle; 204 205EXTERN_C DllExport int 206RunPerl(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 290EXTERN_C void 291set_w32_module_name(void); 292 293EXTERN_C void 294EndSockets(void); 295 296 297#ifdef __MINGW32__ 298EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ 299#endif 300BOOL APIENTRY 301DllMain(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) 359EXTERN_C PerlInterpreter * 360perl_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