diff options
Diffstat (limited to 'generic/tclNamesp.c')
| -rw-r--r-- | generic/tclNamesp.c | 83 |
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 |