merge trunk

5 files changed, 127 insertions, 14 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/generic/tclIO.c b/generic/tclIO.c
index 0087526..776ff12 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);
@@ -2311,6 +2312,13 @@ ReleaseChannelBuffer(
     }
     ckfree(bufPtr);
 }
+
+static int
+IsShared(
+    ChannelBuffer *bufPtr)
+{
+    return bufPtr->refCount > 1;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -2341,6 +2349,9 @@ RecycleBuffer(
     /*
      * Do we have to free the buffer to the OS?
      */
+    if (IsShared(bufPtr)) {
+	mustDiscard = 1;
+    }
 
     if (1 || mustDiscard) {
 	ReleaseChannelBuffer(bufPtr);
@@ -4576,12 +4587,12 @@ Tcl_GetsObj(
     chanPtr = statePtr->topChanPtr;
      */
     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);
@@ -4722,6 +4733,9 @@ TclGetsObjBinary(
 		goto restore;
 	    }
 	    bufPtr = statePtr->inQueueTail;
+	    if (bufPtr == NULL) {
+		goto restore;
+	    }
 	}
 
 	dst = (unsigned char *) RemovePoint(bufPtr);
@@ -4834,12 +4848,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);
@@ -4994,6 +5008,11 @@ FilterInputBytes(
 	}
 	bufPtr = statePtr->inQueueTail;
 	gsPtr->bufPtr = bufPtr;
+	if (bufPtr == NULL) {
+	    gsPtr->charsWrote = 0;
+	    gsPtr->rawRead = 0;
+	    return -1;
+	}
     }
 
     /*
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index d5ac64d..14910d7 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -181,6 +181,7 @@ Tcl_PutsObjCmd(
 	return TCL_ERROR;
     }
 
+    Tcl_Preserve(chan);
     result = Tcl_WriteObj(chan, string);
     if (result < 0) {
 	goto error;
@@ -191,6 +192,7 @@ Tcl_PutsObjCmd(
 	    goto error;
 	}
     }
+    Tcl_Release(chan);
     return TCL_OK;
 
     /*
@@ -205,6 +207,7 @@ Tcl_PutsObjCmd(
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
 		TclGetString(chanObjPtr), Tcl_PosixError(interp)));
     }
+    Tcl_Release(chan);
     return TCL_ERROR;
 }
 
@@ -252,6 +255,7 @@ Tcl_FlushObjCmd(
 	return TCL_ERROR;
     }
 
+    Tcl_Preserve(chan);
     if (Tcl_Flush(chan) != TCL_OK) {
 	/*
 	 * TIP #219.
@@ -265,8 +269,10 @@ Tcl_FlushObjCmd(
 		    "error flushing \"%s\": %s",
 		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
 	}
+	Tcl_Release(chan);
 	return TCL_ERROR;
     }
+    Tcl_Release(chan);
     return TCL_OK;
 }
 
@@ -299,6 +305,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?");
@@ -315,6 +322,7 @@ Tcl_GetsObjCmd(
 	return TCL_ERROR;
     }
 
+    Tcl_Preserve(chan);
     linePtr = Tcl_NewObj();
     lineLen = Tcl_GetsObj(chan, linePtr);
     if (lineLen < 0) {
@@ -333,7 +341,8 @@ Tcl_GetsObjCmd(
 			"error reading \"%s\": %s",
 			TclGetString(chanObjPtr), Tcl_PosixError(interp)));
 	    }
-	    return TCL_ERROR;
+	    code = TCL_ERROR;
+	    goto done;
 	}
 	lineLen = -1;
     }
@@ -346,7 +355,9 @@ Tcl_GetsObjCmd(
     } else {
 	Tcl_SetObjResult(interp, linePtr);
     }
-    return TCL_OK;
+  done:
+    Tcl_Release(chan);
+    return code;
 }
 
 /*
@@ -547,6 +558,7 @@ Tcl_SeekObjCmd(
 	mode = modeArray[optionIndex];
     }
 
+    Tcl_Preserve(chan);
     result = Tcl_Seek(chan, offset, mode);
     if (result == Tcl_LongAsWide(-1)) {
 	/*
@@ -561,8 +573,10 @@ Tcl_SeekObjCmd(
 		    "error during seek on \"%s\": %s",
 		    TclGetString(objv[1]), Tcl_PosixError(interp)));
 	}
+	Tcl_Release(chan);
 	return TCL_ERROR;
     }
+    Tcl_Release(chan);
     return TCL_OK;
 }
 
@@ -593,6 +607,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");
@@ -608,6 +623,7 @@ Tcl_TellObjCmd(
 	return TCL_ERROR;
     }
 
+    Tcl_Preserve(chan);
     newLoc = Tcl_Tell(chan);
 
     /*
@@ -616,7 +632,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;
     }
 
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 36339ec..3976d25 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -844,6 +844,39 @@ 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
+} -cleanup {
+    catch {close $ch}
+    rename foo {}
+} -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.
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 9e00ce7..165ef20 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 {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 {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}
 
 ## string tolower
 ## not yet bc