X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fperllib.c;h=6243a79fd3d4ea21dfdc6168db79de7924a3df44;hb=91af766ac8815630662ce7fde84b165de512e80f;hp=26135f864e0edc2e9e1444b188cd70c2f5529b9c;hpb=cb50131aab68ac6dda048612c6e853b8cb08701e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/perllib.c b/win32/perllib.c index 26135f8..6243a79 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1,15 +1,10 @@ /* * "The Road goes ever on and on, down from the door where it began." */ - - +#define PERLIO_NOT_STDIO 0 #include "EXTERN.h" #include "perl.h" -#ifdef PERL_OBJECT -#define NO_XSLOCKS -#endif - #include "XSUB.h" #ifdef PERL_IMPLICIT_SYS @@ -24,10 +19,10 @@ char *staticlinkmodules[] = { NULL, }; -EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv); +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); static void -xs_init(pTHXo) +xs_init(pTHX) { char *file = __FILE__; dXSUB_SYS; @@ -109,9 +104,6 @@ perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, pHost->m_pHostperlSock, pHost->m_pHostperlProc); if (my_perl) { -#ifdef PERL_OBJECT - CPerlObj* pPerl = (CPerlObj*)my_perl; -#endif w32_internal_host = pHost; } } @@ -134,152 +126,28 @@ perl_alloc(void) pHost->m_pHostperlSock, pHost->m_pHostperlProc); if (my_perl) { -#ifdef PERL_OBJECT - CPerlObj* pPerl = (CPerlObj*)my_perl; -#endif w32_internal_host = pHost; } } return my_perl; } -#ifdef PERL_OBJECT - EXTERN_C void -perl_construct(PerlInterpreter* my_perl) +win32_delete_internal_host(void *h) { - CPerlObj* pPerl = (CPerlObj*)my_perl; - try - { - Perl_construct(); - } - catch(...) - { - win32_fprintf(stderr, "%s\n", - "Error: Unable to construct data structures"); - CPerlHost* pHost = (CPerlHost*)w32_internal_host; - Perl_free(); - delete pHost; - SetPerlInterpreter(NULL); - } + CPerlHost *host = (CPerlHost*)h; + delete host; } -EXTERN_C void -perl_destruct(PerlInterpreter* my_perl) -{ - CPerlObj* pPerl = (CPerlObj*)my_perl; -#ifdef DEBUGGING - Perl_destruct(); -#else - try - { - Perl_destruct(); - } - catch(...) - { - } -#endif -} - -EXTERN_C void -perl_free(PerlInterpreter* my_perl) -{ - CPerlObj* pPerl = (CPerlObj*)my_perl; -#ifdef DEBUGGING - CPerlHost* pHost = (CPerlHost*)w32_internal_host; - Perl_free(); - delete pHost; -#else - try - { - CPerlHost* pHost = (CPerlHost*)w32_internal_host; - Perl_free(); - delete pHost; - } - catch(...) - { - } -#endif - SetPerlInterpreter(NULL); -} - -EXTERN_C int -perl_run(PerlInterpreter* my_perl) -{ - CPerlObj* pPerl = (CPerlObj*)my_perl; -#ifdef DEBUGGING - return Perl_run(); -#else - int retVal; - try - { - retVal = Perl_run(); - } - catch(...) - { - win32_fprintf(stderr, "Error: Runtime exception\n"); - retVal = -1; - } - return retVal; -#endif -} - -EXTERN_C int -perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env) -{ - int retVal; - CPerlObj* pPerl = (CPerlObj*)my_perl; -#ifdef DEBUGGING - retVal = Perl_parse(xsinit, argc, argv, env); -#else - try - { - retVal = Perl_parse(xsinit, argc, argv, env); - } - catch(...) - { - win32_fprintf(stderr, "Error: Parse exception\n"); - retVal = -1; - } -#endif - *win32_errno() = 0; - return retVal; -} - -#undef PL_perl_destruct_level -#define PL_perl_destruct_level int dummy - -#endif /* PERL_OBJECT */ #endif /* PERL_IMPLICIT_SYS */ EXTERN_C HANDLE w32_perldll_handle; -static DWORD g_TlsAllocIndex; - -EXTERN_C DllExport bool -SetPerlInterpreter(void *interp) -{ - DWORD dwErr = GetLastError(); - bool bResult = TlsSetValue(g_TlsAllocIndex, interp); - SetLastError(dwErr); - return bResult; -} - -EXTERN_C DllExport void* -GetPerlInterpreter(void) -{ - DWORD dwErr = GetLastError(); - LPVOID pResult = TlsGetValue(g_TlsAllocIndex); - SetLastError(dwErr); - return pResult; -} - EXTERN_C DllExport int RunPerl(int argc, char **argv, char **env) { int exitstatus; PerlInterpreter *my_perl, *new_perl = NULL; - struct perl_thread *thr; #ifndef __BORLANDC__ /* XXX this _may_ be a problem on some compilers (e.g. Borland) that @@ -309,41 +177,25 @@ RunPerl(int argc, char **argv, char **env) if (!(my_perl = perl_alloc())) return (1); - perl_construct( my_perl ); + perl_construct(my_perl); PL_perl_destruct_level = 0; exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ -# ifdef PERL_OBJECT - CPerlHost *h = new CPerlHost(); - new_perl = perl_clone_using(my_perl, 1, - h->m_pHostperlMem, - h->m_pHostperlMemShared, - h->m_pHostperlMemParse, - h->m_pHostperlEnv, - h->m_pHostperlStdIO, - h->m_pHostperlLIO, - h->m_pHostperlDir, - h->m_pHostperlSock, - h->m_pHostperlProc - ); - CPerlObj *pPerl = (CPerlObj*)new_perl; -# else new_perl = perl_clone(my_perl, 1); -# endif - exitstatus = perl_run( new_perl ); - SetPerlInterpreter(my_perl); + exitstatus = perl_run(new_perl); + PERL_SET_THX(my_perl); #else - exitstatus = perl_run( my_perl ); + exitstatus = perl_run(my_perl); #endif } - perl_destruct( my_perl ); - perl_free( my_perl ); + perl_destruct(my_perl); + perl_free(my_perl); #ifdef USE_ITHREADS if (new_perl) { - SetPerlInterpreter(new_perl); + PERL_SET_THX(new_perl); perl_destruct(new_perl); perl_free(new_perl); } @@ -354,6 +206,16 @@ RunPerl(int argc, char **argv, char **env) return (exitstatus); } +EXTERN_C void +set_w32_module_name(void); + +EXTERN_C void +EndSockets(void); + + +#ifdef __MINGW32__ +EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ +#endif BOOL APIENTRY DllMain(HANDLE hModule, /* DLL module handle */ DWORD fdwReason, /* reason called */ @@ -371,16 +233,26 @@ DllMain(HANDLE hModule, /* DLL module handle */ setmode( fileno( stderr ), O_BINARY ); _fmode = O_BINARY; #endif - g_TlsAllocIndex = TlsAlloc(); DisableThreadLibraryCalls((HMODULE)hModule); w32_perldll_handle = hModule; + set_w32_module_name(); break; /* The DLL is detaching from a process due to * process termination or call to FreeLibrary. */ case DLL_PROCESS_DETACH: - TlsFree(g_TlsAllocIndex); + /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() + anything here had better be harmless if: + A. Not called at all. + B. Called after memory allocation for Heap has been forcibly removed by OS. + PerlIO_cleanup() was done here but fails (B). + */ + EndSockets(); +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + if (PL_curinterp) + FREE_THREAD_KEY; +#endif break; /* The attached process creates a new thread. */ @@ -396,3 +268,26 @@ DllMain(HANDLE hModule, /* DLL module handle */ } return TRUE; } + +#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) +EXTERN_C PerlInterpreter * +perl_clone_host(PerlInterpreter* proto_perl, UV flags) { + dTHX; + CPerlHost *h; + h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host); + proto_perl = perl_clone_using(proto_perl, flags, + h->m_pHostperlMem, + h->m_pHostperlMemShared, + h->m_pHostperlMemParse, + h->m_pHostperlEnv, + h->m_pHostperlStdIO, + h->m_pHostperlLIO, + h->m_pHostperlDir, + h->m_pHostperlSock, + h->m_pHostperlProc + ); + proto_perl->Isys_intern.internal_host = h; + return proto_perl; + +} +#endif