* 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].

1 files changed, 82 insertions, 1 deletions

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