merge 8.7

6 files changed, 349 insertions, 50 deletions

diff --git a/generic/tclIO.c b/generic/tclIO.c
index eec6062..8f3f728 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -97,6 +97,7 @@ typedef struct GetsState {
 typedef struct CopyState {
     struct Channel *readPtr;	/* Pointer to input channel. */
     struct Channel *writePtr;	/* Pointer to output channel. */
+    int refCount;		/* Reference counter. */
     int readFlags;		/* Original read channel flags. */
     int writeFlags;		/* Original write channel flags. */
     Tcl_WideInt toRead;		/* Number of bytes to copy, or -1. */
@@ -222,6 +223,7 @@ static int		StackSetBlockMode(Channel *chanPtr, int mode);
 static int		SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
 			    int mode);
 static void		StopCopy(CopyState *csPtr);
+static void		CopyDecrRefCount(CopyState *csPtr);
 static void		TranslateInputEOL(ChannelState *statePtr, char *dst,
 			    const char *src, int *dstLenPtr, int *srcLenPtr);
 static void		UpdateInterest(Channel *chanPtr);
@@ -2087,7 +2089,7 @@ Tcl_UnstackChannel(
 		return TCL_ERROR;
 	    }
 
-	    statePtr->csPtrR  = csPtrR;
+	    statePtr->csPtrR = csPtrR;
 	    statePtr->csPtrW = csPtrW;
 	}
 
@@ -3017,6 +3019,34 @@ FlushChannel(
     return errorCode;
 }
 
+static void
+FreeChannelState(
+    void *blockPtr)		/* Channel state to free. */
+{
+    ChannelState *statePtr = (ChannelState *)blockPtr;
+    /*
+     * Even after close some members can be filled again (in events etc).
+     * Test in bug [79474c588] illustrates one leak (on remaining chanMsg).
+     * Possible other fields need freeing on some constellations.
+     */
+
+    DiscardInputQueued(statePtr, 1);
+    if (statePtr->curOutPtr != NULL) {
+	ReleaseChannelBuffer(statePtr->curOutPtr);
+    }
+    DiscardOutputQueued(statePtr);
+    
+    DeleteTimerHandler(statePtr);
+
+    if (statePtr->chanMsg) {
+	Tcl_DecrRefCount(statePtr->chanMsg);
+    }
+    if (statePtr->unreportedMsg) {
+	Tcl_DecrRefCount(statePtr->unreportedMsg);
+    }
+    Tcl_Free(statePtr);
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -3181,7 +3211,7 @@ CloseChannel(
 
     ChannelFree(chanPtr);
 
-    Tcl_EventuallyFree(statePtr, TCL_DYNAMIC);
+    Tcl_EventuallyFree(statePtr, FreeChannelState);
 
     return errorCode;
 }
@@ -3989,8 +4019,14 @@ Tcl_ClearChannelHandlers(
      * Cancel any pending copy operation.
      */
 
-    StopCopy(statePtr->csPtrR);
-    StopCopy(statePtr->csPtrW);
+    if (statePtr->csPtrR) {
+	StopCopy(statePtr->csPtrR);
+	statePtr->csPtrR = NULL;
+    }
+    if (statePtr->csPtrW) {
+	StopCopy(statePtr->csPtrW);
+	statePtr->csPtrW = NULL;
+    }
 
     /*
      * Must set the interest mask now to 0, otherwise infinite loops will
@@ -9390,6 +9426,7 @@ TclCopyChannel(
     csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
     csPtr->readPtr = inPtr;
     csPtr->writePtr = outPtr;
+    csPtr->refCount = 2; /* two references below (inStatePtr, outStatePtr) */
     csPtr->readFlags = readFlags;
     csPtr->writeFlags = writeFlags;
     csPtr->toRead = toRead;
@@ -9400,7 +9437,10 @@ TclCopyChannel(
     }
     csPtr->cmdPtr = cmdPtr;
 
-    inStatePtr->csPtrR  = csPtr;
+    TclChannelPreserve(inChan);
+    TclChannelPreserve(outChan);
+
+    inStatePtr->csPtrR = csPtr;
     outStatePtr->csPtrW = csPtr;
 
     if (moveBytes) {
@@ -9414,7 +9454,7 @@ TclCopyChannel(
 
     if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) {
 	Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr);
-	return 0;
+	return TCL_OK;
     }
 
     /*
@@ -9689,6 +9729,8 @@ CopyData(
     int moveBytes;
     int underflow;		/* Input underflow */
 
+    csPtr->refCount++;		/* avoid freeing during handling */
+
     inChan	= (Tcl_Channel) csPtr->readPtr;
     outChan	= (Tcl_Channel) csPtr->writePtr;
     inStatePtr	= csPtr->readPtr->state;
@@ -9833,7 +9875,7 @@ CopyData(
 		    TclDecrRefCount(bufObj);
 		    bufObj = NULL;
 		}
-		return TCL_OK;
+		goto done;
 	    }
 	}
 
