Merge 8.7

11 files changed, 209 insertions, 38 deletions

diff --git a/doc/Init.3 b/doc/Init.3
index d9fc2e1..cf17a37 100644
--- a/doc/Init.3
+++ b/doc/Init.3
@@ -2,7 +2,7 @@
 '\" Copyright (c) 1998-2000 Scriptics Corporation.
 '\" All rights reserved.
 '\"
-.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures"
+.TH Tcl_Init 3 8.7 Tcl "Tcl Library Procedures"
 .so man.macros
 .BS
 .SH NAME
@@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script
 .sp
 int
 \fBTcl_Init\fR(\fIinterp\fR)
+.sp
+const char *
+\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR)
 .SH ARGUMENTS
 .AS Tcl_Interp *interp
 .AP Tcl_Interp *interp in
 Interpreter to initialize.
+.AP "const char" *scriptPtr in
+Address of the initialization script.
 .BE
 
 .SH DESCRIPTION
@@ -26,6 +31,13 @@ Interpreter to initialize.
 path.
 .PP
 \fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures.
+.PP
+\fBTcl_SetPreInitScript\fR registers the pre-initialization script and
+returns the former (now replaced) script pointer.
+A value of \fINULL\fR may be passed to not register any script.
+The pre-initialization script is executed by \fBTcl_Init\fR before accessing
+the file system. The purpose is to typically prepare a custom file system
+(like an embedded zip-file) to be activated before the search.
 
 .SH "SEE ALSO"
 Tcl_AppInit, Tcl_Main
diff --git a/generic/tcl.h b/generic/tcl.h
index 9bd7bb5..d503914 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2191,6 +2191,7 @@ EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
 EXTERN void		Tcl_InitSubsystems(void);
 EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 EXTERN void		Tcl_FindExecutable(const char *argv0);
