| 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 | |
| 6 | #ifdef PERL_OBJECT |
| 7 | #define NO_XSLOCKS |
| 8 | #endif |
| 9 | |
| 10 | #include "XSUB.h" |
| 11 | |
| 12 | #ifdef PERL_IMPLICIT_SYS |
| 13 | #include "win32iop.h" |
| 14 | #include <fcntl.h> |
| 15 | #endif /* PERL_IMPLICIT_SYS */ |
| 16 | |
| 17 | |
| 18 | /* Register any extra external extensions */ |
| 19 | char *staticlinkmodules[] = { |
| 20 | "DynaLoader", |
| 21 | NULL, |
| 22 | }; |
| 23 | |
| 24 | EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv); |
| 25 | |
| 26 | static void |
| 27 | xs_init(pTHXo) |
| 28 | { |
| 29 | char *file = __FILE__; |
| 30 | dXSUB_SYS; |
| 31 | newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); |
| 32 | } |
| 33 | |
| 34 | #ifdef PERL_IMPLICIT_SYS |
| 35 | |
| 36 | #include "perlhost.h" |
| 37 | |
| 38 | EXTERN_C void |
| 39 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, |
| 40 | struct IPerlMemInfo* perlMemSharedInfo, |
| 41 | struct IPerlMemInfo* perlMemParseInfo, |
| 42 | struct IPerlEnvInfo* perlEnvInfo, |
| 43 | struct IPerlStdIOInfo* perlStdIOInfo, |
| 44 | struct IPerlLIOInfo* perlLIOInfo, |
| 45 | struct IPerlDirInfo* perlDirInfo, |
| 46 | struct IPerlSockInfo* perlSockInfo, |
| 47 | struct IPerlProcInfo* perlProcInfo) |
| 48 | { |
| 49 | if (perlMemInfo) { |
| 50 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
| 51 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 52 | } |
| 53 | if (perlMemSharedInfo) { |
| 54 | Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); |
| 55 | perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 56 | } |
| 57 | if (perlMemParseInfo) { |
| 58 | Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); |
| 59 | perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 60 | } |
| 61 | if (perlEnvInfo) { |
| 62 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
| 63 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); |
| 64 | } |
| 65 | if (perlStdIOInfo) { |
| 66 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
| 67 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); |
| 68 | } |
| 69 | if (perlLIOInfo) { |
| 70 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
| 71 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); |
| 72 | } |
| 73 | if (perlDirInfo) { |
| 74 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
| 75 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); |
| 76 | } |
| 77 | if (perlSockInfo) { |
| 78 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
| 79 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); |
| 80 | } |
| 81 | if (perlProcInfo) { |
| 82 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
| 83 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); |
| 84 | } |
| 85 | } |
| 86 | |
| 87 | EXTERN_C PerlInterpreter* |
| 88 | perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, |
| 89 | struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, |
| 90 | struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, |
| 91 | struct IPerlDir** ppDir, struct IPerlSock** ppSock, |
| 92 | struct IPerlProc** ppProc) |
| 93 | { |
| 94 | PerlInterpreter *my_perl = NULL; |
| 95 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
| 96 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); |
| 97 | |
| 98 | if (pHost) { |
| 99 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
| 100 | pHost->m_pHostperlMemShared, |
| 101 | pHost->m_pHostperlMemParse, |
| 102 | pHost->m_pHostperlEnv, |
| 103 | pHost->m_pHostperlStdIO, |
| 104 | pHost->m_pHostperlLIO, |
| 105 | pHost->m_pHostperlDir, |
| 106 | pHost->m_pHostperlSock, |
| 107 | pHost->m_pHostperlProc); |
| 108 | if (my_perl) { |
| 109 | #ifdef PERL_OBJECT |
| 110 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 111 | #endif |
| 112 | w32_internal_host = pHost; |
| 113 | } |
| 114 | } |
| 115 | return my_perl; |
| 116 | } |
| 117 | |
| 118 | EXTERN_C PerlInterpreter* |
| 119 | perl_alloc(void) |
| 120 | { |
| 121 | PerlInterpreter* my_perl = NULL; |
| 122 | CPerlHost* pHost = new CPerlHost(); |
| 123 | if (pHost) { |
| 124 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
| 125 | pHost->m_pHostperlMemShared, |
| 126 | pHost->m_pHostperlMemParse, |
| 127 | pHost->m_pHostperlEnv, |
| 128 | pHost->m_pHostperlStdIO, |
| 129 | pHost->m_pHostperlLIO, |
| 130 | pHost->m_pHostperlDir, |
| 131 | pHost->m_pHostperlSock, |
| 132 | pHost->m_pHostperlProc); |
| 133 | if (my_perl) { |
| 134 | #ifdef PERL_OBJECT |
| 135 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 136 | #endif |
| 137 | w32_internal_host = pHost; |
| 138 | } |
| 139 | } |
| 140 | return my_perl; |
| 141 | } |
| 142 | |
| 143 | EXTERN_C void |
| 144 | win32_delete_internal_host(void *h) |
| 145 | { |
| 146 | CPerlHost *host = (CPerlHost*)h; |
| 147 | delete host; |
| 148 | } |
| 149 | |
| 150 | #ifdef PERL_OBJECT |
| 151 | |
| 152 | EXTERN_C void |
| 153 | perl_construct(PerlInterpreter* my_perl) |
| 154 | { |
| 155 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 156 | try |
| 157 | { |
| 158 | Perl_construct(); |
| 159 | } |
| 160 | catch(...) |
| 161 | { |
| 162 | win32_fprintf(stderr, "%s\n", |
| 163 | "Error: Unable to construct data structures"); |
| 164 | perl_free(my_perl); |
| 165 | } |
| 166 | } |
| 167 | |
| 168 | EXTERN_C void |
| 169 | perl_destruct(PerlInterpreter* my_perl) |
| 170 | { |
| 171 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 172 | #ifdef DEBUGGING |
| 173 | Perl_destruct(); |
| 174 | #else |
| 175 | try |
| 176 | { |
| 177 | Perl_destruct(); |
| 178 | } |
| 179 | catch(...) |
| 180 | { |
| 181 | } |
| 182 | #endif |
| 183 | } |
| 184 | |
| 185 | EXTERN_C void |
| 186 | perl_free(PerlInterpreter* my_perl) |
| 187 | { |
| 188 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 189 | void *host = w32_internal_host; |
| 190 | #ifdef DEBUGGING |
| 191 | Perl_free(); |
| 192 | #else |
| 193 | try |
| 194 | { |
| 195 | Perl_free(); |
| 196 | } |
| 197 | catch(...) |
| 198 | { |
| 199 | } |
| 200 | #endif |
| 201 | win32_delete_internal_host(host); |
| 202 | PERL_SET_THX(NULL); |
| 203 | } |
| 204 | |
| 205 | EXTERN_C int |
| 206 | perl_run(PerlInterpreter* my_perl) |
| 207 | { |
| 208 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 209 | int retVal; |
| 210 | #ifdef DEBUGGING |
| 211 | retVal = Perl_run(); |
| 212 | #else |
| 213 | try |
| 214 | { |
| 215 | retVal = Perl_run(); |
| 216 | } |
| 217 | catch(...) |
| 218 | { |
| 219 | win32_fprintf(stderr, "Error: Runtime exception\n"); |
| 220 | retVal = -1; |
| 221 | } |
| 222 | #endif |
| 223 | return retVal; |
| 224 | } |
| 225 | |
| 226 | EXTERN_C int |
| 227 | perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env) |
| 228 | { |
| 229 | int retVal; |
| 230 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 231 | #ifdef DEBUGGING |
| 232 | retVal = Perl_parse(xsinit, argc, argv, env); |
| 233 | #else |
| 234 | try |
| 235 | { |
| 236 | retVal = Perl_parse(xsinit, argc, argv, env); |
| 237 | } |
| 238 | catch(...) |
| 239 | { |
| 240 | win32_fprintf(stderr, "Error: Parse exception\n"); |
| 241 | retVal = -1; |
| 242 | } |
| 243 | #endif |
| 244 | *win32_errno() = 0; |
| 245 | return retVal; |
| 246 | } |
| 247 | |
| 248 | #undef PL_perl_destruct_level |
| 249 | #define PL_perl_destruct_level int dummy |
| 250 | |
| 251 | #endif /* PERL_OBJECT */ |
| 252 | #endif /* PERL_IMPLICIT_SYS */ |
| 253 | |
| 254 | EXTERN_C HANDLE w32_perldll_handle; |
| 255 | |
| 256 | EXTERN_C DllExport int |
| 257 | RunPerl(int argc, char **argv, char **env) |
| 258 | { |
| 259 | int exitstatus; |
| 260 | PerlInterpreter *my_perl, *new_perl = NULL; |
| 261 | |
| 262 | #ifndef __BORLANDC__ |
| 263 | /* XXX this _may_ be a problem on some compilers (e.g. Borland) that |
| 264 | * want to free() argv after main() returns. As luck would have it, |
| 265 | * Borland's CRT does the right thing to argv[0] already. */ |
| 266 | char szModuleName[MAX_PATH]; |
| 267 | char *ptr; |
| 268 | |
| 269 | XCEGetModuleFileNameA(NULL, szModuleName, sizeof(szModuleName)); |
| 270 | (void)win32_longpath(szModuleName); |
| 271 | argv[0] = szModuleName; |
| 272 | #endif |
| 273 | |
| 274 | #ifdef PERL_GLOBAL_STRUCT |
| 275 | #define PERLVAR(var,type) /**/ |
| 276 | #define PERLVARA(var,type) /**/ |
| 277 | #define PERLVARI(var,type,init) PL_Vars.var = init; |
| 278 | #define PERLVARIC(var,type,init) PL_Vars.var = init; |
| 279 | #include "perlvars.h" |
| 280 | #undef PERLVAR |
| 281 | #undef PERLVARA |
| 282 | #undef PERLVARI |
| 283 | #undef PERLVARIC |
| 284 | #endif |
| 285 | |
| 286 | PERL_SYS_INIT(&argc,&argv); |
| 287 | |
| 288 | if (!(my_perl = perl_alloc())) |
| 289 | return (1); |
| 290 | perl_construct(my_perl); |
| 291 | PL_perl_destruct_level = 0; |
| 292 | |
| 293 | exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); |
| 294 | if (!exitstatus) { |
| 295 | #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ |
| 296 | # ifdef PERL_OBJECT |
| 297 | CPerlHost *h = new CPerlHost(); |
| 298 | new_perl = perl_clone_using(my_perl, 1, |
| 299 | h->m_pHostperlMem, |
| 300 | h->m_pHostperlMemShared, |
| 301 | h->m_pHostperlMemParse, |
| 302 | h->m_pHostperlEnv, |
| 303 | h->m_pHostperlStdIO, |
| 304 | h->m_pHostperlLIO, |
| 305 | h->m_pHostperlDir, |
| 306 | h->m_pHostperlSock, |
| 307 | h->m_pHostperlProc |
| 308 | ); |
| 309 | CPerlObj *pPerl = (CPerlObj*)new_perl; |
| 310 | # else |
| 311 | new_perl = perl_clone(my_perl, 1); |
| 312 | # endif |
| 313 | exitstatus = perl_run(new_perl); |
| 314 | PERL_SET_THX(my_perl); |
| 315 | #else |
| 316 | exitstatus = perl_run(my_perl); |
| 317 | #endif |
| 318 | } |
| 319 | |
| 320 | perl_destruct(my_perl); |
| 321 | perl_free(my_perl); |
| 322 | #ifdef USE_ITHREADS |
| 323 | if (new_perl) { |
| 324 | PERL_SET_THX(new_perl); |
| 325 | perl_destruct(new_perl); |
| 326 | perl_free(new_perl); |
| 327 | } |
| 328 | #endif |
| 329 | |
| 330 | PERL_SYS_TERM(); |
| 331 | |
| 332 | return (exitstatus); |
| 333 | } |
| 334 | |
| 335 | EXTERN_C void |
| 336 | set_w32_module_name(void); |
| 337 | |
| 338 | #ifdef __MINGW32__ |
| 339 | EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ |
| 340 | #endif |
| 341 | BOOL APIENTRY |
| 342 | DllMain(HANDLE hModule, /* DLL module handle */ |
| 343 | DWORD fdwReason, /* reason called */ |
| 344 | LPVOID lpvReserved) /* reserved */ |
| 345 | { |
| 346 | switch (fdwReason) { |
| 347 | /* The DLL is attaching to a process due to process |
| 348 | * initialization or a call to LoadLibrary. |
| 349 | */ |
| 350 | case DLL_PROCESS_ATTACH: |
| 351 | /* #define DEFAULT_BINMODE */ |
| 352 | #ifdef DEFAULT_BINMODE |
| 353 | setmode( fileno( stdin ), O_BINARY ); |
| 354 | setmode( fileno( stdout ), O_BINARY ); |
| 355 | setmode( fileno( stderr ), O_BINARY ); |
| 356 | _fmode = O_BINARY; |
| 357 | #endif |
| 358 | |
| 359 | #ifndef UNDER_CE |
| 360 | DisableThreadLibraryCalls((HMODULE)hModule); |
| 361 | #endif |
| 362 | |
| 363 | w32_perldll_handle = hModule; |
| 364 | set_w32_module_name(); |
| 365 | break; |
| 366 | |
| 367 | /* The DLL is detaching from a process due to |
| 368 | * process termination or call to FreeLibrary. |
| 369 | */ |
| 370 | case DLL_PROCESS_DETACH: |
| 371 | break; |
| 372 | |
| 373 | /* The attached process creates a new thread. */ |
| 374 | case DLL_THREAD_ATTACH: |
| 375 | break; |
| 376 | |
| 377 | /* The thread of the attached process terminates. */ |
| 378 | case DLL_THREAD_DETACH: |
| 379 | break; |
| 380 | |
| 381 | default: |
| 382 | break; |
| 383 | } |
| 384 | return TRUE; |
| 385 | } |
| 386 | |
projects / p5sagit/p5-mst-13.2.git / blame