@@ -9919,7 +9961,7 @@ CopyData(
 		TclDecrRefCount(bufObj);
 		bufObj = NULL;
 	    }
-	    return TCL_OK;
+	    goto done;
 	}
 
 	/*
@@ -9941,7 +9983,7 @@ CopyData(
 		TclDecrRefCount(bufObj);
 		bufObj = NULL;
 	    }
-	    return TCL_OK;
+	    goto done;
 	}
     } /* while */
 
@@ -9993,6 +10035,9 @@ CopyData(
 	    }
 	}
     }
+
+  done:
+    CopyDecrRefCount(csPtr);
     return result;
 }
 
@@ -10102,8 +10147,6 @@ DoRead(
 	    code = GetInput(chanPtr);
 	    bufPtr = statePtr->inQueueHead;
 
-	    assert(bufPtr != NULL);
-
 	    if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
 		/*
 		 * Further reads cannot do any more.
@@ -10112,20 +10155,21 @@ DoRead(
 		break;
 	    }
 
-	    if (code) {
-		/*
-	     * Read error
-	     */
-
-		UpdateInterest(chanPtr);
-		TclChannelRelease((Tcl_Channel)chanPtr);
-		return -1;
+	    if (code || !bufPtr) {
+		/* Read error (or channel dead/closed) */
+		goto readErr;
 	    }
 
 	    assert(IsBufferFull(bufPtr));
 	}
 
-	assert(bufPtr != NULL);
+	if (!bufPtr) {
+	  readErr:
+
+	    UpdateInterest(chanPtr);
+	    TclChannelRelease((Tcl_Channel)chanPtr);
+	    return -1;
+	}
 
 	bytesRead = BytesLeft(bufPtr);
 	bytesWritten = bytesToRead;
@@ -10367,9 +10411,32 @@ StopCopy(
 	Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
 	Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
 	TclDecrRefCount(csPtr->cmdPtr);
+	csPtr->cmdPtr = NULL;
+    }
+
+    if (inStatePtr->csPtrR) {
+	assert(inStatePtr->csPtrR == csPtr);
+	inStatePtr->csPtrR = NULL;
+	CopyDecrRefCount(csPtr);
+    }
+    if (outStatePtr->csPtrW) {
+	assert(outStatePtr->csPtrW == csPtr);
+	outStatePtr->csPtrW = NULL;
+	CopyDecrRefCount(csPtr);
     }
-    inStatePtr->csPtrR = NULL;
-    outStatePtr->csPtrW = NULL;
+}
+
+static void
+CopyDecrRefCount(
+    CopyState *csPtr)
+{
+    if (csPtr->refCount-- > 1) {
+	return;
+    }
+
+    TclChannelRelease((Tcl_Channel)csPtr->readPtr);
+    TclChannelRelease((Tcl_Channel)csPtr->writePtr);
+
     Tcl_Free(csPtr);
 }
 
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 0118ce0..712b67a 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -2311,23 +2311,37 @@ NextHandle(void)
     return resObj;
 }
 
