Fix for [6d4e9d1af5bf5b7d]: Memory leak: SetFsPathFromAny, assisted by the

global literal table, causes a Tcl_Obj to reference itself.

3 files changed, 75 insertions, 0 deletions

diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index b14fd8a..2d73379 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2207,6 +2207,8 @@ SetFsPathFromAny(
     fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath));
 
     if (transPtr == pathPtr) {
+	Tcl_GetStringFromObj(pathPtr, NULL);
+	TclFreeInternalRep(pathPtr);
         transPtr = Tcl_DuplicateObj(pathPtr);
         fsPathPtr->filesystemEpoch = 0;
     } else {
diff --git a/tests/fileName.test b/tests/fileName.test
index 416c419..621dfbf 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -18,6 +18,7 @@ if {"::tcltest" ni [namespace children]} {
 
 ::tcltest::loadTestedCommands
 catch [list package require -exact tcl::test [info patchlevel]]
+source [file join [file dirname [info script]] tcltests.tcl]
 
 testConstraint testsetplatform [llength [info commands testsetplatform]]
 testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
@@ -1609,6 +1610,66 @@ test fileName-20.10 {globbing for special chars} -setup {
     removeFile fileName-20.10 $s
     removeDirectory sub [file home]
 } -result [file home]/sub/fileName-20.10
+
+
+apply [list {} {
+    test fileName-6d4e9d1af5bf5b7d {
+	memory leak in SetFsPathFromAny
+
+	Runs under both a TCL_DEBUG_MEM build and a -DPURIFY build for
+	valgrind, which is useful since Valgrind provides information about the
+	error location, but [memory] doesn't.
+    } -setup {
+	makeFile {puts "In script"} script
+
+	if {[namespace which ::memory] eq {}} {
+	    set memcheckcmd [list ::apply [list script {
+		uplevel 1 $script
+		return 0
+	    } [namespace current]]]
+	} else {
+	    set memcheckcmd ::tcltests::scriptmemcheck
+	}
+    } -body {
+	{*}$memcheckcmd {
+	    set interp [interp create]
+	    interp eval $interp {
+		apply [list {} {
+		    upvar 1 f f 
+
+		    # A unique name so that no internal representation of this
+		    # literal value has been picked up from any other script
+		    # that has alredy been sourced into this interpreter.
+		    set variableUniqueInTheEntireTclCodebase a
+		    set name variableUniqueInTheEntireTclCodebase
+
+		    # give the Tcl_Obj for "var1" an internal representation of
+		    # type 'localVarNameType'.
+		    set $name
+
+		    set f [open variableUniqueInTheEntireTclCodebase w]
+			try {
+				puts $f {some data}
+			} finally {
+				close $f
+			}
+
+		    set f [open variableUniqueInTheEntireTclCodebase]
+			try {
+				read $f
+			} finally {
+				catch {file delete variableUniqueInTheEntireTclCodebase}
+				close $f
+			}
+		} [namespace current]]
+	    }
+	    interp delete $interp
+	}
+    } -result 0
+} [namespace current]]
+    
+
+
 
 # cleanup
 catch {file delete -force C:/globTest}
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index a2251bf..61366a4 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -34,6 +34,18 @@ namespace eval ::tcltests {
     }
 
 
+    # Stolen from dict.test
+    proc scriptmemcheck script {
+	set end [lindex [split [memory info] \n] 3 3]
+	for {set i 0} {$i < 5} {incr i} {
+	    uplevel 1 $script
+	    set tmp $end
+	    set end [lindex [split [memory info] \n] 3 3]
+	}
+	expr {$end - $tmp}
+    }
+
+
     proc tempdir_alternate {} {
 	close [file tempfile tempfile]
 	set tmpdir [file dirname $tempfile]