summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2012-02-01 15:46:18 (GMT)
committerdgp <dgp@users.sourceforge.net>2012-02-01 15:46:18 (GMT)
commit2669f7aa359f52c6ef4c3b7653581d63af47d62c (patch)
tree8432c1bb048503fb7981777d704535b67cf367d1
parent73ae354d31d0f8f9e87e0d0c52d58b258afedd5d (diff)
parent15e829bc91966b284e40edc9d89e54f78a805503 (diff)
downloadtcl-2669f7aa359f52c6ef4c3b7653581d63af47d62c.zip
tcl-2669f7aa359f52c6ef4c3b7653581d63af47d62c.tar.gz
tcl-2669f7aa359f52c6ef4c3b7653581d63af47d62c.tar.bz2
merge to bugfix branchfix_win_native_access
-rw-r--r--ChangeLog10
-rw-r--r--doc/AddErrInfo.32
-rw-r--r--generic/tclPathObj.c29
-rw-r--r--library/package.tcl2
-rw-r--r--tests/stringObj.test65
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"