-static void
-FreeReflectedChannel(
-    void *blockPtr)
+static inline void
+CleanRefChannelInstance(
+    ReflectedChannel *rcPtr)
 {
-    ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr;
-    Channel *chanPtr = (Channel *) rcPtr->chan;
-
-    TclChannelRelease((Tcl_Channel)chanPtr);
     if (rcPtr->name) {
+	/* 
+	 * Reset obj-type (channel is deleted or dead anyway) to avoid leakage
+	 * by cyclic references (see bug [79474c58800cdf94]).
+	 */
+	TclFreeInternalRep(rcPtr->name);
 	Tcl_DecrRefCount(rcPtr->name);
+	rcPtr->name = NULL;
     }
     if (rcPtr->methods) {
 	Tcl_DecrRefCount(rcPtr->methods);
+	rcPtr->methods = NULL;
     }
     if (rcPtr->cmd) {
 	Tcl_DecrRefCount(rcPtr->cmd);
+	rcPtr->cmd = NULL;
     }
+}
+static void
+FreeReflectedChannel(
+    void *blockPtr)
+{
+    ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr;
+    Channel *chanPtr = (Channel *) rcPtr->chan;
+
+    TclChannelRelease((Tcl_Channel)chanPtr);
+    CleanRefChannelInstance(rcPtr);
     Tcl_Free(rcPtr);
 }
 
