From 267c1eb9f4c15531f7bf4095ffb56151ad8f9203 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 29 Apr 2014 17:40:15 +0000 Subject: Make sure no shared ChannelBuffers get recycled. --- generic/tclIO.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 08d0d93..6831c47 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -164,6 +164,7 @@ typedef struct CloseCallback { static ChannelBuffer * AllocChannelBuffer(int length); static void PreserveChannelBuffer(ChannelBuffer *bufPtr); static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); +static int IsShared(ChannelBuffer *bufPtr); static void ChannelTimerProc(ClientData clientData); static int CheckChannelErrors(ChannelState *statePtr, int direction); @@ -2239,6 +2240,13 @@ ReleaseChannelBuffer( } ckfree((char *) bufPtr); } + +static int +IsShared( + ChannelBuffer *bufPtr) +{ + return bufPtr->refCount > 1; +} /* *---------------------------------------------------------------------- @@ -2269,6 +2277,9 @@ RecycleBuffer( /* * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { + mustDiscard = 1; + } if (mustDiscard) { ReleaseChannelBuffer(bufPtr); -- cgit v0.12 From 75c22ad9870b02a3a9b9d213a1d38a1e93a7f7e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:12:37 +0000 Subject: Another segfault demo test, this one with [close] during [gets]. --- tests/ioCmd.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 8bf32d2..d2c0173 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -806,6 +806,22 @@ test iocmd-21.22 {[close] in [read] segfaults} -setup { catch {close $ch} rename foo {} } -match glob -result {*invalid argument*} +test iocmd-21.23 {[close] in [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + gets $ch +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From 1264e873bbaae9d4328826b749e459e88b32e820 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:33:21 +0000 Subject: Panic message to pinpoint the cause of iocmd-21.23 segfault. --- generic/tclIO.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6831c47..0c9db67 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4570,6 +4570,9 @@ FilterInputBytes( } bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; + if (bufPtr == NULL) { + Tcl_Panic("GetInput nuked buffers!"); + } } /* -- cgit v0.12 From 1c909a3352991d577a7164d5bb33dbe8d295ae67 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:54:51 +0000 Subject: Stop the segfaults in [close] during [gets] tests. Not sure this is the right behavior, but it's better than crashing. --- generic/tclIO.c | 23 ++++++++++++++--------- tests/ioCmd.test | 21 +++++++++++++++++++-- 2 files changed, 33 insertions(+), 11 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0c9db67..cd28a0e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4163,12 +4163,12 @@ Tcl_GetsObj( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL"); + if (bufPtr != NULL) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4298,6 +4298,9 @@ TclGetsObjBinary( goto restore; } bufPtr = statePtr->inQueueTail; + if (bufPtr == NULL) { + goto restore; + } } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4410,12 +4413,12 @@ TclGetsObjBinary( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL"); + if (bufPtr) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4571,7 +4574,9 @@ FilterInputBytes( bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; if (bufPtr == NULL) { - Tcl_Panic("GetInput nuked buffers!"); + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; } } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index d2c0173..bb133f9 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -818,10 +818,27 @@ test iocmd-21.23 {[close] in [gets] segfaults} -setup { set ch [chan create read foo] } -body { gets $ch -} -returnCodes error -cleanup { +} -cleanup { catch {close $ch} rename foo {} -} -match glob -result {*invalid argument*} +} -result {} +test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + chan configure $ch -translation binary + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From 10d7a2ac566063ffdd10a932a0d610ae6ecd62dd Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 30 Apr 2014 21:24:39 +0000 Subject: [82e7f67325] Fix an evil refcount problem in compiled [string replace]. --- generic/tclExecute.c | 14 ++++++++++++-- tests/stringComp.test | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2c136d7..4ecca5b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5702,11 +5702,21 @@ TEBCresume( length - toIdx); } } else { - objResultPtr = value3Ptr; + /* + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] + */ + if (toIdx < length) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, length - toIdx); } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + NEXT_INST_F(1, 0, 0); } TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); diff --git a/tests/stringComp.test b/tests/stringComp.test index 9e00ce7..39dac78 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -26,6 +26,22 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} @@ -687,7 +703,23 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} { ## not yet bc ## string replace -## not yet bc +test stringComp-14.1 {Bug 82e7f67325} { + apply {{} { + set a [join {a b} {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} +} {3 3} +test stringComp-14.2 {Bug 82e7f67325} { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {{} { + set a [join {a b} {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} + } +} {0} ## string tolower ## not yet bc -- cgit v0.12 From 7df749abdc0780eb176e6fade94388d60cd8a0ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Apr 2014 21:59:00 +0000 Subject: Better (safer) fix for [0e92c404f1] --- generic/tclCmdMZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6fd468c..d106f53 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2086,7 +2086,7 @@ StringRangeCmd( * Unicode string rep to get the range. */ - if (objv[1]->typePtr == &tclByteArrayType) { + if (objv[1]->typePtr == &tclByteArrayType && (objv[1]->bytes==NULL)) { string = Tcl_GetByteArrayFromObj(objv[1], &length); length--; } else { -- cgit v0.12 From f715c2fad2a69457bbcbdf99167c66a3f62ed3a5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 May 2014 01:15:42 +0000 Subject: missing constraint --- tests/stringComp.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/stringComp.test b/tests/stringComp.test index 39dac78..0d134b5 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -710,7 +710,7 @@ test stringComp-14.1 {Bug 82e7f67325} { lappend b [string length [string replace ___! 0 2 $a[unset a]]] }} } {3 3} -test stringComp-14.2 {Bug 82e7f67325} { +test stringComp-14.2 {Bug 82e7f67325} memory { # As in stringComp-14.1, but make sure we don't retain too many refs leaktest { apply {{} { -- cgit v0.12 From 1c52941e5f67f7f374dbc110234bf18a7ac4844a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 May 2014 07:38:27 +0000 Subject: Fix more corner-cases like [0e92c404f19ede5b2eb06e6db27647d3138cc56|0e92c404f1]: The only place where a type of &tclByteArrayType can be trusted is when determining its length, because the character length of a (UTF-8) string is always equal to the byte length of the byte array. --- generic/tclCmdMZ.c | 12 ++++++------ generic/tclExecute.c | 10 +++++----- generic/tclInt.h | 18 ++++++++++++++++++ generic/tclUtil.c | 2 +- 4 files changed, 30 insertions(+), 12 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d106f53..70943e9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1345,7 +1345,7 @@ StringIndexCmd( * Unicode string rep to get the index'th char. */ - if (objv[1]->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(objv[1])) { const unsigned char *string = Tcl_GetByteArrayFromObj(objv[1], &length); @@ -2086,7 +2086,7 @@ StringRangeCmd( * Unicode string rep to get the range. */ - if (objv[1]->typePtr == &tclByteArrayType && (objv[1]->bytes==NULL)) { + if (TclIsPureByteArray(objv[1])) { string = Tcl_GetByteArrayFromObj(objv[1], &length); length--; } else { @@ -2537,8 +2537,8 @@ StringEqualCmd( return TCL_OK; } - if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're @@ -2684,8 +2684,8 @@ StringCmpCmd( return TCL_OK; } - if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2e396e8..c4f9836 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4235,8 +4235,8 @@ TclExecuteByteCode( */ iResult = s1len = s2len = 0; - } else if ((valuePtr->typePtr == &tclByteArrayType) - && (value2Ptr->typePtr == &tclByteArrayType)) { + } else if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); iResult = memcmp(s1, s2, @@ -4354,7 +4354,7 @@ TclExecuteByteCode( * use the Unicode string rep to get the index'th char. */ - if (valuePtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(valuePtr)) { bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); } else { /* @@ -4370,7 +4370,7 @@ TclExecuteByteCode( } if ((index >= 0) && (index < length)) { - if (valuePtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj((unsigned char *) (&bytes[index]), 1); } else if (valuePtr->bytes && length == valuePtr->length) { @@ -4422,7 +4422,7 @@ TclExecuteByteCode( ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, length1, ustring2, length2, nocase); - } else if ((valuePtr->typePtr == &tclByteArrayType) && !nocase) { + } else if (TclIsPureByteArray(valuePtr) && !nocase) { unsigned char *string1, *string2; int length1, length2; diff --git a/generic/tclInt.h b/generic/tclInt.h index 00b246b..2353450 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3668,6 +3668,24 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file, /* *---------------------------------------------------------------- + * Macro that encapsulates the logic that determines when it is safe to + * interpret a string as a byte array directly. In summary, the object must be + * a byte array and must not have a string representation (as the operations + * that it is used in are defined on strings, not byte arrays). Theoretically + * it is possible to also be efficient in the case where the object's bytes + * field is filled by generation from the byte array (c.f. list canonicality) + * but we don't do that at the moment since this is purely about efficiency. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) + +/* + *---------------------------------------------------------------- * Macro used by the Tcl core to compare Unicode strings. On big-endian * systems we can use the more efficient memcmp, but this would not be * lexically correct on little-endian systems. The ANSI C "prototype" for diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5f4cdae..8c6adfe 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2334,7 +2334,7 @@ TclStringMatchObj( udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if ((strObj->typePtr == &tclByteArrayType) && !flags) { + } else if (TclIsPureByteArray(strObj) && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); -- cgit v0.12 From f90303fa441e484833044f364aae0974a6a705d4 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 May 2014 09:11:09 +0000 Subject: make doubly sure that things which should be unshared stay unshared --- tests/stringComp.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/stringComp.test b/tests/stringComp.test index 0d134b5..165ef20 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -704,20 +704,20 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} { ## string replace test stringComp-14.1 {Bug 82e7f67325} { - apply {{} { - set a [join {a b} {}] + apply {x { + set a [join $x {}] lappend b [string length [string replace ___! 0 2 $a]] lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} + }} {a b} } {3 3} test stringComp-14.2 {Bug 82e7f67325} memory { # As in stringComp-14.1, but make sure we don't retain too many refs leaktest { - apply {{} { - set a [join {a b} {}] + apply {x { + set a [join $x {}] lappend b [string length [string replace ___! 0 2 $a]] lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} + }} {a b} } } {0} -- cgit v0.12 From cf5a2fcdb5b8dd834e530641922f7ba5c841553f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 May 2014 14:18:35 +0000 Subject: We must Preserve channels if we're going to use TclChanCaughtErrorBypass() to get error information after channel routines are called (and have possibly called for the channel to go away). --- generic/tclIOCmd.c | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 7e8e91a..b206303 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -177,6 +177,7 @@ Tcl_PutsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -187,6 +188,7 @@ Tcl_PutsObjCmd( goto error; } } + Tcl_Release(chan); return TCL_OK; /* @@ -202,6 +204,7 @@ Tcl_PutsObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } @@ -248,6 +251,7 @@ Tcl_FlushObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -261,8 +265,10 @@ Tcl_FlushObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -295,6 +301,7 @@ Tcl_GetsObjCmd( int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; + int code = TCL_OK; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); @@ -310,6 +317,7 @@ Tcl_GetsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { @@ -329,7 +337,8 @@ Tcl_GetsObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } - return TCL_ERROR; + code = TCL_ERROR; + goto done; } lineLen = -1; } @@ -339,11 +348,12 @@ Tcl_GetsObjCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } - return TCL_OK; + done: + Tcl_Release(chan); + return code; } /* @@ -542,6 +552,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + Tcl_Preserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -555,8 +566,10 @@ Tcl_SeekObjCmd( TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -587,6 +600,7 @@ Tcl_TellObjCmd( { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; + int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -602,6 +616,7 @@ Tcl_TellObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); newLoc = Tcl_Tell(chan); /* @@ -610,7 +625,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + Tcl_Release(chan); + if (code) { return TCL_ERROR; } -- cgit v0.12