diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 62 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 83 | ||||
| -rw-r--r-- | tests/error.test | 23 |
4 files changed, 115 insertions, 64 deletions
@@ -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 |