X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fperllib.c;h=f38dfa1fd6c87dfd10938bdf14b6deed2b0eb4ed;hb=abec23e71b5d54dc73752d78864a1da13b1510e0;hp=45d64d394cb1211749f3c511be59147c0ffbbe39;hpb=3e3baf6d63945cb64e829d6e5c70a7d00f3d3d03;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/perllib.c b/win32/perllib.c index 45d64d3..f38dfa1 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1,59 +1,233 @@ /* * "The Road goes ever on and on, down from the door where it began." */ - -#ifdef __cplusplus -extern "C" { -#endif - +#define PERLIO_NOT_STDIO 0 #include "EXTERN.h" #include "perl.h" + #include "XSUB.h" -#ifdef __cplusplus +#ifdef PERL_IMPLICIT_SYS +#include "win32iop.h" +#include +#endif /* PERL_IMPLICIT_SYS */ + + +/* Register any extra external extensions */ +char *staticlinkmodules[] = { + "DynaLoader", + NULL, +}; + +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + +static void +xs_init(pTHX) +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } -# define EXTERN_C extern "C" -#else -# define EXTERN_C extern -#endif -static void xs_init _((void)); +#ifdef PERL_IMPLICIT_SYS + +#include "perlhost.h" -__declspec(dllexport) int -RunPerl(int argc, char **argv, char **env, void *iosubsystem) +void +win32_checkTLS(PerlInterpreter *host_perl) +{ + dTHX; + if (host_perl != my_perl) { + int *nowhere = NULL; + *nowhere = 0; + abort(); + } +} + +EXTERN_C void +perl_get_host_info(struct IPerlMemInfo* perlMemInfo, + struct IPerlMemInfo* perlMemSharedInfo, + struct IPerlMemInfo* perlMemParseInfo, + struct IPerlEnvInfo* perlEnvInfo, + struct IPerlStdIOInfo* perlStdIOInfo, + struct IPerlLIOInfo* perlLIOInfo, + struct IPerlDirInfo* perlDirInfo, + struct IPerlSockInfo* perlSockInfo, + struct IPerlProcInfo* perlProcInfo) +{ + if (perlMemInfo) { + Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); + perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + } + if (perlMemSharedInfo) { + Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); + perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + } + if (perlMemParseInfo) { + Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); + perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + } + if (perlEnvInfo) { + Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); + perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); + } + if (perlStdIOInfo) { + Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); + perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); + } + if (perlLIOInfo) { + Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); + perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); + } + if (perlDirInfo) { + Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); + perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); + } + if (perlSockInfo) { + Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); + perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); + } + if (perlProcInfo) { + Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); + perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); + } +} + +EXTERN_C PerlInterpreter* +perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) +{ + PerlInterpreter *my_perl = NULL; + CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, + ppStdIO, ppLIO, ppDir, ppSock, ppProc); + + if (pHost) { + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + w32_internal_host = pHost; + pHost->host_perl = my_perl; + } + } + return my_perl; +} + +EXTERN_C PerlInterpreter* +perl_alloc(void) +{ + PerlInterpreter* my_perl = NULL; + CPerlHost* pHost = new CPerlHost(); + if (pHost) { + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + w32_internal_host = pHost; + pHost->host_perl = my_perl; + } + } + return my_perl; +} + +EXTERN_C void +win32_delete_internal_host(void *h) +{ + CPerlHost *host = (CPerlHost*)h; + delete host; +} + +#endif /* PERL_IMPLICIT_SYS */ + +EXTERN_C HANDLE w32_perldll_handle; + +EXTERN_C DllExport int +RunPerl(int argc, char **argv, char **env) { int exitstatus; - PerlInterpreter *my_perl; - void *pOldIOSubsystem; + PerlInterpreter *my_perl, *new_perl = NULL; - pOldIOSubsystem = SetIOSubSystem(iosubsystem); +#ifndef __BORLANDC__ + /* XXX this _may_ be a problem on some compilers (e.g. Borland) that + * want to free() argv after main() returns. As luck would have it, + * Borland's CRT does the right thing to argv[0] already. */ + char szModuleName[MAX_PATH]; - PERL_SYS_INIT(&argc,&argv); + GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); + (void)win32_longpath(szModuleName); + argv[0] = szModuleName; +#endif - perl_init_i18nl10n(1); +#ifdef PERL_GLOBAL_STRUCT +#define PERLVAR(var,type) /**/ +#define PERLVARA(var,type) /**/ +#define PERLVARI(var,type,init) PL_Vars.var = init; +#define PERLVARIC(var,type,init) PL_Vars.var = init; +#include "perlvars.h" +#undef PERLVAR +#undef PERLVARA +#undef PERLVARI +#undef PERLVARIC +#endif + + PERL_SYS_INIT(&argc,&argv); if (!(my_perl = perl_alloc())) return (1); - perl_construct( my_perl ); - perl_destruct_level = 0; + perl_construct(my_perl); + PL_perl_destruct_level = 0; - exitstatus = perl_parse( my_perl, xs_init, argc, argv, env); + exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { - exitstatus = perl_run( my_perl ); +#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ + new_perl = perl_clone(my_perl, 1); + exitstatus = perl_run(new_perl); + PERL_SET_THX(my_perl); +#else + 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) { + PERL_SET_THX(new_perl); + perl_destruct(new_perl); + perl_free(new_perl); + } +#endif PERL_SYS_TERM(); - SetIOSubSystem(pOldIOSubsystem); - return (exitstatus); } -extern HANDLE PerlDllHandle; +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 */ @@ -71,13 +245,26 @@ DllMain(HANDLE hModule, /* DLL module handle */ setmode( fileno( stderr ), O_BINARY ); _fmode = O_BINARY; #endif - PerlDllHandle = hModule; + 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: + /* 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_ITHREADS) + if (PL_curinterp) + FREE_THREAD_KEY; +#endif break; /* The attached process creates a new thread. */ @@ -94,293 +281,26 @@ DllMain(HANDLE hModule, /* DLL module handle */ return TRUE; } -/* Register any extra external extensions */ - -char *staticlinkmodules[] = { - "DynaLoader", - NULL, -}; - -EXTERN_C void boot_DynaLoader _((CV* cv)); - -static -XS(w32_GetCwd) -{ - dXSARGS; - SV *sv = sv_newmortal(); - /* Make one call with zero size - return value is required size */ - DWORD len = GetCurrentDirectory((DWORD)0,NULL); - SvUPGRADE(sv,SVt_PV); - SvGROW(sv,len); - SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); - /* - * If result != 0 - * then it worked, set PV valid, - * else leave it 'undef' - */ - if (SvCUR(sv)) - SvPOK_on(sv); - EXTEND(sp,1); - ST(0) = sv; - XSRETURN(1); -} - -static -XS(w32_SetCwd) -{ - dXSARGS; - if (items != 1) - croak("usage: Win32::SetCurrentDirectory($cwd)"); - if (SetCurrentDirectory(SvPV(ST(0),na))) - XSRETURN_YES; - - XSRETURN_NO; -} - -static -XS(w32_GetNextAvailDrive) -{ - dXSARGS; - char ix = 'C'; - char root[] = "_:\\"; - while (ix <= 'Z') { - root[0] = ix++; - if (GetDriveType(root) == 1) { - root[2] = '\0'; - XSRETURN_PV(root); - } - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetLastError) -{ - dXSARGS; - XSRETURN_IV(GetLastError()); -} - -static -XS(w32_LoginName) -{ - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - /* size includes NULL */ - ST(0) = sv_2mortal(newSVpv(name,size-1)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -static -XS(w32_NodeName) -{ - dXSARGS; - char name[MAX_COMPUTERNAME_LENGTH+1]; - DWORD size = sizeof(name); - if (GetComputerName(name,&size)) { - /* size does NOT include NULL :-( */ - ST(0) = sv_2mortal(newSVpv(name,size)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - - -static -XS(w32_DomainName) -{ - dXSARGS; - char name[256]; - DWORD size = sizeof(name); - if (GetUserName(name,&size)) { - char sid[1024]; - DWORD sidlen = sizeof(sid); - char dname[256]; - DWORD dnamelen = sizeof(dname); - SID_NAME_USE snu; - if (LookupAccountName(NULL, name, &sid, &sidlen, - dname, &dnamelen, &snu)) { - XSRETURN_PV(dname); /* all that for this */ - } - } - XSRETURN_UNDEF; +#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; + h->host_perl = proto_perl; + return proto_perl; + } - -static -XS(w32_FsType) -{ - dXSARGS; - char fsname[256]; - DWORD flags, filecomplen; - if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { - if (GIMME == G_ARRAY) { - XPUSHs(sv_2mortal(newSVpv(fsname,0))); - XPUSHs(sv_2mortal(newSViv(flags))); - XPUSHs(sv_2mortal(newSViv(filecomplen))); - PUTBACK; - return; - } - XSRETURN_PV(fsname); - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetOSVersion) -{ - dXSARGS; - OSVERSIONINFO osver; - - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if (GetVersionEx(&osver)) { - XPUSHs(newSVpv(osver.szCSDVersion, 0)); - XPUSHs(newSViv(osver.dwMajorVersion)); - XPUSHs(newSViv(osver.dwMinorVersion)); - XPUSHs(newSViv(osver.dwBuildNumber)); - XPUSHs(newSViv(osver.dwPlatformId)); - PUTBACK; - return; - } - XSRETURN_UNDEF; -} - -static -XS(w32_IsWinNT) -{ - dXSARGS; - XSRETURN_IV(IsWinNT()); -} - -static -XS(w32_IsWin95) -{ - dXSARGS; - XSRETURN_IV(IsWin95()); -} - -static -XS(w32_FormatMessage) -{ - dXSARGS; - DWORD source = 0; - char msgbuf[1024]; - - if (items != 1) - croak("usage: Win32::FormatMessage($errno)"); - - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, - &source, SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - XSRETURN_PV(msgbuf); - - XSRETURN_UNDEF; -} - -static -XS(w32_Spawn) -{ - dXSARGS; - char *cmd, *args; - PROCESS_INFORMATION stProcInfo; - STARTUPINFO stStartInfo; - BOOL bSuccess = FALSE; - - if(items != 3) - croak("usage: Win32::Spawn($cmdName, $args, $PID)"); - - cmd = SvPV(ST(0),na); - args = SvPV(ST(1), na); - - memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ - stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ - stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ - stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ - - if(CreateProcess( - cmd, /* Image path */ - args, /* Arguments for command line */ - NULL, /* Default process security */ - NULL, /* Default thread security */ - FALSE, /* Must be TRUE to use std handles */ - NORMAL_PRIORITY_CLASS, /* No special scheduling */ - NULL, /* Inherit our environment block */ - NULL, /* Inherit our currrent directory */ - &stStartInfo, /* -> Startup info */ - &stProcInfo)) /* <- Process info (if OK) */ - { - CloseHandle(stProcInfo.hThread);/* library source code does this. */ - sv_setiv(ST(2), stProcInfo.dwProcessId); - bSuccess = TRUE; - } - XSRETURN_IV(bSuccess); -} - -static -XS(w32_GetTickCount) -{ - dXSARGS; - XSRETURN_IV(GetTickCount()); -} - -static -XS(w32_GetShortPathName) -{ - dXSARGS; - SV *shortpath; - - if(items != 1) - croak("usage: Win32::GetShortPathName($longPathName)"); - - shortpath = sv_mortalcopy(ST(0)); - SvUPGRADE(shortpath, SVt_PV); - /* src == target is allowed */ - if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) - ST(0) = shortpath; - else - ST(0) = &sv_undef; - XSRETURN(1); -} - -static void -xs_init() -{ - char *file = __FILE__; - dXSUB_SYS; - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); - - /* XXX should be removed after checking with Nick */ - newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); - - /* these names are Activeware compatible */ - newXS("Win32::GetCwd", w32_GetCwd, file); - newXS("Win32::SetCwd", w32_SetCwd, file); - newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); - newXS("Win32::GetLastError", w32_GetLastError, file); - newXS("Win32::LoginName", w32_LoginName, file); - newXS("Win32::NodeName", w32_NodeName, file); - newXS("Win32::DomainName", w32_DomainName, file); - newXS("Win32::FsType", w32_FsType, file); - newXS("Win32::GetOSVersion", w32_GetOSVersion, file); - newXS("Win32::IsWinNT", w32_IsWinNT, file); - newXS("Win32::IsWin95", w32_IsWin95, file); - newXS("Win32::FormatMessage", w32_FormatMessage, file); - newXS("Win32::Spawn", w32_Spawn, file); - newXS("Win32::GetTickCount", w32_GetTickCount, file); - newXS("Win32::GetShortPathName", w32_GetShortPathName, file); - - /* XXX Bloat Alert! The following Activeware preloads really - * ought to be part of Win32::Sys::*, so they're not included - * here. - */ - /* LookupAccountName - * LookupAccountSID - * InitiateSystemShutdown - * AbortSystemShutdown - * ExpandEnvrironmentStrings - */ -} - +#endif