merge 8.7

7 files changed, 62 insertions, 9 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index af56dcb..9867dfc 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2586,7 +2586,7 @@ Tcl_LpopObjCmd(
 				/* Argument objects. */
 {
     int listLen, result;
-    Tcl_Obj *elemPtr;
+    Tcl_Obj *elemPtr, *stored;
     Tcl_Obj *listPtr, **elemPtrs;
 
     if (objc < 2) {
@@ -2624,6 +2624,7 @@ Tcl_LpopObjCmd(
 
     /*
      * Second, remove the element.
+     * TclLsetFlat adds a ref count which is handled.
      */
 
     if (objc == 2) {
@@ -2634,6 +2635,7 @@ Tcl_LpopObjCmd(
 	if (result != TCL_OK) {
 	    return result;
 	}
+	Tcl_IncrRefCount(listPtr);
     } else {
 	listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
 
@@ -2642,8 +2644,9 @@ Tcl_LpopObjCmd(
 	}
     }
 
-    listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
-    if (listPtr == NULL) {
+    stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+    Tcl_DecrRefCount(listPtr);
+    if (stored == NULL) {
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 559050c..9d15ff5 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -8515,7 +8515,7 @@ UpdateInterest(
 	}
     }
 
-    if (statePtr->timer == NULL
+    if (!statePtr->timer
 	&& mask & TCL_WRITABLE
 	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
 
@@ -8555,7 +8555,9 @@ ChannelTimerProc(
     Tcl_Preserve(statePtr);
     statePtr->timer = NULL;
     if (statePtr->interestMask & TCL_WRITABLE
-	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
+	&& !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
+	) {
 	/*
 	 * Restart the timer in case a channel handler reenters the event loop
 	 * before UpdateInterest gets called by Tcl_NotifyChannel.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ebac1a6..1b4d898 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3034,6 +3034,7 @@ MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
 MODULE_SCOPE int	TclNokia770Doubles(void);
 MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
+MODULE_SCOPE int	TclNamespaceDeleted(Namespace *nsPtr);
 MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
 			    Tcl_Obj *part2Ptr, const char *operation,
 			    const char *reason, int index);
diff --git a/generic/tclLink.c b/generic/tclLink.c
index b8fea64..590881d 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -27,6 +27,7 @@
 
 typedef struct {
     Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
+    Namespace *nsPtr;		/* Namespace containing Tcl variable */
     Tcl_Obj *varName;		/* Name of variable (must be global). This is
 				 * needed during trace callbacks, since the
 				 * actual variable may be aliased at that time
@@ -158,6 +159,8 @@ Tcl_LinkVar(
 {
     Tcl_Obj *objPtr;
     Link *linkPtr;
+    Namespace *dummy;
+    const char *name;
     int code;
 
     linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
@@ -170,6 +173,7 @@ Tcl_LinkVar(
 
     linkPtr = Tcl_Alloc(sizeof(Link));
     linkPtr->interp = interp;
+    linkPtr->nsPtr = NULL;
     linkPtr->varName = Tcl_NewStringObj(varName, -1);
     Tcl_IncrRefCount(linkPtr->varName);
     linkPtr->addr = addr;
@@ -196,6 +200,11 @@ Tcl_LinkVar(
 	LinkFree(linkPtr);
 	return TCL_ERROR;
     }
+
+    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
+    linkPtr->nsPtr->refCount++;
+
     code = Tcl_TraceVar2(interp, varName, NULL,
 	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 	    LinkTraceProc, linkPtr);
@@ -240,6 +249,8 @@ Tcl_LinkArray(
 {
     Tcl_Obj *objPtr;
     Link *linkPtr;
+    Namespace *dummy;
+    const char *name;
     int code;
 
     if (size < 1) {
@@ -362,6 +373,11 @@ Tcl_LinkArray(
     linkPtr->interp = interp;
     linkPtr->varName = Tcl_NewStringObj(varName, -1);
     Tcl_IncrRefCount(linkPtr->varName);
+
+    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
+    linkPtr->nsPtr->refCount++;
+
     objPtr = ObjValue(linkPtr);
     if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
 	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
@@ -748,7 +764,7 @@ LinkTraceProc(
      */
 
     if (flags & TCL_TRACE_UNSETS) {
-	if (Tcl_InterpDeleted(interp)) {
+	if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
 	    Tcl_DecrRefCount(linkPtr->varName);
 	    LinkFree(linkPtr);
 	} else if (flags & TCL_TRACE_DESTROYED) {
@@ -1497,6 +1513,9 @@ static void
 LinkFree(
     Link *linkPtr)		/* Structure describing linked variable. */
 {
+    if (linkPtr->nsPtr) {
+	TclNsDecrRefCount(linkPtr->nsPtr);
+    }
     if (linkPtr->flags & LINK_ALLOC_ADDR) {
 	Tcl_Free(linkPtr->addr);
     }
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3c23b97..426fd16 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1086,6 +1086,13 @@ Tcl_DeleteNamespace(
     }
     TclNsDecrRefCount(nsPtr);
 }
+
+int
+TclNamespaceDeleted(
+    Namespace *nsPtr)
+{
+    return (nsPtr->flags & NS_DYING) ? 1 : 0;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 0c81e5a..0ba240e 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -381,6 +381,7 @@ static int		ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
 static int		ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
 			    Tcl_LoadHandle *loadHandle,
 			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+static void		ZipfsExitHandler(ClientData clientData);
 static void		ZipfsSetup(void);
 static int		ZipChannelClose(void *instanceData,
 			    Tcl_Interp *interp);
@@ -1280,6 +1281,7 @@ ZipFSCatalogFilesystem(
 
     *zf = *zf0;
     zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+    Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
     zf->mountPointLen = strlen(zf->mountPoint);
     zf->nameLength = strlen(zipname);
     zf->name = Tcl_Alloc(zf->nameLength + 1);
@@ -1673,9 +1675,16 @@ TclZipfs_Mount(
 	return TCL_ERROR;
     }
     if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+	ckfree(zf);
 	return TCL_ERROR;
     }
-    return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname);
+    if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
+	    != TCL_OK) {
+	ckfree(zf);
+	return TCL_ERROR;
+    }
+    ckfree(zf);
+    return TCL_OK;
 }
 
 /*
@@ -1838,6 +1847,7 @@ TclZipfs_Unmount(
 	Tcl_Free(z);
     }
     ZipFSCloseArchive(interp, zf);
+    Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf);
     Tcl_Free(zf);
     unmounted = 1;
   done:
@@ -4823,6 +4833,17 @@ ZipfsAppHookFindTclInit(
     return TCL_ERROR;
 }
 
+static void
+ZipfsExitHandler(
+    ClientData clientData)
+{
+    ZipFile *zf = (ZipFile *)clientData;
+
+    if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+	Tcl_Panic("tried to unmount busy filesystem");
+    }
+}
+
 /*
  *-------------------------------------------------------------------------
  *
diff --git a/tests/dict.test b/tests/dict.test
index 62590e7..e5284fc 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -2128,7 +2128,7 @@ test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
 test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
     dict getwithdefault {} {}
 } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
-test dict-26.10 {dict getdef command} -returnCodes error -body {
+test dict-27.10 {dict getdef command} -returnCodes error -body {
     dict getwithdefault {a b c} d e
 } -result {missing value to go with key}
 test dict-27.11 {dict getwithdefault command} -body {
@@ -2149,7 +2149,7 @@ test dict-27.15 {dict getwithdefault command} -body {
 test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
     $dict getwithdefault {a {b c d}} a b d
 } -result {missing value to go with key}
-test dict-26.17 {dict getdef command} -returnCodes error -body {
+test dict-27.17 {dict getdef command} -returnCodes error -body {
     $dict getwithdefault {a b c} d e
 } -result {missing value to go with key}