+EXTERN const char *	Tcl_SetPreInitScript(const char *string);
 EXTERN void		Tcl_SetPanicProc(
 			    TCL_NORETURN1 Tcl_PanicProc *panicProc);
 EXTERN void		Tcl_StaticLibrary(Tcl_Interp *interp,
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7b80165..dc028b5 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3624,7 +3624,7 @@ Tcl_CloseEx(
      * That won't do.
      */
 
-    if (statePtr->flags & CHANNEL_INCLOSE) {
+    if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
 	if (interp) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                     "illegal recursive call to close through close-handler"
@@ -8561,9 +8561,12 @@ ChannelTimerProc(
     ClientData clientData)
 {
     Channel *chanPtr = (Channel *)clientData;
+
+    /* State info for channel */
     ChannelState *statePtr = chanPtr->state;
-				/* State info for channel */
 
+	/* Preserve chanPtr to guard against deallocation in Tcl_NotifyChannel. */
+    TclChannelPreserve((Tcl_Channel)chanPtr);
     Tcl_Preserve(statePtr);
     statePtr->timer = NULL;
     if (statePtr->interestMask & TCL_WRITABLE
@@ -8579,22 +8582,27 @@ ChannelTimerProc(
 	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
     }
 
-    if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
-	    && (statePtr->interestMask & TCL_READABLE)
-	    && (statePtr->inQueueHead != NULL)
-	    && IsBufferReady(statePtr->inQueueHead)) {
-	/*
-	 * Restart the timer in case a channel handler reenters the event loop
-	 * before UpdateInterest gets called by Tcl_NotifyChannel.
-	 */
+    /* The channel may have just been closed from within Tcl_NotifyChannel */
+    if (!GotFlag(statePtr, CHANNEL_INCLOSE)) {
+	if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
+		&& (statePtr->interestMask & TCL_READABLE)
+		&& (statePtr->inQueueHead != NULL)
+		&& IsBufferReady(statePtr->inQueueHead)) {
+	    /*
+	     * Restart the timer in case a channel handler reenters the event loop
+	     * before UpdateInterest gets called by Tcl_NotifyChannel.
+	     */
 
-	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
-                ChannelTimerProc,chanPtr);
-	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
-    } else {
-	UpdateInterest(chanPtr);
+	    statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+		    ChannelTimerProc,chanPtr);
+	    Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
+	} else {
+	    UpdateInterest(chanPtr);
+	}
     }
+
     Tcl_Release(statePtr);
+    TclChannelRelease((Tcl_Channel)chanPtr);
 }
 
 /*
@@ -8659,7 +8667,7 @@ Tcl_CreateChannelHandler(
 
     /*
      * The remainder of the initialization below is done regardless of whether
-     * or not this is a new record or a modification of an old one.
+     * this is a new record or a modification of an old one.
      */
 
     chPtr->mask = mask;
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 2f29816..82ed10b 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -72,7 +72,7 @@ static const Tcl_ChannelType tclRChannelType = {
     ReflectGetOption,	   /* Get options.			NULL'able */
     ReflectWatch,	   /* Initialize notifier			  */
     NULL,		   /* Get OS handle from the channel.	NULL'able */
-	ReflectClose,	   /* No close2 support.		NULL'able */
+    ReflectClose,	   /* No close2 support.		NULL'able */
     ReflectBlock,	   /* Set blocking/nonblocking.		NULL'able */
     NULL,		   /* Flush channel. Not used by core.	NULL'able */
     NULL,		   /* Handle events.			NULL'able */
@@ -1145,7 +1145,7 @@ TclChanCaughtErrorBypass(
  * ReflectClose --
  *
  *	This function is invoked when the channel is closed, to delete the
- *	driver specific instance data.
+ *	driver-specific instance data.
  *
  * Results:
  *	A posix error.
@@ -1178,8 +1178,8 @@ ReflectClose(
 	/*
 	 * This call comes from TclFinalizeIOSystem. There are no
 	 * interpreters, and therefore we cannot call upon the handler command
-	 * anymore. Threading is irrelevant as well. We simply clean up all
-	 * our C level data structures and leave the Tcl level to the other
+	 * anymore. Threading is irrelevant as well. Simply clean up all
+	 * the C level data structures and leave the Tcl level to the other
 	 * finalization functions.
 	 */
 
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 452749e..4ecd2bc 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -185,9 +185,10 @@ declare 97 {
 declare 98 {
     int TclServiceIdle(void)
 }
-declare 101 {
-    const char *TclSetPreInitScript(const char *string)
-}
+# Removed in 9.0:
+#declare 101 {
+#    const char *TclSetPreInitScript(const char *string)
+#}
 declare 102 {
     void TclSetupEnv(Tcl_Interp *interp)
 }
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index bd33b92..5fa3bb0 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -227,8 +227,7 @@ EXTERN void		TclResetShadowedCmdRefs(Tcl_Interp *interp,
 EXTERN int		TclServiceIdle(void);
 /* Slot 99 is reserved */
 /* Slot 100 is reserved */
-/* 101 */
-EXTERN const char *	TclSetPreInitScript(const char *string);
+/* Slot 101 is reserved */
 /* 102 */
 EXTERN void		TclSetupEnv(Tcl_Interp *interp);
 /* 103 */
@@ -688,7 +687,7 @@ typedef struct TclIntStubs {
     int (*tclServiceIdle) (void); /* 98 */
     void (*reserved99)(void);
     void (*reserved100)(void);
-    const char * (*tclSetPreInitScript) (const char *string); /* 101 */
+    void (*reserved101)(void);
     void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
     int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
     void (*reserved104)(void);
@@ -1008,8 +1007,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclServiceIdle) /* 98 */
 /* Slot 99 is reserved */
 /* Slot 100 is reserved */
-#define TclSetPreInitScript \
-	(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
+/* Slot 101 is reserved */
 #define TclSetupEnv \
 	(tclIntStubsPtr->tclSetupEnv) /* 102 */
 #define TclSockGetPort \
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index e1979e0..d448c3b 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -281,7 +281,7 @@ static Tcl_ObjCmdProc	NRChildCmd;
 /*
  *----------------------------------------------------------------------
  *
- * TclSetPreInitScript --
+ * Tcl_SetPreInitScript --
  *
  *	This routine is used to change the value of the internal variable,
  *	tclPreInitScript.
@@ -296,12 +296,12 @@ static Tcl_ObjCmdProc	NRChildCmd;
  */
 
 const char *
-TclSetPreInitScript(
+Tcl_SetPreInitScript(
     const char *string)		/* Pointer to a script. */
 {
     const char *prevString = tclPreInitScript;
     tclPreInitScript = string;
-    return(prevString);
+    return prevString;
 }
 
 /*
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9d8f12e..f94e936 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -401,7 +401,7 @@ static const TclIntStubs tclIntStubs = {
     TclServiceIdle, /* 98 */
     0, /* 99 */
     0, /* 100 */
-    TclSetPreInitScript, /* 101 */
+    0, /* 101 */
     TclSetupEnv, /* 102 */
     TclSockGetPort, /* 103 */
     0, /* 104 */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a433c49..83c7c18 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -224,6 +224,7 @@ static Tcl_CmdProc	TestcreatecommandCmd;
 static Tcl_CmdProc	TestdcallCmd;
 static Tcl_CmdProc	TestdelCmd;
 static Tcl_CmdProc	TestdelassocdataCmd;
+static Tcl_ObjCmdProc	TestdebugObjCmd;
 static Tcl_ObjCmdProc	TestdoubledigitsObjCmd;
 static Tcl_CmdProc	TestdstringCmd;
 static Tcl_ObjCmdProc	TestencodingObjCmd;
@@ -262,6 +263,7 @@ static Tcl_ObjCmdProc	TestparsevarObjCmd;
 static Tcl_ObjCmdProc	TestparsevarnameObjCmd;
 static Tcl_ObjCmdProc	TestpreferstableObjCmd;
 static Tcl_ObjCmdProc	TestprintObjCmd;
+static Tcl_ObjCmdProc	TestpurifyObjCmd;
 static Tcl_ObjCmdProc	TestregexpObjCmd;
 static Tcl_ObjCmdProc	TestreturnObjCmd;
 static void		TestregexpXflags(const char *string,
@@ -501,6 +503,8 @@ Tcltest_Init(
     Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
 	    NULL, NULL);
     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testdebug", TestdebugObjCmd,
+	    NULL, NULL);
     Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL);
     Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
 	    NULL, NULL);
@@ -565,6 +569,8 @@ Tcltest_Init(
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
 	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testpurify", TestpurifyObjCmd,
+	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
@@ -3362,6 +3368,40 @@ TestlocaleCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TestdebugObjCmd --
+ *
+ *	Implements the "testdebug" command, to detect whether Tcl was built with
+ *	--enabble-symbols.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestdebugObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Current interpreter. */
+    TCL_UNUSED(int) /*objc*/,
+    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
+{
+
+#if defined(NDEBUG) && NDEBUG == 1
+	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+#else
+	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
+#endif
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * CleanupTestSetassocdataTests --
  *
  *	This function is called when an interpreter is deleted to clean
@@ -3763,6 +3803,40 @@ TestprintObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TestpurifyObjCmd --
+ *
+ *	Implements the "testpurify" command, to detect whether Tcl was built with
+ *	-DPURIFY.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestpurifyObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Current interpreter. */
+    TCL_UNUSED(int) /*objc*/,
+    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
+{
+
+#ifdef PURIFY
+	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
+#else
+	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+#endif
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestregexpObjCmd --
  *
  *	This procedure implements the "testregexp" command. It is used to give
diff --git a/tests/io.test b/tests/io.test
index e0a2389..ddf2403 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2346,9 +2346,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \
         set result ok
     }
 } ok
-test io-28.4 {Tcl_Close} {testchannel} {
+test io-28.4 Tcl_Close testchannel {
     file delete $path(test1)
-    set l ""
+    set l {}
     lappend l [lsort [testchannel open]]
     set f [open $path(test1) w]
     lappend l [lsort [testchannel open]]
@@ -2373,6 +2373,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
     lsort $l
 } {file1 file2}
 
+
+test io-28.6 {
+	close channel in write event handler
+
+	Should not produce a segmentation fault in a Tcl built with
+	--enable-symbols and -DPURIFY
+} debugpurify {
+    variable done
+    variable res
+    after 0 [list coroutine c1 apply [list {} {
+	variable done
+	set chan [chan create w {apply {args {
+	    list initialize finalize watch write configure blocking
+	}}}]
+	chan configure $chan -blocking 0
+	while 1 {
+	    chan event $chan writable [list [info coroutine]]
+	    yield
+	    close $chan
+	    set done 1
+	    return
+	}
+    } [namespace current]]]
+    vwait [namespace current]::done
+return success
+} success
+
+
+test io-28.7 {
+    close channel in read event handler
+
+	Should not produce a segmentation fault in a Tcl built with
+	--enable-symbols and -DPURIFY
+} debugpurify {
+    variable done
+    variable res
+    after 0 [list coroutine c1 apply [list {} {
+	variable done
+	set chan [chan create r {apply {{cmd chan args} {
+	    switch $cmd {
+		blocking - finalize {
+		}
+		watch {
+		    chan postevent $chan read 
+		}
+		initialize {
+		    list initialize finalize watch read write configure blocking
+		}
+		default {
+		    error [list {unexpected command} $cmd]
+		}
+	    }
+	}}}]
+	chan configure $chan -blocking 0
+	while 1 {
+	    chan event $chan readable [list [info coroutine]]
+	    yield
+	    close $chan
+	    set done 1
+	    return
+	}
+    } [namespace current]]]
+    vwait [namespace current]::done
+return success
+} success 
+
+
+
 test io-29.1 {Tcl_WriteChars, channel not writable} {
     list [catch {puts stdin hello} msg] $msg
 } {1 {channel "stdin" wasn't opened for writing}}
@@ -5310,9 +5378,6 @@ test io-39.1 {Tcl_GetChannelOption} {
     close $f1
     set x
 } 1
-#
-# Test 17.2 was removed.
-#
 test io-39.2 {Tcl_GetChannelOption} {
     file delete $path(test1)
     set f1 [open $path(test1) w]
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index 193ba0a..1ee37d3 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -3,6 +3,18 @@
 package require tcltest 2.5
 namespace import ::tcltest::*
 testConstraint exec          [llength [info commands exec]]
+if {[namespace which testdebug] ne {}} {
+	testConstraint debug         [testdebug]
+	testConstraint purify        [testpurify]
+	testConstraint debugpurify   [
+		expr {
+		![testConstraint memory]
+		&&
+		[testConstraint debug]
+		&&
+		[testConstraint purify]
+	}]
+}
 testConstraint fcopy         [llength [info commands fcopy]]
 testConstraint fileevent     [llength [info commands fileevent]]
 testConstraint thread        [