From a1a806f280075c02c755f1a453ca462c0db71ce1 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 24 Jan 2012 22:50:46 +0000 Subject: 3475569 Add value-sharing checks before calls that demand unshared arguments. --- generic/tclPathObj.c | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index eb19096..c32202d 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -269,6 +269,14 @@ TclFSNormalizeAbsolutePath( } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { link = Tcl_FSLink(retVal, NULL, 0); + + /* Safety check in case driver caused sharing */ + if (Tcl_IsShared(retVal)) { + TclDecrRefCount(retVal); + retVal = Tcl_DuplicateObj(retVal); + Tcl_IncrRefCount(retVal); + } + if (link != NULL) { /* * Got a link. Need to check if the link is relative @@ -292,11 +300,6 @@ TclFSNormalizeAbsolutePath( break; } } - if (Tcl_IsShared(retVal)) { - TclDecrRefCount(retVal); - retVal = Tcl_DuplicateObj(retVal); - Tcl_IncrRefCount(retVal); - } /* * We want the trailing slash. @@ -312,7 +315,12 @@ TclFSNormalizeAbsolutePath( */ TclDecrRefCount(retVal); - retVal = link; + if (Tcl_IsShared(link)) { + retVal = Tcl_DuplicateObj(link); + TclDecrRefCount(link); + } else { + retVal = link; + } linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* @@ -1073,6 +1081,12 @@ Tcl_FSJoinPath( if (sep != NULL) { separator = TclGetString(sep)[0]; } + /* Safety check in case the VFS driver caused sharing */ + if (Tcl_IsShared(res)) { + TclDecrRefCount(res); + res = Tcl_DuplicateObj(res); + Tcl_IncrRefCount(res); + } } if (length > 0 && ptr[length -1] != '/') { -- cgit v0.12 From 4e5840745fe8bd929f716debb48a26d381fd8023 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 26 Jan 2012 16:14:07 +0000 Subject: Backport more robust stringObj tests. --- tests/stringObj.test | 65 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 26 deletions(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index 1ab3a48..3b25592 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -18,6 +18,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testobj [llength [info commands testobj]] +testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { set t [testobj types] @@ -229,13 +230,15 @@ test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj { [set y] [testobj objtype $x] [testobj objtype $y] } {string string abcdefghijkl abcdefghi string string} -test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} testobj { - set x abcï¿®ghi - set y ®¿ï +test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} { + set x abc\u00ef\u00bf\u00aeghi + testdstring free + testdstring append \u00ae\u00bf\u00ef -1 + set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ - [set y] [testobj objtype $x] [testobj objtype $y] -} {string none abcï¿®ghi®¿ï ®¿ï string none} + [set y] [testobj objtype $x] [testobj objtype $y] +} "string none abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { set x abcï¿®ghi string length $x @@ -244,19 +247,23 @@ test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { } {string abcï¿®ghiabcï¿®ghi string\ abcï¿®ghiabcï¿®ghiabcï¿®ghiabcï¿®ghi\ string} -test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} testobj { +test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} { set x abcdefghi - set y ®¿ï + testdstring free + testdstring append \u00ae\u00bf\u00ef -1 + set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ - [set y] [testobj objtype $x] [testobj objtype $y] -} {string none abcdefghi®¿ï ®¿ï string none} -test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} testobj { + [set y] [testobj objtype $x] [testobj objtype $y] +} "string none abcdefghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" +test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} { set x abcdefghi - set y jkl + testdstring free + testdstring append jkl -1 + set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ - [set y] [testobj objtype $x] [testobj objtype $y] + [set y] [testobj objtype $x] [testobj objtype $y] } {string none abcdefghijkl jkl string none} test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { set x abcdefghi @@ -265,13 +272,15 @@ test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { [append x $x] [testobj objtype $x] } {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\ string} -test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} testobj { - set x abcï¿®ghi - set y jkl +test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} { + set x abc\u00ef\u00bf\u00aeghi + testdstring free + testdstring append jkl -1 + set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ - [set y] [testobj objtype $x] [testobj objtype $y] -} {string none abcï¿®ghijkl jkl string none} + [set y] [testobj objtype $x] [testobj objtype $y] +} "string none abc\u00ef\u00bf\u00aeghijkl jkl string none" test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] set y [expr {4 + 5}] @@ -316,20 +325,24 @@ test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} tes set q } {a b c d e f a ü b å c ï} -test stringObj-10.1 {Tcl_GetRange with all byte-size chars} testobj { - set x "abcdef" +test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring} { + testdstring free + testdstring append abcdef -1 + set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ - [testobj objtype $x] [testobj objtype $y] + [testobj objtype $x] [testobj objtype $y] } [list none bcde string string] -test stringObj-10.2 {Tcl_GetRange with some mixed width chars} testobj { +test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} { # Because this test does not use \uXXXX notation below instead of - # hardcoding the values, it may fail in multibyte locales. However, - # we need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "ï"). I don't know what + # hardcoding the values, it may fail in multibyte locales. However, we + # need to test that the parser produces untyped objects even when there + # are high-ASCII characters in the input (like "ï"). I don't know what # else to do but inline those characters here. - set x "abcïïdef" + testdstring free + testdstring append "abc\u00ef\u00efdef" -1 + set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ - [testobj objtype $x] [testobj objtype $y] + [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { # set x "abcïïdef" -- cgit v0.12 From 108e8a50f4cecebcceafb5aa428bc279fc726260 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 26 Jan 2012 16:26:38 +0000 Subject: yank back debugging code --- generic/tclObj.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index a30ba6e..5c17df2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -384,9 +384,6 @@ typedef struct ResolvedCmdName { void TclInitObjSubsystem(void) { - ObjInitDeletionContext(context); - ObjDeletionLock(context); - Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); @@ -488,9 +485,6 @@ TclFinalizeThreadObjects(void) void TclFinalizeObjects(void) { - ObjInitDeletionContext(context); - ObjDeletionUnlock(context); - Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { Tcl_DeleteHashTable(&typeTable); -- cgit v0.12 From c476140458013d8216208a4ea6f6c8537525fa98 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 26 Jan 2012 16:42:52 +0000 Subject: 3479689 Stop memory corruption when shimmering 0-refCount value to "path" type. --- ChangeLog | 6 ++++++ generic/tclPathObj.c | 3 +++ 2 files changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 47c37b0..263cbfa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-01-26 Don Porter + + * generic/tclPathObj.c: [Bug 3475569]: Add checks for unshared values + before calls demanding them. [Bug 3479689]: Stop memory corruption + when shimmering 0-refCount value to "path" type. + 2012-01-22 Jan Nijtmans * tools/uniClass.tcl: [Frq 3473670]: Various Unicode-related diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index c32202d..6a26b9f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2551,7 +2551,10 @@ SetFsPathFromAny( } Tcl_DStringFree(&temp); } else { + /* Bug 3479689: protect 0-refcount pathPth from getting freed */ + pathPtr->refCount++; transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL); + pathPtr->refCount--; } #if defined(__CYGWIN__) && defined(__WIN32__) -- cgit v0.12