@@ -2597,18 +2611,7 @@ MarkDead(
     if (rcPtr->dead) {
 	return;
     }
-    if (rcPtr->name) {
-	Tcl_DecrRefCount(rcPtr->name);
-	rcPtr->name = NULL;
-    }
-    if (rcPtr->methods) {
-	Tcl_DecrRefCount(rcPtr->methods);
-	rcPtr->methods = NULL;
-    }
-    if (rcPtr->cmd) {
-	Tcl_DecrRefCount(rcPtr->cmd);
-	rcPtr->cmd = NULL;
-    }
+    CleanRefChannelInstance(rcPtr);
     rcPtr->dead = 1;
 }
 
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 46ee8be..f13aa99 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -1073,15 +1073,28 @@ InitCallChain(
     Object *oPtr,
     int flags)
 {
+    /*
+     * Note that it's possible to end up with a NULL oPtr->selfCls here if
+     * there is a call into stereotypical object after it has finished running
+     * its destructor phase. Such things can't be cached for a long time so the
+     * epoch can be bogus. [Bug 7842f33a5c]
+     */
+
     callPtr->flags = flags &
 	    (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
     if (oPtr->flags & USE_CLASS_CACHE) {
-	oPtr = oPtr->selfCls->thisPtr;
+	oPtr = (oPtr->selfCls ? oPtr->selfCls->thisPtr : NULL);
 	callPtr->flags |= USE_CLASS_CACHE;
     }
-    callPtr->epoch = oPtr->fPtr->epoch;
-    callPtr->objectCreationEpoch = oPtr->creationEpoch;
-    callPtr->objectEpoch = oPtr->epoch;
+    if (oPtr) {
+	callPtr->epoch = oPtr->fPtr->epoch;
+	callPtr->objectCreationEpoch = oPtr->creationEpoch;
+	callPtr->objectEpoch = oPtr->epoch;
+    } else {
+	callPtr->epoch = 0;
+	callPtr->objectCreationEpoch = 0;
+	callPtr->objectEpoch = 0;
+    }
     callPtr->refCount = 1;
     callPtr->numChain = 0;
     callPtr->chain = callPtr->staticChain;
@@ -1112,6 +1125,13 @@ IsStillValid(
     int mask)
 {
     if ((oPtr->flags & USE_CLASS_CACHE)) {
+	/*
+	 * If the object is in a weird state (due to stereotype tricks) then
+	 * just declare the cache invalid. [Bug 7842f33a5c]
+	 */
+	if (!oPtr->selfCls) {
+	    return 0;
+	}
 	oPtr = oPtr->selfCls->thisPtr;
 	flags |= USE_CLASS_CACHE;
     }
@@ -1209,8 +1229,16 @@ TclOOGetCallContext(
 	    Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
 	}
 
-	if (oPtr->flags & USE_CLASS_CACHE) {
-	    if (oPtr->selfCls->classChainCache != NULL) {
+	/*
+	 * Note that it's possible to end up with a NULL oPtr->selfCls here if
+	 * there is a call into stereotypical object after it has finished
+	 * running its destructor phase. It's quite a tangle, but at that
+	 * point, we simply can't get stereotypes from the cache.
+	 * [Bug 7842f33a5c]
+	 */
+
+	if (oPtr->flags & USE_CLASS_CACHE && oPtr->selfCls) {
+	    if (oPtr->selfCls->classChainCache) {
 		hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
 			methodNameObj);
 	    } else {
@@ -1424,6 +1452,17 @@ TclOOGetStereotypeCallChain(
     Object obj;
 
     /*
+     * Note that it's possible to end up with a NULL clsPtr here if there is
+     * a call into stereotypical object after it has finished running its
+     * destructor phase. It's quite a tangle, but at that point, we simply
+     * can't get stereotypes. [Bug 7842f33a5c]
+     */
+
+    if (clsPtr == NULL) {
+	return NULL;
+    }
+
+    /*
      * Synthesize a temporary stereotypical object so that we can use existing
      * machinery to produce the stereotypical call chain.
      */
@@ -1650,9 +1689,16 @@ AddPrivatesFromClassChainToCallContext(
      *
      * Note that mixins must be processed before the main class hierarchy.
      * [Bug 1998221]
+     *
+     * Note also that it's possible to end up with a null classPtr here if
+     * there is a call into stereotypical object after it has finished running
+     * its destructor phase. [Bug 7842f33a5c]
      */
 
   tailRecurse:
+    if (classPtr == NULL) {
+	return 0;
+    }
     FOREACH(superPtr, classPtr->mixins) {
 	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
 		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 2a6defa..2303f0d 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2214,6 +2214,74 @@ test iocmd-32.2 {delete interp of reflected chan} {
     interp delete child
 } {}
 
+# 1st attempt without error in write, another with error in write:
+foreach ::writeErr {0 1} {
+test iocmd-32.3.$::writeErr {prevent copy-state against segfault by finalize, bug [79474c58800cdf94]} -setup {
+    proc test_chan {args} {
+      set rest [lassign $args mode chan]
+      lappend ::ret $mode
+      switch -exact $mode {
+        read {puts $chan "Test" ; close $chan}
+        write {if {$::writeErr} {return "boom"}; set data [lindex $rest 0]; string length $data}
+        finalize {after 20 {set ::done done}}
+        initialize {return "initialize watch finalize read write"}
+      }
+    }
+    set clchlst {}
+    set toev [after 5000 {set ::done tout}]
+} -body {
+    set ::ret {}
+    set ch [chan create "read write" test_chan]
+    lappend clchlst $ch
+
+    lassign [chan pipe] in1 out1
+    lappend clchlst $in1 $out1
+    lassign [chan pipe] in2 out2
+    lappend clchlst $in2 $out2
+    lassign [chan pipe] in3 out3
+    lappend clchlst $in3 $out3
+
+    # simulate exec: echo test >@ $out2 2>@ $out3 <@ $in1 &:
+    fileevent $out2 writable [list apply {{cho che} {
+	puts $cho test; close $cho; close $che
+    }} $out2 $out3]
+    # recopy to given chans in handler
+    fileevent $in2 readable [list apply {{in out} {
+	if {[catch {
+	    chan copy $in $out
+	} msg]} {
+	    #puts err:$msg
+	    fileevent $in readable {}
+	}
+    }} $in2 $ch]
+    fileevent $in3 readable [list apply {{in out} {
+	if {[catch {
+	    chan copy $in $out
+	} msg]} {
+	    #puts err:$msg
+	    fileevent $in readable {}
+	}
+    }} $in3 $ch]
+    fileevent $out1 writable [list apply {{in out} {
+	if {[catch {
+	    chan copy $in $out
+	} msg]} {
+	    #puts err:$msg
+	    fileevent $out writable {}
+	}
+    }} $ch $out1]
+
+    vwait ::done
+    lappend ::ret $::done
+} -cleanup {
+    foreach ch $clchlst {
+	catch {close $ch}
+    }
+    after cancel $toev
+    unset -nocomplain ::done ::ret ch in1 in2 in3 out1 out2 out3 toev clchlst
+} -result {initialize read write finalize done}
+}; unset ::writeErr
+
 # ### ### ### ######### ######### #########
 ## Same tests as above, but exercising the code forwarding and
 ## receiving driver operations to the originator thread.
diff --git a/tests/oo.test b/tests/oo.test
index 3048a88..d836e96 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -4541,7 +4541,112 @@ test oo-35.6 {
 } -cleanup {
     rename obj {}
 } -result done
-
+test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
+    oo::class create base
+    oo::class create RpcClient {
+	superclass base
+	method write name {
+	    lappend ::result "RpcClient -> $name"
+	}
+	method create_bug {} {
+	    MkObjectRpc create cfg [self] 111
+	}
+    }
+    oo::class create MkObjectRpc {
+	superclass base
+	variable hdl
+	constructor {rpcHdl mqHdl} {
+	    set hdl $mqHdl
+	    oo::objdefine [self] forward rpc $rpcHdl
+	}
+	destructor {
+	    my rpc write otto-$hdl
+	}
+    }
+    set ::result {}
+} -body {
+    set FH [RpcClient new]
+    $FH create_bug
+    $FH destroy
+    join $result \n
+} -cleanup {
+    base destroy
+} -result {}
+test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
+    oo::class create base
+    oo::class create RpcClient {
+	superclass base
+	method write name {
+	    lappend ::result "RpcClient -> $name"
+	}
+	method create_bug {} {
+	    MkObjectRpc create cfg [self] 111
+	}
+	destructor {
+	    lappend ::result "Destroyed"
+	}
+    }
+    oo::class create MkObjectRpc {
+	superclass base
+	variable hdl
+	constructor {rpcHdl mqHdl} {
+	    set hdl $mqHdl
+	    oo::objdefine [self] forward rpc $rpcHdl
+	}
+	destructor {
+	    my rpc write otto-$hdl
+	}
+    }
+    set ::result {}
+} -body {
+    set FH [RpcClient new]
+    $FH create_bug
+    $FH destroy
+    join $result \n
+} -cleanup {
+    base destroy
+} -result {Destroyed}
+test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
+    oo::class create base
+    oo::class create RpcClient {
+	superclass base
+	variable interiorObjects
+	method write name {
+	    lappend ::result "RpcClient -> $name"
+	}
+	method create_bug {} {
+	    set obj [MkObjectRpc create cfg [self] 111]
+	    lappend interiorObjects $obj
+	    return $obj
+	}
+	destructor {
+	    lappend ::result "Destroyed"
+	    # Explicit destroy of interior objects
+	    foreach obj $interiorObjects {
+		$obj destroy
+	    }
+	}
+    }
+    oo::class create MkObjectRpc {
+	superclass base
+	variable hdl
+	constructor {rpcHdl mqHdl} {
+	    set hdl $mqHdl
+	    oo::objdefine [self] forward rpc $rpcHdl
+	}
+	destructor {
+	    my rpc write otto-$hdl
+	}
+    }
+    set ::result {}
+} -body {
+    set FH [RpcClient new]
+    $FH create_bug
+    $FH destroy
+    join $result \n
+} -cleanup {
+    base destroy
+} -result "Destroyed\nRpcClient -> otto-111"
 test oo-36.1 {TIP #470: introspection within oo::define} {
     oo::define oo::object self
 } ::oo::object
diff --git a/win/Makefile.in b/win/Makefile.in
index ce09ade..18ce10d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -160,7 +160,7 @@ TEST_LOAD_PRMS		= lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
 TEST_LOAD_FACILITIES	= package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\
 			  $(TEST_LOAD_PRMS)
 ZLIB_DLL_FILE		= zlib1.dll
-TOMMATH_DLL_FILE		= libtommath.dll
+TOMMATH_DLL_FILE	= libtommath.dll
 
 SHARED_LIBRARIES 	= $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
 STATIC_LIBRARIES	= $(TCL_LIB_FILE)
@@ -210,6 +210,7 @@ SHELL		= @SHELL@
 RM		= rm -f
 COPY		= cp
 LN		= ln
+GDB		= gdb
 
 ###
 # Tip 430 - ZipFS Modifications
@@ -1025,7 +1026,16 @@ shell: binaries
 # This target can be used to run tclsh inside either gdb or insight
 gdb: binaries
 	@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
-	gdb ./$(TCLSH) --command=gdb.run
+	$(GDB) ./$(TCLSH) --command=gdb.run
+	rm gdb.run
+
+shquotequote = $(subst ',\",$(subst ",\",$(1)))
+gdb-test: tcltest
+	@printf '%s ' 'set env TCL_LIBRARY=$(LIBRARY_DIR)' > gdb.run
+	@printf '\n' >>gdb.run
+	@printf '%s ' set args $(ROOT_DIR_NATIVE)/tests/all.tcl \
+		$(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run
+	$(GDB) ${TEST_EXE_FILE} --command=gdb.run
 	rm gdb.run
 
 depend: