summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-08-30 18:15:24 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-08-30 18:15:24 (GMT)
commit54f15bb144abf1e98db0a7bf90f741a93b41eff4 (patch)
tree39ee31674a5a0324d9368289abf06d114660122b
parent9e7d1e52219a5f372c7a0dea6ef24110e03cee81 (diff)
downloadtcl-54f15bb144abf1e98db0a7bf90f741a93b41eff4.zip
tcl-54f15bb144abf1e98db0a7bf90f741a93b41eff4.tar.gz
tcl-54f15bb144abf1e98db0a7bf90f741a93b41eff4.tar.bz2
Fix crash in [string map] when objects are shared. [Bug 1018562]
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclCmdMZ.c26
-rw-r--r--tests/string.test6
3 files changed, 31 insertions, 6 deletions
diff --git a/ChangeLog b/ChangeLog
index 0b2a0ba..9391122 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2004-08-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd): Stop [string map] from
+ crashing when its map and input string are the same object.
+
2004-08-27 Daniel Steffen <das@users.sourceforge.net>
* tests/env.test: macosx fixes.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 09c3853..1bf2183 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.11 2004/03/01 17:33:21 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.12 2004/08/30 18:15:24 dkf Exp $
*/
#include "tclInt.h"
@@ -1857,8 +1857,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_MAP: {
- int mapElemc, nocase = 0;
- Tcl_Obj **mapElemv;
+ int mapElemc, nocase = 0, copySource = 0;
+ Tcl_Obj **mapElemv, *sourceObj;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
@@ -1898,13 +1898,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
- objc--;
- ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
+ /*
+ * Take a copy of the source string object if it is the
+ * same as the map string to cut out nasty sharing
+ * crashes. [Bug 1018562]
+ */
+ if (objv[objc-2] == objv[objc-1]) {
+ sourceObj = Tcl_DuplicateObj(objv[objc-1]);
+ copySource = 1;
+ } else {
+ sourceObj = objv[objc-1];
+ }
+ ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
*/
+ if (copySource) {
+ Tcl_DecrRefCount(sourceObj);
+ }
break;
}
end = ustring1 + length1;
@@ -2024,6 +2037,9 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
+ if (copySource) {
+ Tcl_DecrRefCount(sourceObj);
+ }
break;
}
case STR_MATCH: {
diff --git a/tests/string.test b/tests/string.test
index 6e937f4..a48df1c 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: string.test,v 1.36.2.2 2003/06/09 21:51:56 dgp Exp $
+# RCS: @(#) $Id: string.test,v 1.36.2.3 2004/08/30 18:15:25 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -760,6 +760,10 @@ test string-10.18 {string map, empty argument} {
test string-10.19 {string map, empty arguments} {
string map -nocase {{} abc f bar {} def} foo
} baroo
+test string-10.20 {string map, nasty sharing crash from [Bug 1018562]} {
+ set a {a b}
+ string map $a $a
+} {b b}
test string-11.1 {string match, too few args} {
list [catch {string match a} msg] $msg