merge to bugfix branchfix_win_native_access

5 files changed, 74 insertions, 34 deletions

diff --git a/ChangeLog b/ChangeLog
index 47c37b0..432fae4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2012-02-01  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/AddErrInfo.3: [Bug 3482614]: Documentation nit.
+
+2012-01-26  Don Porter  <dgp@users.sourceforge.net>
+
+	* 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  <nijtmans@users.sf.net>
 
 	* tools/uniClass.tcl:    [Frq 3473670]: Various Unicode-related 
diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index 45a0c41..136a16f 100644
--- a/doc/AddErrInfo.3
+++ b/doc/AddErrInfo.3
@@ -109,7 +109,7 @@ with the value of \fIcode\fR.  The \fB(Tcl_Obj *)\fR returned
 by \fBTcl_GetReturnOptions\fR points to an unshared
 \fBTcl_Obj\fR with reference count of zero.  The dictionary
 may be written to, either adding, removing, or overwriting
-any entries in it, with the need to check for a shared object.
+any entries in it, without the need to check for a shared object.
 .PP
 A typical usage for \fBTcl_GetReturnOptions\fR is to
 retrieve the stack trace when script evaluation returns
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index eb19096..6a26b9f 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] != '/') {
@@ -2537,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__)
diff --git a/library/package.tcl b/library/package.tcl
index dc06641..3831822 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -393,7 +393,7 @@ proc pkg_mkIndex {args} {
 	    break
 	}
 	lappend cmd ::tcl::Pkg::Create -name $name -version $version
-	foreach spec $files($pkg) {
+	foreach spec [lsort -index 0 $files($pkg)] {
 	    foreach {file type procs} $spec {
 		if { $direct } {
 		    set procs {}
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"