From 1aa5869ecef3ba22e6cf9dbd3a08725d5c1f4541 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 20 Nov 2018 18:02:32 +0000 Subject: fixes segfault [7a9dc52b29]: unexpected decrement of the ref-count after TclJoinPath --- generic/tclPathObj.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 87ddfb7..5c30bcf 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2515,8 +2515,12 @@ SetFsPathFromAny( pair[0] = transPtr; pair[1] = Tcl_NewStringObj(name+split+1, -1); transPtr = TclJoinPath(2, pair); - TclDecrRefCount(pair[0]); - TclDecrRefCount(pair[1]); + if (transPtr != pair[0]) { + TclDecrRefCount(pair[0]); + } + if (transPtr != pair[1]) { + TclDecrRefCount(pair[1]); + } } } Tcl_DStringFree(&temp); -- cgit v0.12 From 23102369d18f15a160e508c36990054b67c5a446 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 20 Nov 2018 20:11:02 +0000 Subject: refactoring normalize in case of second path starting with tilde (~/~foo) - force second path as relative by join (provide normalize flag for TclJoinPath); test cases extended --- generic/tclPathObj.c | 65 +++++++++++++++++++++++++--------------------------- tests/cmdAH.test | 7 ++++++ 2 files changed, 38 insertions(+), 34 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 5c30bcf..c0e8081 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -821,7 +821,7 @@ GetExtension( *--------------------------------------------------------------------------- */ -Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]); +Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int normalize); Tcl_Obj * Tcl_FSJoinPath( @@ -829,7 +829,7 @@ Tcl_FSJoinPath( * reference count. */ int elements) /* Number of elements to use (-1 = all) */ { - Tcl_Obj *copy, *res; + Tcl_Obj *res; int objc; Tcl_Obj **objv; @@ -838,17 +838,17 @@ Tcl_FSJoinPath( } elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; - copy = TclListObjCopy(NULL, listObj); Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); - res = TclJoinPath(elements, objv); - Tcl_DecrRefCount(copy); + res = TclJoinPath(elements, objv, 0); return res; } Tcl_Obj * TclJoinPath( - int elements, - Tcl_Obj * const objv[]) + int elements, /* Number of elements to use (-1 = all) */ + Tcl_Obj * const objv[], /* Path elements to join */ + int normalize) /* 1 if special normalization case (force second + * path relative) */ { Tcl_Obj *res = NULL; /* Resulting path object (container of join) */ Tcl_Obj *elt; /* Path part (result if returns part of path) */ @@ -875,13 +875,14 @@ TclJoinPath( * to be an absolute path. Added a check for that elt is absolute. */ - if ((i == (elements-2)) && (i == 0) + if ((i == 0) && (elements == 2) && (elt->typePtr == &tclFsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[i+1]; - type = TclGetPathType(tailObj, NULL, NULL, NULL); + type = normalize ? TCL_PATH_RELATIVE : + TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; int len; @@ -953,7 +954,8 @@ TclJoinPath( } strElt = Tcl_GetStringFromObj(elt, &strEltLen); driveNameLength = 0; - type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); + type = (normalize && (i > 0)) ? TCL_PATH_RELATIVE : + TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* * Zero out the current result. @@ -2413,37 +2415,30 @@ SetFsPathFromAny( * Handle tilde substitutions, if needed. */ - if (name[0] == '~') { + if (len && name[0] == '~') { char *expandedUser; Tcl_DString temp; int split; char separator = '/'; + /* + * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. + * split becomes value 1 for '~/...' as well as for '~'. + */ split = FindSplitPos(name, separator); - if (split != len) { - /* - * We have multiple pieces '~user/foo/bar...' - */ - - name[split] = '\0'; - } /* * Do some tilde substitution. */ - if (name[1] == '\0') { + if (split == 1) { /* - * We have just '~' + * We have just '~' (or '~/...') */ const char *dir; Tcl_DString dirString; - if (split != len) { - name[split] = separator; - } - dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { @@ -2461,22 +2456,24 @@ SetFsPathFromAny( * We have a user name '~user' */ + Tcl_DString userName; + + Tcl_DStringInit(&userName); + Tcl_DStringAppend(&userName, name+1, split-1); + expandedUser = Tcl_DStringValue(&userName); + Tcl_DStringInit(&temp); - if (TclpGetUserHome(name+1, &temp) == NULL) { + if (TclpGetUserHome(expandedUser, &temp) == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", name+1, + Tcl_AppendResult(interp, "user \"", expandedUser, "\" doesn't exist", NULL); } + Tcl_DStringFree(&userName); Tcl_DStringFree(&temp); - if (split != len) { - name[split] = separator; - } return TCL_ERROR; } - if (split != len) { - name[split] = separator; - } + Tcl_DStringFree(&userName); } expandedUser = Tcl_DStringValue(&temp); @@ -2514,7 +2511,7 @@ SetFsPathFromAny( pair[0] = transPtr; pair[1] = Tcl_NewStringObj(name+split+1, -1); - transPtr = TclJoinPath(2, pair); + transPtr = TclJoinPath(2, pair, 1); if (transPtr != pair[0]) { TclDecrRefCount(pair[0]); } @@ -2525,7 +2522,7 @@ SetFsPathFromAny( } Tcl_DStringFree(&temp); } else { - transPtr = TclJoinPath(1, &pathPtr); + transPtr = TclJoinPath(1, &pathPtr, 1); } /* diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 6cc8c0f..516505c 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -541,6 +541,13 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {foo\bar} } bar +test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} { + list \ + [file tail {~/~foo}] \ + [file tail {~/test/~foo}] \ + [file tail [file normalize {~/~foo}]] \ + [file tail [file normalize {~/test/~foo}]] +} [lrepeat 4 ./~foo] # rootname -- cgit v0.12 From 0e5ff410218f872fe9ff61301ffa96c489f0d788 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 20 Nov 2018 20:23:22 +0000 Subject: win: fixes case sensitivity of glob test cases (winFile-2.*): current directory can be different as [temporaryDirectory] (if parameter `-tmpdir` specified). --- tests/winFile.test | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/winFile.test b/tests/winFile.test index bfba9cf..d586e06 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -60,13 +60,15 @@ test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { test winFile-2.1 {TclpMatchFiles: case sensitivity} {win} { makeFile {} GlobCapS - set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] + set args [list -nocomplain -tails -directory [temporaryDirectory]] + set result [list [glob {*}$args GlobC*] [glob {*}$args globc*]] removeFile GlobCapS set result } {GlobCapS GlobCapS} test winFile-2.2 {TclpMatchFiles: case sensitivity} {win} { makeFile {} globlower - set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] + set args [list -nocomplain -tails -directory [temporaryDirectory]] + set result [list [glob {*}$args globl*] [glob {*}$args gLOBl*]] removeFile globlower set result } {globlower globlower} -- cgit v0.12 From 8c233c93c1ce27186c71a73472267447eab13f1b Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 20 Nov 2018 20:56:50 +0000 Subject: win: fixed pwd-related test-cases in winPipe.test: several test-cases expect current directory equals [temporaryDirectory] --- tests/winPipe.test | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/tests/winPipe.test b/tests/winPipe.test index 6a02147..70d4843 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -17,9 +17,13 @@ namespace import -force ::tcltest::* unset -nocomplain path -set bindir [file join [pwd] [file dirname [info nameofexecutable]]] +set org_pwd [pwd] +set bindir [file join $org_pwd [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] +# several test-cases here expect current directory == [temporaryDirectory]: +cd [temporaryDirectory] + testConstraint exec [llength [info commands exec]] testConstraint testexcept [llength [info commands testexcept]] testConstraint cat32 [file exists $cat32] @@ -600,4 +604,6 @@ if {[catch {set env(TEMP) $env_temp}]} { file delete big little stdout stderr nothing echoArgs.tcl echoArgs.bat file delete -force [file join [temporaryDirectory] test(Dir)Check] ::tcltest::cleanupTests +# back to original directory: +cd $org_pwd; unset org_pwd return -- cgit v0.12 From e02fb5a67bc4951e4e36007d4ddaaad531846b2b Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 21 Nov 2018 10:00:54 +0000 Subject: win: repair test command "testchmod": correct load module (ADVAPI32 for x86/x64) and fix readonly mask (don't deny DELETE mask, test cleanup should be able to delete entry) --- win/tclWinTest.c | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 73f4e45..7f49b63 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -420,9 +420,11 @@ TestplatformChmod( static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION; + /* don't deny DELETE mask (reset writable only, allow test-cases cleanup) */ static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA - | FILE_WRITE_DATA | DELETE; + | FILE_WRITE_DATA + /* | DELETE */; /* * References to security functions (only available on NT and later). @@ -466,7 +468,10 @@ TestplatformChmod( TCL_DECLARE_MUTEX(initializeMutex) Tcl_MutexLock(&initializeMutex); if (!initialized) { - HMODULE handle = GetModuleHandle(TEXT("ADVAPI")); + HMODULE handle = GetModuleHandle(TEXT("ADVAPI32")); + if (handle == NULL) { + handle = GetModuleHandle(TEXT("ADVAPI")); + } if (handle != NULL) { setNamedSecurityInfoProc = (setNamedSecurityInfoADef) @@ -661,11 +666,13 @@ TestplatformChmod( } /* - * Apply the new ACL. + * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used + * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ if (set_readOnly == acl_readOnly_found || setNamedSecurityInfoProc( - (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, + (LPSTR) nativePath, SE_FILE_OBJECT, + DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; } -- cgit v0.12 From a89cd349f181ad5d291f096086ef4ad632956bc7 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 22 Nov 2018 12:45:04 +0000 Subject: prepare merge: TclJoinPath is in internal API (MODULE_SCOPE) since 8.6 and static (used locally in tclPathObj) in 8.5 --- generic/tclPathObj.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index c0e8081..d8be51a 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -29,6 +29,9 @@ static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, Tcl_Obj *pathPtr); +static Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], + int forceRelative); + /* * Define the 'path' object type, which Tcl uses to represent file paths @@ -821,8 +824,6 @@ GetExtension( *--------------------------------------------------------------------------- */ -Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int normalize); - Tcl_Obj * Tcl_FSJoinPath( Tcl_Obj *listObj, /* Path elements to join, may have a zero @@ -843,12 +844,12 @@ Tcl_FSJoinPath( return res; } -Tcl_Obj * +static Tcl_Obj * TclJoinPath( int elements, /* Number of elements to use (-1 = all) */ Tcl_Obj * const objv[], /* Path elements to join */ - int normalize) /* 1 if special normalization case (force second - * path relative) */ + int forceRelative) /* If non-zero, assume all more paths are + * relative (e. g. simple normalization) */ { Tcl_Obj *res = NULL; /* Resulting path object (container of join) */ Tcl_Obj *elt; /* Path part (result if returns part of path) */ @@ -880,8 +881,8 @@ TclJoinPath( && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[i+1]; - - type = normalize ? TCL_PATH_RELATIVE : + /* if forceRelative - second path is relative */ + type = forceRelative ? TCL_PATH_RELATIVE : TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; @@ -954,7 +955,8 @@ TclJoinPath( } strElt = Tcl_GetStringFromObj(elt, &strEltLen); driveNameLength = 0; - type = (normalize && (i > 0)) ? TCL_PATH_RELATIVE : + /* if forceRelative - all paths excepting first one are relative */ + type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE : TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* -- cgit v0.12 From e4f3ce78e3bd0c816cb0a5377ab66a42f9eb7552 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 22 Nov 2018 12:58:16 +0000 Subject: win/Makefile.in (mingw/gcc toolchains): fixes make mode "tcltest" - added dependencies to build tcl (dlls) also. --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index f197190..b3be22d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -387,7 +387,7 @@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc -tcltest: $(TCLTEST) +tcltest: binaries $(TCLTEST) binaries: @LIBRARIES@ $(TCLSH) -- cgit v0.12