Attachment "1397843.patch" to
ticket [1397843fff]
added by
dgp
2006-01-10 00:40:19.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.186
diff -u -r1.186 tclBasic.c
--- generic/tclBasic.c 27 Dec 2005 20:14:08 -0000 1.186
+++ generic/tclBasic.c 9 Jan 2006 17:36:18 -0000
@@ -3510,66 +3510,6 @@
/*
*----------------------------------------------------------------------
*
- * 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
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.89
diff -u -r1.89 tclNamesp.c
--- generic/tclNamesp.c 27 Nov 2005 02:33:49 -0000 1.89
+++ generic/tclNamesp.c 9 Jan 2006 17:36:19 -0000
@@ -6632,6 +6632,87 @@
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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
Index: tests/error.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/error.test,v
retrieving revision 1.13
diff -u -r1.13 error.test
--- tests/error.test 28 Jul 2005 18:42:28 -0000 1.13
+++ tests/error.test 9 Jan 2006 17:36:21 -0000
@@ -220,6 +220,25 @@
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
