diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 62 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 83 |
2 files changed, 83 insertions, 62 deletions
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 |