* generic/tclBasic.c: Moved Tcl_LogCommandInfo from tclBasic.c to

        * generic/tclNamesp.c:  tclNamesp.c to get access to identifier with
        * tests/error.test (error-7.0): file scope.  Added check for traces
        on ::errorInfo, and when present fall back to contruction of the
        stack trace in the variable so that write trace notification timings
        are compatible with earlier Tcl releases.  This reduces, but does not
        completely eliminate the ***POTENTIAL INCOMPATIBILITY*** created by
        the 2004-10-15 commit.  [Bug 1397843].

4 files changed, 115 insertions, 64 deletions

diff --git a/ChangeLog b/ChangeLog
index cebeb79..a419f26 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2006-01-11  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:	Moved Tcl_LogCommandInfo from tclBasic.c to
+	* generic/tclNamesp.c:	tclNamesp.c to get access to identifier with
+	* tests/error.test (error-7.0):	file scope.  Added check for traces
+	on ::errorInfo, and when present fall back to contruction of the
+	stack trace in the variable so that write trace notification timings
+	are compatible with earlier Tcl releases.  This reduces, but does not
+	completely eliminate the ***POTENTIAL INCOMPATIBILITY*** created by
+	the 2004-10-15 commit.  [Bug 1397843].
+
 2006-01-10  Daniel Steffen  <das@users.sourceforge.net>
 
 	* unix/configure:    add caching, use AC_CACHE_CHECK instead of
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 19acbf5..735874b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.186 2005/12/27 20:14:08 kennykb Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.187 2006/01/11 17:34:53 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3510,66 +3510,6 @@ Tcl_EvalObjv(
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_LogCommandInfo --
- *
- *	This function is invoked after an error occurs in an interpreter. It
- *	adds information to iPtr->errorInfo field to describe the command that
- *	was being executed when the error occurred.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Information about the command is added to errorInfo and the line
- *	number stored internally in the interpreter is set.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LogCommandInfo(
-    Tcl_Interp *interp,		/* Interpreter in which to log information. */
-    CONST char *script,		/* First character in script containing
-				 * command (must be <= command). */
-    CONST char *command,	/* First character in command that generated
-				 * the error. */
-    int length)			/* Number of bytes in command (-1 means use
-				 * all bytes up to first null byte). */
-{
-    register CONST char *p;
-    Interp *iPtr = (Interp *) interp;
-    int overflow, limit = 150;
-
-    if (iPtr->flags & ERR_ALREADY_LOGGED) {
-	/*
-	 * Someone else has already logged error information for this command;
-	 * we shouldn't add anything more.
-	 */
-
-	return;
-    }
-
-    /*
-     * Compute the line number where the error occurred.
-     */
-
-    iPtr->errorLine = 1;
-    for (p = script; p != command; p++) {
-	if (*p == '\n') {
-	    iPtr->errorLine++;
-	}
-    }
-
-    overflow = (length > limit);
-    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
-	    ((iPtr->errorInfo == NULL)
-	    ? "while executing" : "invoked from within"),
-	    (overflow ? limit : length), command, (overflow ? "..." : ""));
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_EvalTokensStandard --
  *
  *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 882c429..2debd69 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.90 2006/01/09 18:35:01 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.91 2006/01/11 17:34:53 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -6634,6 +6634,87 @@ StringOfEnsembleCmdRep(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LogCommandInfo --
+ *
+ *      This function is invoked after an error occurs in an interpreter. It
+ *      adds information to iPtr->errorInfo field to describe the command that
+ *      was being executed when the error occurred.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      Information about the command is added to errorInfo and the line
+ *      number stored internally in the interpreter is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_LogCommandInfo(
+    Tcl_Interp *interp,         /* Interpreter in which to log information. */
+    CONST char *script,         /* First character in script containing
+                                 * command (must be <= command). */
+    CONST char *command,        /* First character in command that generated
+                                 * the error. */
+    int length)                 /* Number of bytes in command (-1 means use
+                                 * all bytes up to first null byte). */
+{
+    register CONST char *p;
+    Interp *iPtr = (Interp *) interp;
+    int overflow, limit = 150;
+    Var *varPtr, *arrayPtr;
+
+    if (iPtr->flags & ERR_ALREADY_LOGGED) {
+	/*
+	 * Someone else has already logged error information for this command;
+	 * we shouldn't add anything more.
+	 */
+
+        return;
+    }
+
+    /*
+     * Compute the line number where the error occurred.
+     */
+
+    iPtr->errorLine = 1;
+    for (p = script; p != command; p++) {
+	if (*p == '\n') {
+	    iPtr->errorLine++;
+	}
+    }
+
+    overflow = (length > limit);
+    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
+	    ((iPtr->errorInfo == NULL)
+	    ? "while executing" : "invoked from within"),
+	    (overflow ? limit : length), command, (overflow ? "..." : ""));
+
+    varPtr = TclObjLookupVar(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+	    NULL, 0, 0, &arrayPtr);
+    if ((varPtr == NULL) || (varPtr->tracePtr == NULL)) {
+	/* Should not happen */
+	return;
+    }
+    if (varPtr->tracePtr->traceProc != EstablishErrorInfoTraces) {
+	/*
+	 * The most recent trace set on ::errorInfo is not the one
+	 * the core itself puts on last.  This means some other code
+	 * is tracing the variable, and the additional trace(s) might
+	 * be write traces that expect the timing of writes to ::errorInfo
+	 * that existed Tcl releases before 8.5.  To satisfy that
+	 * compatibility need, we write the current -errorinfo value
+	 * to the ::errorInfo variable.
+	 */
+	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+		iPtr->errorInfo, TCL_GLOBAL_ONLY);
+    }
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/tests/error.test b/tests/error.test
index ab35c5d..d8bfaba 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -11,10 +11,10 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: error.test,v 1.13 2005/07/28 18:42:28 dgp Exp $
+# RCS: @(#) $Id: error.test,v 1.14 2006/01/11 17:34:54 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+    package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
@@ -220,6 +220,25 @@ test error-6.9 {catch must reset error state} {
     list $errorCode
 } {NONE}
 
+namespace eval ::tcl::test::error {
+    test error-7.0 {Bug 1397843} -body {
+	variable cmds
+	proc EIWrite args {
+	    variable cmds
+	    lappend cmds [lindex [info level -2] 0]
+	}
+	proc BadProc {} {
+	    set i a
+	    incr i
+	}
+	trace add variable ::errorInfo write [namespace code EIWrite]
+	catch BadProc
+	trace remove variable ::errorInfo write [namespace code EIWrite]
+	set cmds
+    } -match glob -result {*BadProc*}
+}
+namespace delete ::tcl::test::error
+
 # cleanup
 catch {rename p ""}
 ::tcltest::cleanupTests