From d49908850f4747e397786cba1c88d3aca348eb36 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sun, 17 Aug 2008 14:15:24 +0000 Subject: * 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 *** --- ChangeLog | 11 +++ generic/tclTest.c | 283 +++++++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclUtil.c | 8 +- tests/util.test | 7 +- 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 + + * 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 * 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 -- cgit v0.12