summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-08-17 14:15:24 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-08-17 14:15:24 (GMT)
commitd49908850f4747e397786cba1c88d3aca348eb36 (patch)
treebb2b51fe89b8a3295adbd6dbf7f01e53f4b89469 /generic
parent146f94987b85cac730a1bde68d0e16d6907f79c0 (diff)
downloadtcl-d49908850f4747e397786cba1c88d3aca348eb36.zip
tcl-d49908850f4747e397786cba1c88d3aca348eb36.tar.gz
tcl-d49908850f4747e397786cba1c88d3aca348eb36.tar.bz2
* 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 ***
Diffstat (limited to 'generic')
-rw-r--r--generic/tclTest.c283
-rw-r--r--generic/tclUtil.c8
2 files changed, 284 insertions, 7 deletions
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);
}
}
}