From ba42e43e970a3a2f5299df4f36fb283c7cc9526b Mon Sep 17 00:00:00 2001 From: fvogel Date: Fri, 18 May 2018 06:18:56 +0000 Subject: Add test filesystem-1.30.1 checking file normalize ~$::tcl_platform(user). This test should currently fail when the computer is connected to a Windows domain controller, due to [9e6b569963]: file normalize ~user fails on Windows --- tests/fileSystem.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b805780..edc1df2 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -264,6 +264,9 @@ removeDirectory dir.dir test filesystem-1.30 {normalisation of nonexistent user} -body { file normalize ~noonewiththisname } -returnCodes error -result {user "noonewiththisname" doesn't exist} +test filesystem-1.30.1 {normalisation of existing user} -body { + catch {file normalize ~$::tcl_platform(user)} +} -result {0} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From 423f761169b37ab7bd60fa145f1b2a63c4075db0 Mon Sep 17 00:00:00 2001 From: fvogel Date: Fri, 18 May 2018 19:54:56 +0000 Subject: Fix [9e6b569963]: file normalize ~user fails on Windows --- win/tclWinFile.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 9afe0a9..beab147 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1444,6 +1444,7 @@ TclpGetUserHome( char *domain; WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; WCHAR buf[MAX_PATH]; + LPCWSTR wServername = NULL; Tcl_DStringInit(bufferPtr); wDomain = NULL; @@ -1458,7 +1459,8 @@ TclpGetUserHome( if (badDomain == 0) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - if (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { + NetGetDCName(NULL, wDomain, (LPBYTE *) &wServername); + if (NetUserGetInfo(wServername, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), -- cgit v0.12 From dffe6bc7f17cc047da64213a097fe2f9b3a58865 Mon Sep 17 00:00:00 2001 From: fvogel Date: Sat, 19 May 2018 07:10:43 +0000 Subject: Add test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} --- tests/fileSystem.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index edc1df2..f778112 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -267,6 +267,9 @@ test filesystem-1.30 {normalisation of nonexistent user} -body { test filesystem-1.30.1 {normalisation of existing user} -body { catch {file normalize ~$::tcl_platform(user)} } -result {0} +test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { + file normalize ~nonexistentuser@nonexistentdomain +} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From 36a1a69178cf1667f7ddd31ee00274f9e7709139 Mon Sep 17 00:00:00 2001 From: fvogel Date: Wed, 23 May 2018 21:08:01 +0000 Subject: Add support for ~domain\user style user names, with new test test filesystem-1.30.3. Warning: does not yet work. --- tests/fileSystem.test | 3 +++ win/tclWinFile.c | 18 +++++++++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index f778112..277fcd3 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -270,6 +270,9 @@ test filesystem-1.30.1 {normalisation of existing user} -body { test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { file normalize ~nonexistentuser@nonexistentdomain } -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} +test filesystem-1.30.3 {normalisation of nonexistent user specified as domain\user} -body { + file normalize ~nonexistentdomain\\nonexistentuser +} -returnCodes error -result {user "nonexistentdomain\nonexistentuser" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar diff --git a/win/tclWinFile.c b/win/tclWinFile.c index beab147..b8fb046 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1441,11 +1441,13 @@ TclpGetUserHome( Tcl_DString ds; int nameLen = -1; int badDomain = 0; - char *domain; + char *domain, *user; + const char *nameStart; WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; WCHAR buf[MAX_PATH]; LPCWSTR wServername = NULL; + nameStart = name; Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = strchr(name, '@'); @@ -1455,10 +1457,20 @@ TclpGetUserHome( badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr); Tcl_DStringFree(&ds); nameLen = domain - name; + } else { + user = strchr(name, '\\'); + if (user != NULL) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, user - name, &ds); + badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr); + Tcl_DStringFree(&ds); + nameStart = user + 1; + nameLen = name + strlen(name) - 1 - user; + } } if (badDomain == 0) { Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + wName = Tcl_UtfToUniCharDString(nameStart, nameLen, &ds); NetGetDCName(NULL, wDomain, (LPBYTE *) &wServername); if (NetUserGetInfo(wServername, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; @@ -1477,7 +1489,7 @@ TclpGetUserHome( } Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", -1); - Tcl_DStringAppend(bufferPtr, name, -1); + Tcl_DStringAppend(bufferPtr, nameStart, nameLen); } result = Tcl_DStringValue(bufferPtr); NetApiBufferFree((void *) uiPtr); -- cgit v0.12 From ecec1703aade688299289c4d74bae88a04e04d22 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:12:43 +0000 Subject: win: TclpGetUserHome should return normalized path (also in case we find domain and NetUserGetInfo returns path), PoC: file normalize ~$::tcl_platform(user)@$::env(USERDOMAIN) --- win/tclWinFile.c | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 8fc0b8e..1acc225 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1450,7 +1450,7 @@ TclpGetUserHome( Tcl_DString ds; int nameLen, badDomain; char *domain; - WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; + WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; badDomain = 0; @@ -1461,7 +1461,7 @@ TclpGetUserHome( Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); badDomain = (netGetDCNameProc)(NULL, wName, - (LPBYTE *) wDomainPtr); + (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } @@ -1470,25 +1470,26 @@ TclpGetUserHome( wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); if ((netUserGetInfoProc)(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { + DWORD i, size = MAX_PATH; wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), - bufferPtr); + size = lstrlenW(wHomeDir); + Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); } else { /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ - DWORD i, size = MAX_PATH; getProfilesDirectoryProc(buf, &size); - for (i = 0; i < size; ++i){ - if (buf[i] == '\\') buf[i] = '/'; - } Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", -1); - Tcl_DStringAppend(bufferPtr, name, -1); + Tcl_DStringAppend(bufferPtr, "/", 1); + Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); + /* be sure we returns normalized path */ + for (i = 0; i < size; ++i){ + if (result[i] == '\\') result[i] = '/'; + } (*netApiBufferFreeProc)((void *) uiPtr); } Tcl_DStringFree(&ds); -- cgit v0.12 From a410c0d8d504868b1dbdcaf70a521859e32327fd Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:20:26 +0000 Subject: fixed typo in winFCmd-12.6.2: unneeded extra-bracket removed --- tests/winFCmd.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 1b2b042..f1f2afa 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -913,7 +913,7 @@ test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp fo } -constraints {win} -body { createfile $::env(TEMP)/td1 {} string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \ - [string tolower [file normalize $::env(TEMP)]/td1]] + [string tolower [file normalize $::env(TEMP)]/td1] } -cleanup { file delete -force -- $::env(TEMP)/td1 } -result 1 -- cgit v0.12 From 1c13d543f4934c33e441ef5c77a592b9822a8823 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:49:12 +0000 Subject: [9e6b569963] win: if user specified without domain (and local user was not found), try to resolve user-home using current domain, so following code's are similar: file normalize ~$::tcl_platform(user)@$::env(USERDOMAIN) file normalize ~$::tcl_platform(user) --- win/tclWinFile.c | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1acc225..a3fad1d 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1446,30 +1446,41 @@ TclpGetUserHome( GetProcAddress(userenvInst, "GetProfilesDirectoryW"); if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) { - USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr; + USER_INFO_1 *uiPtr; Tcl_DString ds; - int nameLen, badDomain; + int nameLen, rc; char *domain; WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; - badDomain = 0; + rc = 0; nameLen = -1; wDomain = NULL; domain = strchr(name, '@'); if (domain != NULL) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - badDomain = (netGetDCNameProc)(NULL, wName, - (LPBYTE *) &wDomain); + rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } - if (badDomain == 0) { + if (rc == 0) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - if ((netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) uiPtrPtr) == 0) { + while ((netUserGetInfoProc)(wDomain, wName, 1, + (LPBYTE *) &uiPtr) != 0) { + /* + * user does not exists - if domain was not specified, + * try again using current domain. + */ + rc = 1; + if (domain != NULL) break; + /* get current domain */ + rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); + if (rc != 0) break; + domain = INT2PTR(-1); /* repeat once */ + } + if (rc == 0) { DWORD i, size = MAX_PATH; wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { -- cgit v0.12 From 6d943ef7b5327ee4ccdf46fecd74ecbb5f75ca73 Mon Sep 17 00:00:00 2001 From: fvogel Date: Thu, 24 May 2018 20:51:45 +0000 Subject: Remove test filesystem-1.30.3, this is unstestable --- tests/fileSystem.test | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 277fcd3..f778112 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -270,9 +270,6 @@ test filesystem-1.30.1 {normalisation of existing user} -body { test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { file normalize ~nonexistentuser@nonexistentdomain } -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} -test filesystem-1.30.3 {normalisation of nonexistent user specified as domain\user} -body { - file normalize ~nonexistentdomain\\nonexistentuser -} -returnCodes error -result {user "nonexistentdomain\nonexistentuser" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From a0290b85c51fde9541564338e5b7908153f0cc96 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:04:27 +0000 Subject: optimized winapi-stubs loading (8.5th only); if user name specified without domain and equals the current user - try safest and fastest way to get current user-home path (without usage of netapi) --- win/tclWinFile.c | 187 ++++++++++++++++++++++++++++++++----------------------- win/tclWinInit.c | 34 ++++++---- win/tclWinInt.h | 2 + 3 files changed, 134 insertions(+), 89 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a3fad1d..3819960 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1422,95 +1422,126 @@ TclpGetUserHome( * name of user's home directory. */ { char *result; - HINSTANCE netapiInst; - HINSTANCE userenvInst; + + static NETAPIBUFFERFREEPROC *netApiBufferFreeProc; + static NETGETDCNAMEPROC *netGetDCNameProc; + static NETUSERGETINFOPROC *netUserGetInfoProc; + static GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; + static int apistubs = 0; result = NULL; Tcl_DStringInit(bufferPtr); - netapiInst = LoadLibraryA("netapi32.dll"); - userenvInst = LoadLibraryA("userenv.dll"); - if (netapiInst != NULL && userenvInst != NULL) { - NETAPIBUFFERFREEPROC *netApiBufferFreeProc; - NETGETDCNAMEPROC *netGetDCNameProc; - NETUSERGETINFOPROC *netUserGetInfoProc; - GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; - - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(netapiInst, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(netapiInst, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(netapiInst, "NetUserGetInfo"); - getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) - GetProcAddress(userenvInst, "GetProfilesDirectoryW"); - if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) { - USER_INFO_1 *uiPtr; - Tcl_DString ds; - int nameLen, rc; - char *domain; - WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; - - rc = 0; - nameLen = -1; - wDomain = NULL; - domain = strchr(name, '@'); - if (domain != NULL) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); - Tcl_DStringFree(&ds); - nameLen = domain - name; + if (!apistubs) { + HINSTANCE handle; + TCL_DECLARE_MUTEX(initializeMutex) + Tcl_MutexLock(&initializeMutex); + + handle = LoadLibraryA("netapi32.dll"); + if (handle) { + netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) + GetProcAddress(handle, "NetApiBufferFree"); + netGetDCNameProc = (NETGETDCNAMEPROC *) + GetProcAddress(handle, "NetGetDCName"); + netUserGetInfoProc = (NETUSERGETINFOPROC *) + GetProcAddress(handle, "NetUserGetInfo"); + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + handle = LoadLibraryA("userenv.dll"); + if (handle) { + getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) + GetProcAddress(handle, "GetProfilesDirectoryW"); + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + + apistubs = -1; + if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) + && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) + ) { + apistubs = 1; + } + Tcl_MutexUnlock(&initializeMutex); + } + + if (apistubs == 1) { + USER_INFO_1 *uiPtr; + Tcl_DString ds; + int nameLen, rc; + char *domain; + WCHAR *wName, *wHomeDir, *wDomain; + WCHAR buf[MAX_PATH]; + + rc = 0; + nameLen = -1; + wDomain = NULL; + domain = strchr(name, '@'); + if (domain == NULL) { + const char *ptr; + + /* no domain - firstly check it's the current user */ + if ( (ptr = TclpGetUserName(&ds)) != NULL + && strcasecmp(name, ptr) == 0 + ) { + /* try safest and fastest way to get current user home */ + ptr = TclGetEnv("HOME", &ds); + if (ptr != NULL) { + Tcl_JoinPath(1, &ptr, bufferPtr); + rc = 1; + result = Tcl_DStringValue(bufferPtr); + } + } + Tcl_DStringFree(&ds); + } else { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); + rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); + Tcl_DStringFree(&ds); + nameLen = domain - name; + } + if (rc == 0) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + while ((netUserGetInfoProc)(wDomain, wName, 1, + (LPBYTE *) &uiPtr) != 0) { + /* + * user does not exists - if domain was not specified, + * try again using current domain. + */ + rc = 1; + if (domain != NULL) break; + /* get current domain */ + rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); + if (rc != 0) break; + domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - while ((netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) &uiPtr) != 0) { - /* - * user does not exists - if domain was not specified, - * try again using current domain. + DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; + if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + size = lstrlenW(wHomeDir); + Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); + } else { + /* + * User exists but has no home dir. Return + * "{GetProfilesDirectory}/". */ - rc = 1; - if (domain != NULL) break; - /* get current domain */ - rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; - domain = INT2PTR(-1); /* repeat once */ + getProfilesDirectoryProc(buf, &size); + Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_DStringAppend(bufferPtr, "/", 1); + Tcl_DStringAppend(bufferPtr, name, nameLen); } - if (rc == 0) { - DWORD i, size = MAX_PATH; - wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - size = lstrlenW(wHomeDir); - Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); - } else { - /* - * User exists but has no home dir. Return - * "{GetProfilesDirectory}/". - */ - getProfilesDirectoryProc(buf, &size); - Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", 1); - Tcl_DStringAppend(bufferPtr, name, nameLen); - } - result = Tcl_DStringValue(bufferPtr); - /* be sure we returns normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; - } - (*netApiBufferFreeProc)((void *) uiPtr); + result = Tcl_DStringValue(bufferPtr); + /* be sure we returns normalized path */ + for (i = 0; i < size; ++i){ + if (result[i] == '\\') result[i] = '/'; } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - (*netApiBufferFreeProc)((void *) wDomain); + (*netApiBufferFreeProc)((void *) uiPtr); } + Tcl_DStringFree(&ds); + } + if (wDomain != NULL) { + (*netApiBufferFreeProc)((void *) wDomain); } - FreeLibrary(userenvInst); - FreeLibrary(netapiInst); } if (result == NULL) { /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 1ba7a31..7fa2b7a 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -532,6 +532,27 @@ Tcl_GetEncodingNameFromEnvironment( return Tcl_DStringValue(bufPtr); } +const char * +TclpGetUserName( + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with + * the name of user. */ +{ + Tcl_DStringInit(bufferPtr); + + if (TclGetEnv("USERNAME", bufferPtr) == NULL) { + WCHAR szUserName[UNLEN+1]; + DWORD cchUserNameLen = UNLEN; + + if (!tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen)) { + return NULL; + } + cchUserNameLen--; + if (tclWinProcs->useWide) cchUserNameLen *= sizeof(WCHAR); + Tcl_WinTCharToUtf((LPTSTR)szUserName, cchUserNameLen, bufferPtr); + } + return Tcl_DStringValue(bufferPtr); +} + /* *--------------------------------------------------------------------------- * @@ -562,8 +583,6 @@ TclpSetVariables( static OSVERSIONINFOW osInfo; static int osInfoInitialized = 0; Tcl_DString ds; - WCHAR szUserName[UNLEN+1]; - DWORD cchUserNameLen = UNLEN; Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); @@ -641,15 +660,8 @@ TclpSetVariables( * Note: cchUserNameLen is number of characters including nul terminator. */ - Tcl_DStringInit(&ds); - if (TclGetEnv("USERNAME", &ds) == NULL) { - if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) { - int cbUserNameLen = cchUserNameLen - 1; - if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds); - } - } - Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), + ptr = TclpGetUserName(&ds); + Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "", TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); } diff --git a/win/tclWinInt.h b/win/tclWinInt.h index ccf48bb..af6619f 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -201,6 +201,8 @@ MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); #endif /* TCL_THREADS */ +MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); + /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT #define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400 -- cgit v0.12 From f4651a56605698bf681e88594e7a97d8acd50fac Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:48:50 +0000 Subject: avoid dual init of stubs (possible race condition, 8.5th only) --- win/tclWinFile.c | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 3819960..2395ae1 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1436,29 +1436,30 @@ TclpGetUserHome( HINSTANCE handle; TCL_DECLARE_MUTEX(initializeMutex) Tcl_MutexLock(&initializeMutex); - - handle = LoadLibraryA("netapi32.dll"); - if (handle) { - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) + if (!apistubs) { + handle = LoadLibraryA("netapi32.dll"); + if (handle) { + netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) GetProcAddress(handle, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) + netGetDCNameProc = (NETGETDCNAMEPROC *) GetProcAddress(handle, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) + netUserGetInfoProc = (NETUSERGETINFOPROC *) GetProcAddress(handle, "NetUserGetInfo"); - Tcl_CreateExitHandler(TclpUnloadFile, handle); - } - handle = LoadLibraryA("userenv.dll"); - if (handle) { - getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + handle = LoadLibraryA("userenv.dll"); + if (handle) { + getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) GetProcAddress(handle, "GetProfilesDirectoryW"); - Tcl_CreateExitHandler(TclpUnloadFile, handle); - } - - apistubs = -1; - if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) - ) { - apistubs = 1; + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + + apistubs = -1; + if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) + && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) + ) { + apistubs = 1; + } } Tcl_MutexUnlock(&initializeMutex); } -- cgit v0.12 From 5e7a1545a61ab4e66c1796ad19343e15cd2cc2ba Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:51:23 +0000 Subject: minor indentation fix (no functional changes) --- win/tclWinFile.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 2395ae1..0bed39e 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1440,17 +1440,17 @@ TclpGetUserHome( handle = LoadLibraryA("netapi32.dll"); if (handle) { netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(handle, "NetApiBufferFree"); + GetProcAddress(handle, "NetApiBufferFree"); netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(handle, "NetGetDCName"); + GetProcAddress(handle, "NetGetDCName"); netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(handle, "NetUserGetInfo"); + GetProcAddress(handle, "NetUserGetInfo"); Tcl_CreateExitHandler(TclpUnloadFile, handle); } handle = LoadLibraryA("userenv.dll"); if (handle) { getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) - GetProcAddress(handle, "GetProfilesDirectoryW"); + GetProcAddress(handle, "GetProfilesDirectoryW"); Tcl_CreateExitHandler(TclpUnloadFile, handle); } -- cgit v0.12 From 35f5b82868924ed2ff75452f99083fe04d3a33ef Mon Sep 17 00:00:00 2001 From: fbonnet Date: Sat, 26 May 2018 11:13:34 +0000 Subject: Fixed test process-7.3 --- tests/process.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/process.test b/tests/process.test index 07c6e6f..b88c50a 100644 --- a/tests/process.test +++ b/tests/process.test @@ -271,7 +271,7 @@ test process-7.2 {abnormal exit} -body { tcl::process purge tcl::process autopurge 1 } -test process-7.3 {child killed} -body { +test process-7.3 {child killed} -constraints {win} -body { tcl::process autopurge 0 set pid [exec [interpreter] $path(exit) -1 &] lindex [tcl::process status -wait $pid] 1 -- cgit v0.12 From bb5d24622ffab4d7e6aaf6dba2086cdc870f8470 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 27 May 2018 14:17:08 +0000 Subject: don't bother to use constraint "threaded", because that's the way we want to build anyway --- tests/async.test | 7 +++---- tests/unixNotfy.test | 9 ++------- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/tests/async.test b/tests/async.test index cb67cc2..6de814b 100644 --- a/tests/async.test +++ b/tests/async.test @@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [::tcl::pkgconfig get threaded] proc async1 {result code} { global aresult acode @@ -149,7 +148,7 @@ test async-3.1 {deleting handlers} testasync { } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] proc nothing {} { @@ -171,7 +170,7 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { @@ -188,7 +187,7 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 18b967f..0bd8c69 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -18,16 +18,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] -# Darwin always uses a threaded notifier -testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" -}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} @@ -38,7 +33,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] -- cgit v0.12 From 6a4d06759ed9c9ac3c94860c9d7b17c076f28b7e Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 28 May 2018 13:13:39 +0000 Subject: win: searching for FQDN in user-name should be utf-8 safe (user-name could contain non-ascii utf-8 chars) --- win/tclWinFile.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0bed39e..3655321 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1468,14 +1468,14 @@ TclpGetUserHome( USER_INFO_1 *uiPtr; Tcl_DString ds; int nameLen, rc; - char *domain; + const char *domain; WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; rc = 0; nameLen = -1; wDomain = NULL; - domain = strchr(name, '@'); + domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; -- cgit v0.12 From 267cdaec036394312cd843ed142d998f7bbee4f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 May 2018 07:23:05 +0000 Subject: One TCL_NORETURN -> TCL_NORETURN1 minor mistake. Make it build when Tcl_SetPanicProc is a macro (normally it isn't) --- generic/tclPanic.c | 3 ++- generic/tclStubInit.c | 1 + win/tclWinFile.c | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b50271b..85b7388 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -24,7 +24,7 @@ */ #if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) -static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; +static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; #else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; #endif @@ -45,6 +45,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5057b05..7ce0758 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -40,6 +40,7 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj diff --git a/win/tclWinFile.c b/win/tclWinFile.c index bd4f13b..a70717e 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -867,6 +867,7 @@ TclpFindExecutable( */ if (argv0 == NULL) { +# undef Tcl_SetPanicProc Tcl_SetPanicProc(tclWinDebugPanic); } -- cgit v0.12 From 63b0fef31a850917cdee0f9d059c51516e4b8593 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 May 2018 07:15:13 +0000 Subject: No longer pass "--enable-threads" to battery-included sub-packages, since it's the default, even when Tcl is built without threads, now. This opens the way (in the future) to remove this option from the sub-packages --- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 51c06e5..e1d7d65 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1759,7 +1759,7 @@ configure-packages: $$i/configure --with-tcl=../.. \ --with-tclinclude=$(GENERIC_DIR) \ $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ - --enable-shared --enable-threads; ) || exit $$?; \ + --enable-shared; ) || exit $$?; \ fi; \ fi; \ fi; \ diff --git a/win/Makefile.in b/win/Makefile.in index d155b8d..bf9ab8c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -774,7 +774,7 @@ packages: if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; \ echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \ - $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \ fi ; \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ -- cgit v0.12 From 5e3ca11761b27133a62ee5cd5e340956c640ca8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 May 2018 07:17:23 +0000 Subject: Neither use --disable-threads on MacOS builds, and don't mention it any more in the README --- macosx/GNUmakefile | 2 +- macosx/Tcl-Common.xcconfig | 2 +- unix/README | 2 -- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 1d26a7a..43f8419 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -132,7 +132,7 @@ ${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \ mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \ if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \ --prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \ - --mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \ + --mandir="${MANDIR}" --enable-framework --enable-dtrace \ ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi build-${PROJECT}: ${objdir}/Makefile diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 77402b7..0670479 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -30,7 +30,7 @@ MANDIR = $(PREFIX)/man PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local -TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace +TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H diff --git a/unix/README b/unix/README index d8f1090..381cbdd 100644 --- a/unix/README +++ b/unix/README @@ -45,8 +45,6 @@ How To Compile And Install Tcl: refer to the autoconf documentation (not included here). Tcl's "configure" supports the following special switches in addition to the standard ones: - --enable-threads If this switch is set, Tcl will compile itself - with multithreading support. --disable-load If this switch is specified then Tcl will configure itself not to allow dynamic loading, even if your system appears to support it. -- cgit v0.12