From d25403a5a8b4f784566eb15f30b46ed568efc478 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 15 Apr 2014 16:09:28 +0000
Subject: [88aef05cda] Stop reentrancy segfault in reflected channels by
 managing callbacks as (copies of) lists, not shared Tcl_Obj arrays.  Still
 could use cleanup and improvements.

---
 generic/tclIORChan.c | 22 ++++++++++++++++++++--
 tests/ioCmd.test     | 19 +++++++++++++++++++
 2 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index affed02..2d712a2 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -110,6 +110,7 @@ typedef struct {
 				 * plus 4 placeholders for method, channel,
 				 * and at most two varying (method specific)
 				 * words. */
+    Tcl_Obj *cmd;		/*  */
     int methods;		/* Bitmask of supported methods */
 
     /*
@@ -2044,6 +2045,10 @@ NewReflectedChannel(
      */
 
     /* ASSERT: cmdpfxObj is a Tcl List */
+    rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
+    Tcl_ListObjAppendElement(NULL, rcPtr->cmd, Tcl_NewObj());
+    Tcl_ListObjAppendElement(NULL, rcPtr->cmd, handleObj);
+    Tcl_IncrRefCount(rcPtr->cmd);
 
     Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv);
 
@@ -2158,6 +2163,7 @@ FreeReflectedChannel(
      */
 
     Tcl_DecrRefCount(rcPtr->argv[n+1]);
+    Tcl_DecrRefCount(rcPtr->cmd);
 
     ckfree((char*) rcPtr->argv);
     ckfree((char*) rcPtr);
@@ -2200,6 +2206,8 @@ InvokeTclMethod(
     Tcl_InterpState sr;		/* State of handler interp */
     int result;			/* Result code of method invokation */
     Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
+    Tcl_Obj *cmd;
+    int len;
 
     if (!rcPtr->interp) {
 	/*
@@ -2236,6 +2244,11 @@ InvokeTclMethod(
     Tcl_IncrRefCount(methObj);
     rcPtr->argv[rcPtr->argc - 2] = methObj;
 
+    cmd = TclListObjCopy(NULL, rcPtr->cmd);
+    ListObjLength(cmd, len);
+    Tcl_ListObjReplace(NULL, cmd, len - 2, 1, 1, &methObj);
+
+
     /*
      * Append the additional argument containing method specific details
      * behind the channel id. If specified.
@@ -2244,9 +2257,11 @@ InvokeTclMethod(
     cmdc = rcPtr->argc;
     if (argOneObj) {
 	rcPtr->argv[cmdc] = argOneObj;
+	Tcl_ListObjAppendElement(NULL, cmd, argOneObj);
 	cmdc++;
 	if (argTwoObj) {
 	    rcPtr->argv[cmdc] = argTwoObj;
+	    Tcl_ListObjAppendElement(NULL, cmd, argTwoObj);
 	    cmdc++;
 	}
     }
@@ -2256,9 +2271,11 @@ InvokeTclMethod(
      * existing state intact.
      */
 
+    Tcl_IncrRefCount(cmd);
     sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
     Tcl_Preserve(rcPtr->interp);
-    result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);
+//    result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);
+    result = Tcl_GlobalEvalObj(rcPtr->interp, cmd);
 
     /*
      * We do not try to extract the result information if the caller has no
@@ -2284,7 +2301,7 @@ InvokeTclMethod(
 	     */
 
 	    if (result != TCL_ERROR) {
-		Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv);
+//		Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv);
 		int cmdLen;
 		const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
 
@@ -2303,6 +2320,7 @@ InvokeTclMethod(
 	}
 	Tcl_IncrRefCount(resObj);
     }
+    Tcl_DecrRefCount(cmd);
     Tcl_RestoreInterpState(rcPtr->interp, sr);
     Tcl_Release(rcPtr->interp);
 
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index bdf0fb3..f021ade 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -755,6 +755,25 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
     rename foo {}
     set res
 } -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
+test iocmd-21.20 {Bug 88aef05cda} -setup {
+    proc foo {method chan args} {
+	switch -- $method blocking {
+	    chan configure $chan -blocking [lindex $args 0]
+	    return
+	} initialize {
+	    return {initialize finalize watch blocking read write
+		    configure cget cgetall}
+	} finalize {
+	    return
+	}
+    }
+    set ch [chan create {read write} foo]
+} -body {
+    list [catch {chan configure $ch -blocking 0} m] $m
+} -cleanup {
+    close $ch
+    rename foo {}
+} -match glob -result {1 {*nested eval*}}
 
 # --- --- --- --------- --------- ---------
 # Helper commands to record the arguments to handler methods.
-- 
cgit v0.12