* generic/tclIORTrans.c (ReflectInput, ReflectOutput,

	ReflectSeekWide): [Bug 2921116]: Added missing TclEventuallyFree
	calls for preserved ReflectedTransform* structures. Reworked
	ReflectInput to preserve the structure for its whole life, not
	only in InvokeTclMethod.

	* generic/tclIO.c (Tcl_GetsObj): [Bug 2921116]: Regenerate
	topChan, may have been changed by a self-modifying transformation.

	* tests/ioTrans/test (iortrans-4.8, iortrans-4.9, iortrans-5.11,
	iortrans-7.4, iortrans-8.3): New test cases.

4 files changed, 170 insertions, 23 deletions

diff --git a/ChangeLog b/ChangeLog
index c3b44bf8..b260099 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,17 @@
+2010-03-17  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclIORTrans.c (ReflectInput, ReflectOutput,
+	ReflectSeekWide): [Bug 2921116]: Added missing TclEventuallyFree
+	calls for preserved ReflectedTransform* structures. Reworked
+	ReflectInput to preserve the structure for its whole life, not
+	only in InvokeTclMethod.
+
+	* generic/tclIO.c (Tcl_GetsObj): [Bug 2921116]: Regenerate
+	topChan, may have been changed by a self-modifying transformation.
+
+	* tests/ioTrans/test (iortrans-4.8, iortrans-4.9, iortrans-5.11,
+	iortrans-7.4, iortrans-8.3): New test cases.
+
 2010-03-16  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* compat/zlib/*           Upgrade zlib to version 1.2.4
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7ed714c..bc94bb6 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.c,v 1.172 2010/02/24 10:45:04 dkf Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.173 2010/03/17 16:35:42 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -4715,6 +4715,13 @@ Tcl_GetsObj(
      */
 
   gotEOL:
+    /*
+     * Regenerate the top channel, in case it was changed due to
+     * self-modifying reflected transforms.
+     */
+
+    chanPtr = statePtr->topChanPtr;
+
     bufPtr = gs.bufPtr;
     if (bufPtr == NULL) {
 	Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL");
@@ -4743,6 +4750,13 @@ Tcl_GetsObj(
      */
 
   restore:
+    /*
+     * Regenerate the top channel, in case it was changed due to
+     * self-modifying reflected transforms.
+     */
+
+    chanPtr = statePtr->topChanPtr;
+
     bufPtr = statePtr->inQueueHead;
     if (bufPtr == NULL) {
 	Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");
@@ -4778,6 +4792,13 @@ Tcl_GetsObj(
      */
 
   done:
+    /*
+     * Regenerate the top channel, in case it was changed due to
+     * self-modifying reflected transforms.
+     */
+
+    chanPtr = statePtr->topChanPtr;
+
     UpdateInterest(chanPtr);
     return copiedTotal;
 }
@@ -5776,6 +5797,13 @@ DoReadChars(
      */
 
   done:
+    /*
+     * Regenerate the top channel, in case it was changed due to
+     * self-modifying reflected transforms.
+     */
+
+    chanPtr = statePtr->topChanPtr;
+
     UpdateInterest(chanPtr);
     return copied;
 }
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index eb40ce5..801f5fb 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIORTrans.c,v 1.14 2010/03/05 22:50:32 dkf Exp $
+ * RCS: @(#) $Id: tclIORTrans.c,v 1.15 2010/03/17 16:35:42 andreas_kupries Exp $
  */
 
 #include <tclInt.h>
@@ -721,7 +721,7 @@ TclChanPushObjCmd(
      * structure.
      */
 
-    FreeReflectedTransform(rtPtr);
+    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
     return TCL_ERROR;
 
 #undef CHAN
@@ -931,7 +931,7 @@ ReflectClose(
 	}
 #endif
 
-	FreeReflectedTransform(rtPtr);
+	Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
 	return EOK;
     }
 
@@ -1030,7 +1030,7 @@ ReflectClose(
     }
 #endif
 
-    FreeReflectedTransform(rtPtr);
+    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
     return (result == TCL_OK) ? EOK : EINVAL;
 }
 
@@ -1072,8 +1072,9 @@ ReflectInput(
 	return -1;
     }
 
-    gotBytes = 0;
+    Tcl_Preserve(rtPtr);
 
+    gotBytes = 0;
     while (toRead > 0) {
 	/*
 	 * Loop until the request is satisfied (or no data available from
@@ -1086,7 +1087,7 @@ ReflectInput(
 	gotBytes += copied;
 
 	if (toRead == 0) {
-	    return gotBytes;
+	    goto stop;
 	}
 
 	/*
@@ -1109,10 +1110,10 @@ ReflectInput(
 	    int maxRead = -1;
 
 	    if (!TransformLimit(rtPtr, errorCodePtr, &maxRead)) {
-		return -1;
+		goto error;
 	    }
 	    if (maxRead == 0) {
-		return gotBytes;
+		goto stop;
 	    } else if (maxRead > 0) {
 		if (maxRead < toRead) {
 		    toRead = maxRead;
@@ -1121,7 +1122,7 @@ ReflectInput(
 	}
 
 	if (toRead <= 0) {
-	    return gotBytes;
+	    goto stop;
 	}
 
 	readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead);
@@ -1137,11 +1138,11 @@ ReflectInput(
 		 * we report that instead of the request to re-try.
 		 */
 
-		return gotBytes;
+		goto stop;
 	    }
 
 	    *errorCodePtr = Tcl_GetErrno();
-	    return -1;
+	    goto error;
 	}
 
 	if (readBytes == 0) {
@@ -1162,16 +1163,16 @@ ReflectInput(
 
 		if ((gotBytes == 0) && rtPtr->nonblocking) {
 		    *errorCodePtr = EWOULDBLOCK;
-		    return -1;
+		    goto error;
 		}
-		return gotBytes;
+		goto stop;
 	    } else {
 		/*
 		 * Eof in parent.
 		 */
 
 		if (rtPtr->readIsDrained) {
-		    return gotBytes;
+		    goto stop;
 		}
 
 		/*
@@ -1181,7 +1182,7 @@ ReflectInput(
 
 		if (HAS(rtPtr->methods, METH_DRAIN)) {
 		    if (!TransformDrain(rtPtr, errorCodePtr)) {
-			return -1;
+			goto error;
 		    }
 		}
 
@@ -1190,7 +1191,7 @@ ReflectInput(
 		     * The drain delivered nothing.
 		     */
 
-		    return gotBytes;
+		    goto stop;
 		}
 
 		/*
@@ -1209,11 +1210,17 @@ ReflectInput(
 	 */
 
 	if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) {
-	    return -1;
+	    goto error;
 	}
     } /* while toRead > 0 */
 
+ stop:
+    Tcl_Release(rtPtr);
     return gotBytes;
+
+ error:
+    gotBytes = -1;
+    goto stop;
 }
 
 /*
@@ -1266,6 +1273,8 @@ ReflectOutput(
      * we do when explicitly seeking as well.
      */
 
