diff options
author | msofer <msofer@noemail.net> | 2008-08-17 14:12:31 (GMT) |
---|---|---|
committer | msofer <msofer@noemail.net> | 2008-08-17 14:12:31 (GMT) |
commit | 577d14786458019195cd2953b8ba15991f7f5dfb (patch) | |
tree | aea585ac64e29663faac8bc607d5b2a1bf36bb44 /generic/tclTest.c | |
parent | 64b7c607c499e7a733bb3f728f74a039fd4fc183 (diff) | |
download | tcl-577d14786458019195cd2953b8ba15991f7f5dfb.zip tcl-577d14786458019195cd2953b8ba15991f7f5dfb.tar.gz tcl-577d14786458019195cd2953b8ba15991f7f5dfb.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 ***
FossilOrigin-Name: 01147b1a842c1c650cc89d0b30bf03bc2423b614
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r-- | generic/tclTest.c | 283 |
1 files changed, 282 insertions, 1 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 7f48903..82fa6ba 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.114 2008/03/14 16:32:52 rmax Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.114.2.1 2008/08/17 14:12:33 msofer Exp $ */ #define TCL_TEST @@ -240,6 +240,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, @@ -597,6 +599,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); @@ -7062,6 +7066,283 @@ TestgetintCmd( } /* + *---------------------------------------------------------------------- + * + * 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 |