summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclTest.c283
-rw-r--r--generic/tclUtil.c8
-rw-r--r--tests/util.test7
4 files changed, 301 insertions, 8 deletions
diff --git a/ChangeLog b/ChangeLog
index 690a0d8..0e863e8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2008-08-17 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclTest.c (TestconcatobjCmd):
+ * generic/tclUtil.c (Tcl_ConcatObj):
+ * tests/util.test (util-4.7):
+ fix [Bug 1447328]; the original "fix" turned Tcl_ConcatObj() into
+ a hairy monster. This was exposed by [Bug 2055782]. Additionally,
+ Tcl_ConcatObj could corrupt its input under certain conditions!
+
+ *** NASTY BUG FIXED ***
+
2008-08-16 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c: better cmdFrame management
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 60f15a8..b2b0265 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.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: tclTest.c,v 1.121 2008/07/31 14:43:48 msofer Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.122 2008/08/17 14:15:25 msofer Exp $
*/
#define TCL_TEST
@@ -210,6 +210,8 @@ static int TestcmdtokenCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestcmdtraceCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestconcatobjCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestcreatecommandCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestdcallCmd(ClientData dummy,
@@ -562,6 +564,8 @@ Tcltest_Init(
NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
(ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
(ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, NULL);
@@ -6572,6 +6576,283 @@ TestNRELevels(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TestconcatobjCmd --
+ *
+ * This procedure implements the "testconcatobj" command. It is used
+ * to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all
+ * cases and thet it never corrupts its arguments. In other words, that
+ * [Bug 1447328] was fixed properly.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestconcatobjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
+ int result = TCL_OK, len;
+ Tcl_Obj *objv[3];
+
+ /*
+ * Set the start of the error message as obj result; it will be cleared at
+ * the end if no errors were found.
+ */
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
+
+ emptyPtr = Tcl_NewObj();
+
+ list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
+ Tcl_ListObjLength(NULL, list1Ptr, &len);
+ TclInvalidateStringRep(list1Ptr);
+
+ list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
+ Tcl_ListObjLength(NULL, list2Ptr, &len);
+ TclInvalidateStringRep(list2Ptr);
+
+ /*
+ * Verify that concat'ing a list obj with one or more empty strings does
+ * return a fresh Tcl_Obj (see also [Bug 2055782]).
+ */
+
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+
+ objv[0] = tmpPtr;
+ objv[1] = emptyPtr;
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (a) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ", NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (b) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ", NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 2:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_DecrRefCount(tmpPtr);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+
+ objv[0] = emptyPtr;
+ objv[1] = tmpPtr;
+ objv[2] = emptyPtr;
+ concatPtr = Tcl_ConcatObj(3, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (c) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ", NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[1] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(3, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (d) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ", NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 2:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_DecrRefCount(tmpPtr);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[1] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ /*
+ * Verify that an unshared list is not corrupted when concat'ing things to
+ * it.
+ */
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (e) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (f) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ Tcl_IncrRefCount(tmpPtr);
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (g) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ Tcl_DecrRefCount(tmpPtr);
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+
+ Tcl_DecrRefCount(list1Ptr);
+ Tcl_DecrRefCount(list2Ptr);
+ Tcl_DecrRefCount(emptyPtr);
+ Tcl_DecrRefCount(tmpPtr);
+
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+ return result;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 480196c..a1a0861 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.98 2008/04/27 22:21:33 dkf Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.99 2008/08/17 14:15:26 msofer Exp $
*/
#include "tclInt.h"
@@ -1197,11 +1197,7 @@ Tcl_ConcatObj(
if (resPtr) {
Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv);
} else {
- if (Tcl_IsShared(objPtr)) {
- resPtr = TclListObjCopy(NULL, objPtr);
- } else {
- resPtr = objPtr;
- }
+ resPtr = TclListObjCopy(NULL, objPtr);
}
}
}
diff --git a/tests/util.test b/tests/util.test
index 8c1ef26..61e0fff 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: util.test,v 1.18 2006/03/21 11:12:29 dkf Exp $
+# RCS: @(#) $Id: util.test,v 1.19 2008/08/17 14:15:26 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -163,6 +163,11 @@ test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} {
# Check for Bug #227512. If this violates C isspace, then it returns \xc3.
concat \xe0
} \xe0
+test util-4.7 {Tcl_ConcatObj - refCount safety} {
+ # Check for Bug #1447328 (actually, bugs in its original "fix"). One of the
+ # symptoms was Bug #2055782.
+ testconcatobj
+} {}
proc Wrapper_Tcl_StringMatch {pattern string} {
# Forces use of Tcl_StringMatch, not Tcl_UniCharCaseMatch
generated by cgit v0.12 at 2024-11-11 11:03:04 (GMT)