* 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 ***

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