+    Tcl_Preserve(rtPtr);
+
     if ((rtPtr->methods & FLAG(METH_CLEAR))) {
 	TransformClear(rtPtr);
     }
@@ -1277,10 +1286,12 @@ ReflectOutput(
      */
 
     if (!TransformWrite(rtPtr, errorCodePtr, UCHARP(buf), toWrite)) {
+	Tcl_Release(rtPtr);
 	return -1;
     }
 
     *errorCodePtr = EOK;
+    Tcl_Release(rtPtr);
     return toWrite;
 }
 
@@ -1331,6 +1342,8 @@ ReflectSeekWide(
      * request down and the result back up unchanged.
      */
 
+    Tcl_Preserve(rtPtr);
+
     if (((seekMode != SEEK_CUR) || (offset != 0))
 	    && (HAS(rtPtr->methods, METH_CLEAR)
 	    || HAS(rtPtr->methods, METH_FLUSH))) {
@@ -1353,6 +1366,7 @@ ReflectSeekWide(
 
 	if (HAS(rtPtr->methods, METH_FLUSH)) {
 	    if (!TransformFlush(rtPtr, errorCodePtr, FLUSH_DISCARD)) {
+		Tcl_Release(rtPtr);
 		return -1;
 	    }
 	}
@@ -1382,6 +1396,7 @@ ReflectSeekWide(
     }
 
     *errorCodePtr = EOK;
+    Tcl_Release(rtPtr);
     return curPos;
 }
 
@@ -1971,7 +1986,7 @@ InvokeTclMethod(
      */
 
     sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
-    Tcl_Preserve(rtPtr->interp);
+    Tcl_Preserve(rtPtr);
     result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);
 
     /*
@@ -2016,7 +2031,7 @@ InvokeTclMethod(
 	Tcl_IncrRefCount(resObj);
     }
     Tcl_RestoreInterpState(rtPtr->interp, sr);
-    Tcl_Release(rtPtr->interp);
+    Tcl_Release(rtPtr);
 
     /*
      * Cleanup of the dynamic parts of the command.
@@ -2531,7 +2546,8 @@ ForwardProc(
 	rtmPtr = GetThreadReflectedTransformMap();
 	hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
 	Tcl_DeleteHashEntry(hPtr);
-	FreeReflectedTransform(rtPtr);
+
+	Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
 	break;
 
     case ForwardedInput: {
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index d26789c..7399bfb 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -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: ioTrans.test,v 1.7 2008/07/21 21:12:49 ferrieux Exp $
+# RCS: @(#) $Id: ioTrans.test,v 1.8 2010/03/17 16:35:42 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -41,6 +41,7 @@ set helperscript {
     }
 
     proc note  {item}  {global res; lappend res $item; return}
+    #proc note  {item}  {global res; lappend res $item; puts $item ; flush stdout ; return}
     proc track {}      {upvar args item; note $item; return}
     proc notes {items} {foreach i $items {note $i}}
 
@@ -452,7 +453,41 @@ test iortrans-4.7 {chan read, level is squashed} -match glob -body {
     set res
 } -result {{read rt* {test data
 }} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
-
+test iortrans-4.8 {chan read, read, bug 2921116} -match glob -setup {
+    set res {}
+    proc foo {fd args} {
+	oninit; onfinal; track
+	# Kill and recreate transform while it is operating
+	chan pop  $fd
+	chan push $fd [list foo $fd]
+    }
+    set c [chan push [set c [tempchan]] [list foo $c]]
+} -body {
+    note [read $c]
+    #note [gets $c]
+    set res
+} -cleanup {
+    tempdone
+    rename foo {}
+} -result {{read rt* {test data
+}} file*}
+test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup {
+    set res {}
+    proc foo {fd args} {
+	oninit; onfinal; track
+	# Kill and recreate transform while it is operating
+	chan pop  $fd
+	chan push $fd [list foo $fd]
+    }
+    set c [chan push [set c [tempchan]] [list foo $c]]
+} -body {
+    note [gets $c]
+    set res
+} -cleanup {
+    tempdone
+    rename foo {}
+} -result {{read rt* {test data
+}} file*}
 
 # --- === *** ###########################
 # method write (via puts)
@@ -560,6 +595,28 @@ test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -bod
     rename foo {}
     set res
 } -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
+test iortrans-5.11 {chan write, bug 2921116} -match glob -setup {
+    set res {}
+    set level 0
+    proc foo {fd args} {
+	oninit; onfinal; track
+	# pop - invokes flush - invokes 'foo write' - infinite recursion - stop it
+	global level
+	if {$level} { return "" }
+	incr level
+	# Kill and recreate transform while it is operating
+	chan pop  $fd
+	chan push $fd [list foo $fd]
+    }
+    set c [chan push [set c [tempchan]] [list foo $c]]
+} -body {
+    note [puts -nonewline $c abcdef]
+    note [flush $c]
+    set res
+} -cleanup {
+    tempdone
+    rename foo {}
+} -result {{} {write rt* abcdef} {write rt* abcdef} {}}
 
 # --- === *** ###########################
 # method limit?, drain (via read)
@@ -631,6 +688,22 @@ test iortrans-7.3 {clear, any result is ignored} -match glob -body {
     rename foo {}
     set res
 } -result {{clear rt*}}
+test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup {
+    set res {}
+    proc foo {fd args} {
+	oninit clear; onfinal; track
+	# Kill and recreate transform while it is operating
+	chan pop  $fd
+	chan push $fd [list foo $fd]
+    }
+    set c [chan push [set c [tempchan]] [list foo $c]]
+} -body {
+    seek $c 2
+    set res
+} -cleanup {
+    tempdone
+    rename foo {}
+} -result {{clear rt*}}
 
 # --- === *** ###########################
 # method flush (via seek, close)
@@ -666,6 +739,22 @@ test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
     set res
 } -result {{flush rt*} {finalize rt*} .flushed.}
 
+test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup {
+    set res {}
+    proc foo {fd args} {
+	oninit flush; onfinal; track
+	# Kill and recreate transform while it is operating
+	chan pop  $fd
+	chan push $fd [list foo $fd]
+    }
+    set c [chan push [set c [tempchan]] [list foo $c]]
+} -body {
+    seek $c 2
+    set res
+} -cleanup {
+    tempdone
+    rename foo {}
+} -result {{flush rt*}}
 
 # --- === *** ###########################
 # method watch - removed from TIP (rev 1.12+)