summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c83
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