summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2003-10-14 15:44:52 (GMT)
committerdgp <dgp@users.sourceforge.net>2003-10-14 15:44:52 (GMT)
commitb7c8b125de1f42a74d05bd5882afc2da0a88604a (patch)
treebdeafc412fed0f5ab5d71500254ea6d40c14174c
parent53f461a314e8fda45504e3e1d7a51595d470604e (diff)
downloadtcl-b7c8b125de1f42a74d05bd5882afc2da0a88604a.zip
tcl-b7c8b125de1f42a74d05bd5882afc2da0a88604a.tar.gz
tcl-b7c8b125de1f42a74d05bd5882afc2da0a88604a.tar.bz2
* generic/tclBasic.c (TclAppendObjToErrorInfo): New internal routine
that appends a Tcl_Obj to the errorInfo, saving the caller the trouble of extracting the string rep. * generic/tclStringObj.c (TclAppendLimitedToObj): New internal routine that supports truncated appends with optional ellipsis marking. This single routine supports UTF-8-safe truncated appends needed in several places throughout the Tcl source code, mostly for error and stack messages. Clean fix for [Bug 760872]. * generic/tclInt.h: Declarations for new internal routines. * generic/tclCmdMZ.c: Updated callers to use the new routines. * generic/tclCompExpr.c: * generic/tclCompile.c: * generic/tclExecute.c: * generic/tclIOUtil.c: * generic/tclNamesp.c: * generic/tclObj.c: * generic/tclParseExpr.c: * generic/tclProc.c: * generic/tclStringObj.c: * mac/tclMacResource.c: * library/init.tcl: Updated ::errorInfo cleanup in [unknown] to reflect slight modifications to Tcl_LogCommandInfo(). Corrects failing init-4.* tests.
-rw-r--r--ChangeLog30
-rw-r--r--generic/tclBasic.c98
-rw-r--r--generic/tclCmdMZ.c18
-rw-r--r--generic/tclCompExpr.c16
-rw-r--r--generic/tclCompile.c26
-rw-r--r--generic/tclExecute.c13
-rw-r--r--generic/tclIOUtil.c18
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclNamesp.c18
-rw-r--r--generic/tclObj.c59
-rw-r--r--generic/tclParseExpr.c21
-rw-r--r--generic/tclProc.c65
-rw-r--r--generic/tclStringObj.c79
-rw-r--r--library/init.tcl12
-rw-r--r--mac/tclMacResource.c18
15 files changed, 297 insertions, 201 deletions
diff --git a/ChangeLog b/ChangeLog
index a65ae8f..b1e170d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,33 @@
+2003-10-14 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclBasic.c (TclAppendObjToErrorInfo): New internal routine
+ that appends a Tcl_Obj to the errorInfo, saving the caller the trouble
+ of extracting the string rep.
+
+ * generic/tclStringObj.c (TclAppendLimitedToObj): New internal
+ routine that supports truncated appends with optional ellipsis marking.
+ This single routine supports UTF-8-safe truncated appends needed in
+ several places throughout the Tcl source code, mostly for error and
+ stack messages. Clean fix for [Bug 760872].
+
+ * generic/tclInt.h: Declarations for new internal routines.
+
+ * generic/tclCmdMZ.c: Updated callers to use the new routines.
+ * generic/tclCompExpr.c:
+ * generic/tclCompile.c:
+ * generic/tclExecute.c:
+ * generic/tclIOUtil.c:
+ * generic/tclNamesp.c:
+ * generic/tclObj.c:
+ * generic/tclParseExpr.c:
+ * generic/tclProc.c:
+ * generic/tclStringObj.c:
+ * mac/tclMacResource.c:
+
+ * library/init.tcl: Updated ::errorInfo cleanup in [unknown] to
+ reflect slight modifications to Tcl_LogCommandInfo(). Corrects
+ failing init-4.* tests.
+
2003-10-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
TIP#127 IMPLEMENTATION FROM JOE MICHAEL SCHLENKER
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d356ddf..7f89d7e 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.91 2003/10/08 23:18:35 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.92 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -3337,10 +3337,9 @@ Tcl_LogCommandInfo(interp, script, command, length)
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
- char buffer[200];
register CONST char *p;
- char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *message;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
@@ -3362,26 +3361,16 @@ Tcl_LogCommandInfo(interp, script, command, length)
}
}
- /*
- * Create an error message to add to errorInfo, including up to a
- * maximum number of characters of the command.
- */
-
- if (length < 0) {
- length = strlen(command);
- }
- if (length > 150) {
- length = 150;
- ellipsis = "...";
- }
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buffer, "\n while executing\n\"%.*s%s\"",
- length, command, ellipsis);
+ message = Tcl_NewStringObj("\n while executing\n\"", -1);
} else {
- sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
- length, command, ellipsis);
+ message = Tcl_NewStringObj("\n invoked from within\n\"", -1);
}
- Tcl_AddObjErrorInfo(interp, buffer, -1);
+ Tcl_IncrRefCount(message);
+ TclAppendLimitedToObj(message, command, length, 153, NULL);
+ Tcl_AppendToObj(message, "\"", -1);
+ TclAppendObjToErrorInfo(interp, message);
+ Tcl_DecrRefCount(message);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
@@ -4384,8 +4373,7 @@ TclObjInvoke(interp, objc, objv, flags)
int localObjc; /* Used to invoke "unknown" if the */
Tcl_Obj **localObjv = NULL; /* command is not found. */
register int i;
- int length, result;
- char *bytes;
+ int result;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
@@ -4478,29 +4466,23 @@ TclObjInvoke(interp, objc, objv, flags)
if ((result == TCL_ERROR)
&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
- Tcl_DString ds;
-
- Tcl_DStringInit(&ds);
+ int length;
+ CONST char* cmdString;
+ Tcl_Obj *message, *command = Tcl_NewListObj(objc, objv);
+
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
+ message = Tcl_NewStringObj("\n while invoking\n\"", -1);
} else {
- Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
+ message = Tcl_NewStringObj("\n invoked from within\n\"", -1);
}
- for (i = 0; i < objc; i++) {
- bytes = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_DStringAppend(&ds, bytes, length);
- if (i < (objc - 1)) {
- Tcl_DStringAppend(&ds, " ", -1);
- } else if (Tcl_DStringLength(&ds) > 100) {
- Tcl_DStringSetLength(&ds, 100);
- Tcl_DStringAppend(&ds, "...", -1);
- break;
- }
- }
-
- Tcl_DStringAppend(&ds, "\"", -1);
- Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
- Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(message);
+ Tcl_IncrRefCount(command);
+ cmdString = Tcl_GetStringFromObj(command, &length);
+ TclAppendLimitedToObj(message, cmdString, length, 100, NULL);
+ Tcl_DecrRefCount(command);
+ Tcl_AppendToObj(message, "\"", -1);
+ TclAppendObjToErrorInfo(interp, message);
+ Tcl_DecrRefCount(message);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
@@ -4598,6 +4580,38 @@ Tcl_ExprString(interp, string)
/*
*----------------------------------------------------------------------
*
+ * TclAppendObjToErrorInfo --
+ *
+ * Add a Tcl_Obj value to the "errorInfo" variable that describes the
+ * current error.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The value of the Tcl_obj is added to the "errorInfo" variable.
+ * If Tcl_Eval has been called since the current value of errorInfo
+ * was set, errorInfo is cleared before adding the new message.
+ * If we are just starting to log an error, errorInfo is initialized
+ * from the error message in the interpreter's result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclAppendObjToErrorInfo(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter to which error information
+ * pertains. */
+ Tcl_Obj *objPtr; /* Message to record. */
+{
+ int length;
+ CONST char *message = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_AddObjErrorInfo(interp, message, length);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_AddErrorInfo --
*
* Add information to the "errorInfo" variable that describes the
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 64fc82c..463e0c5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.94 2003/09/05 21:52:11 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.95 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -2712,11 +2712,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
}
result = Tcl_EvalObjEx(interp, objv[j], 0);
if (result == TCL_ERROR) {
- char msg[100 + TCL_INTEGER_SPACE];
-
- sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
+ Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1);
+ Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
+ Tcl_IncrRefCount(msg);
+ Tcl_IncrRefCount(errorLine);
+ TclAppendLimitedToObj(msg, pattern, -1, 50, "");
+ Tcl_AppendToObj(msg,"\" arm line ", -1);
+ Tcl_AppendObjToObj(msg, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(msg,")", -1);
+ TclAppendObjToErrorInfo(interp, msg);
+ Tcl_DecrRefCount(msg);
}
return result;
}
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d4fecc0..c7e6213 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.15 2003/09/12 23:55:32 dkf Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.16 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -954,12 +954,10 @@ LogSyntaxError(infoPtr)
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
{
- int numBytes = (infoPtr->lastChar - infoPtr->expr);
- char buffer[100];
-
- sprintf(buffer, "syntax error in expression \"%.*s\"",
- ((numBytes > 60)? 60 : numBytes), infoPtr->expr);
- Tcl_ResetResult(infoPtr->interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
- buffer, (char *) NULL);
+ Tcl_Obj *result =
+ Tcl_NewStringObj("syntax error in expression \"", -1);
+ TclAppendLimitedToObj(result, infoPtr->expr,
+ (int)(infoPtr->lastChar - infoPtr->expr), 60, "");
+ Tcl_AppendToObj(result, "\"", -1);
+ Tcl_SetObjResult(infoPtr->interp, result);
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 10845d3..66d4bea 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.50 2003/09/12 23:55:32 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.51 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -1613,10 +1613,9 @@ LogCompilationInfo(interp, script, command, length)
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
- char buffer[200];
register CONST char *p;
- char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *message;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
@@ -1638,21 +1637,12 @@ LogCompilationInfo(interp, script, command, length)
}
}
- /*
- * Create an error message to add to errorInfo, including up to a
- * maximum number of characters of the command.
- */
-
- if (length < 0) {
- length = strlen(command);
- }
- if (length > 150) {
- length = 150;
- ellipsis = "...";
- }
- sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
- length, command, ellipsis);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
+ message = Tcl_NewStringObj("\n while compiling\n\"", -1);
+ Tcl_IncrRefCount(message);
+ TclAppendLimitedToObj(message, command, length, 153, NULL);
+ Tcl_AppendToObj(message, "\"", -1);
+ TclAppendObjToErrorInfo(interp, message);
+ Tcl_DecrRefCount(message);
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b6bac46..6f26e10 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.110 2003/10/04 16:12:12 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.111 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -4436,12 +4436,11 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);
if (cmd != NULL) {
- if (numChars > 100) {
- numChars = 100;
- ellipsis = "...";
- }
- fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
- ellipsis);
+ Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1);
+ Tcl_IncrRefCount(message);
+ TclAppendLimitedToObj(message, cmd, numChars, 100, NULL);
+ fprintf(stderr,"%s\n", Tcl_GetString(message));
+ Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 8586eb3..08e2656 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.86 2003/10/13 16:48:06 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.87 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -1577,15 +1577,23 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
- char msg[200 + TCL_INTEGER_SPACE];
/*
* Record information telling where the error occurred.
*/
- sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr),
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
+ Tcl_Obj *msg = Tcl_NewStringObj("\n (file \"", -1);
+ CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ Tcl_IncrRefCount(msg);
+ Tcl_IncrRefCount(errorLine);
+ TclAppendLimitedToObj(msg, pathString, length, 150, "");
+ Tcl_AppendToObj(msg, "\" line ", -1);
+ Tcl_AppendObjToObj(msg, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(msg, ")", -1);
+ TclAppendObjToErrorInfo(interp, msg);
+ Tcl_DecrRefCount(msg);
}
end:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a844485..cbdbd10 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.135 2003/09/29 22:51:50 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.136 2003/10/14 15:44:52 dgp Exp $
*/
#ifndef _TCLINT
@@ -1622,6 +1622,11 @@ extern char tclEmptyString;
*----------------------------------------------------------------
*/
+EXTERN void TclAppendLimitedToObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ CONST char *bytes, int length, int limit,
+ CONST char *ellipsis));
+EXTERN void TclAppendObjToErrorInfo _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr));
EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index b09e5f2..a463e7f 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.33 2003/09/29 14:37:14 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.34 2003/10/14 15:44:52 dgp Exp $
*/
#include "tclInt.h"
@@ -3150,11 +3150,17 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
- char msg[256 + TCL_INTEGER_SPACE];
-
- sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
- namespacePtr->fullName, interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
+ Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
+ Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace eval \"", -1);
+ Tcl_IncrRefCount(errorLine);
+ Tcl_IncrRefCount(msg);
+ TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
+ Tcl_AppendToObj(msg, "\" script line ", -1);
+ Tcl_AppendObjToObj(msg, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(msg, ")", -1);
+ TclAppendObjToErrorInfo(interp, msg);
+ Tcl_DecrRefCount(msg);
}
/*
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 55b7ce8..683d41d 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.51 2003/10/09 00:29:27 patthoyts Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.52 2003/10/14 15:44:53 dgp Exp $
*/
#include "tclInt.h"
@@ -1322,15 +1322,11 @@ SetBooleanFromAny(interp, objPtr)
badBoolean:
if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to a boolean.
- */
-
- char buf[100];
- sprintf(buf, "expected boolean value but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_Obj *msg =
+ Tcl_NewStringObj("expected boolean value but got \"", -1);
+ TclAppendLimitedToObj(msg, string, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
}
return TCL_ERROR;
}
@@ -1601,16 +1597,11 @@ SetDoubleFromAny(interp, objPtr)
if (end == string) {
badDouble:
if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
- */
-
- char buf[100];
- sprintf(buf, "expected floating-point number but got \"%.50s\"",
- string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_Obj *msg = Tcl_NewStringObj(
+ "expected floating-point number but got \"", -1);
+ TclAppendLimitedToObj(msg, string, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
}
return TCL_ERROR;
}
@@ -1898,15 +1889,11 @@ SetIntFromAny(interp, objPtr)
if (end == p) {
badInteger:
if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
- */
-
- char buf[100];
- sprintf(buf, "expected integer but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_Obj *msg =
+ Tcl_NewStringObj("expected integer but got \"", -1);
+ TclAppendLimitedToObj(msg, string, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
@@ -2253,15 +2240,11 @@ SetWideIntFromAny(interp, objPtr)
if (end == p) {
badInteger:
if (interp != NULL) {
- /*
- * Must copy string before resetting the result in case a caller
- * is trying to convert the interpreter's result to an int.
- */
-
- char buf[100];
- sprintf(buf, "expected integer but got \"%.50s\"", string);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_Obj *msg =
+ Tcl_NewStringObj("expected integer but got \"", -1);
+ TclAppendLimitedToObj(msg, string, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
index a0c0316..84094f4 100644
--- a/generic/tclParseExpr.c
+++ b/generic/tclParseExpr.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: tclParseExpr.c,v 1.18 2003/09/12 23:55:34 dkf Exp $
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.19 2003/10/14 15:44:53 dgp Exp $
*/
#include "tclInt.h"
@@ -2162,19 +2162,12 @@ LogSyntaxError(infoPtr, extraInfo)
CONST char *extraInfo; /* String to provide extra information
* about the syntax error. */
{
- int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
- char buffer[100];
-
- if (numBytes > 60) {
- sprintf(buffer, "syntax error in expression \"%.60s...\"",
- infoPtr->originalExpr);
- } else {
- sprintf(buffer, "syntax error in expression \"%.*s\"",
- numBytes, infoPtr->originalExpr);
- }
- Tcl_ResetResult(infoPtr->parsePtr->interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
- buffer, ": ", extraInfo, (char *) NULL);
+ Tcl_Obj *result =
+ Tcl_NewStringObj("syntax error in expression \"", -1);
+ TclAppendLimitedToObj(result, infoPtr->originalExpr,
+ (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL);
+ Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL);
+ Tcl_SetObjResult(infoPtr->parsePtr->interp, result);
infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
infoPtr->parsePtr->term = infoPtr->start;
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 92fba97..9f0b46b 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.46 2003/05/08 00:44:29 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.47 2003/10/14 15:44:53 dgp Exp $
*/
#include "tclInt.h"
@@ -1172,24 +1172,21 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
}
}
if (bodyPtr->typePtr != &tclByteCodeType) {
+#ifdef TCL_COMPILE_DEBUG
int numChars;
char *ellipsis;
-#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 1) {
/*
* Display a line summarizing the top level command we
* are about to compile.
*/
-
- numChars = strlen(procName);
- ellipsis = "";
- if (numChars > 50) {
- numChars = 50;
- ellipsis = "...";
- }
- fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
- description, numChars, procName, ellipsis);
+ Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1);
+ Tcl_IncrRefCount(message);
+ Tcl_AppendStringsToObj(message, description, " \"", NULL);
+ TclAppendLimitedToObj(message, procName, -1, 50, NULL);
+ fprintf(stdout, "%s\"\n", Tcl_GetString(message));
+ Tcl_DecrRefCount(message);
}
#endif
@@ -1219,19 +1216,19 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
if (result != TCL_OK) {
if (result == TCL_ERROR) {
- char buf[100 + TCL_INTEGER_SPACE];
-
- numChars = strlen(procName);
- ellipsis = "";
- if (numChars > 50) {
- numChars = 50;
- ellipsis = "...";
- }
- sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
- description, numChars, procName, ellipsis,
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buf, -1);
- }
+ Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
+ Tcl_Obj *message =
+ Tcl_NewStringObj("\n (compiling ", -1);
+ Tcl_IncrRefCount(message);
+ Tcl_AppendStringsToObj(message, description, " \"", NULL);
+ TclAppendLimitedToObj(message, procName, -1, 50, NULL);
+ Tcl_AppendToObj(message, "\", line ", -1);
+ Tcl_AppendObjToObj(message, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(message, ")", -1);
+ TclAppendObjToErrorInfo(interp, message);
+ Tcl_DecrRefCount(message);
+ }
return result;
}
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -1289,8 +1286,7 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
int returnCode; /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
- char msg[100 + TCL_INTEGER_SPACE];
- char *ellipsis = "";
+ Tcl_Obj *message, *errorLine;
if (returnCode == TCL_OK) {
return TCL_OK;
@@ -1307,13 +1303,16 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
? "invoked \"break\" outside of a loop"
: "invoked \"continue\" outside of a loop"), -1);
}
- if (nameLen > 60) {
- nameLen = 60;
- ellipsis = "...";
- }
- sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
- ellipsis, iPtr->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
+ errorLine = Tcl_NewIntObj(interp->errorLine);
+ message = Tcl_NewStringObj("\n (procedure \"", -1);
+ Tcl_IncrRefCount(message);
+ TclAppendLimitedToObj(message, procName, nameLen, 60, NULL);
+ Tcl_AppendToObj(message, "\" line ", -1);
+ Tcl_AppendObjToObj(message, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(message, ")", -1);
+ TclAppendObjToErrorInfo(interp, message);
+ Tcl_DecrRefCount(message);
return TCL_ERROR;
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 5925451..ed2dba7 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.32 2003/02/19 16:43:28 das Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.33 2003/10/14 15:44:53 dgp Exp $ */
#include "tclInt.h"
@@ -991,9 +991,10 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
/*
*----------------------------------------------------------------------
*
- * Tcl_AppendToObj --
+ * TclAppendLimitedToObj --
*
- * This procedure appends a sequence of bytes to an object.
+ * This procedure appends a limited number of bytes from a sequence
+ * of bytes to an object, marking any limitation with an ellipsis.
*
* Results:
* None.
@@ -1006,20 +1007,26 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
*/
void
-Tcl_AppendToObj(objPtr, bytes, length)
+TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST char *bytes; /* Points to the bytes to append to the
* object. */
- register int length; /* The number of bytes to append from
- * "bytes". If < 0, then append all bytes
- * up to NULL byte. */
+ register int length; /* The number of bytes available to be
+ * appended from "bytes". If < 0, then
+ * all bytes up to a NULL byte are available. */
+ register int limit; /* The maximum number of bytes to append
+ * to the object. */
+ CONST char *ellipsis; /* Ellipsis marker string, appended to
+ * the object to indicate not all available
+ * bytes at "bytes" were appended. */
{
String *stringPtr;
+ int toCopy = 0;
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_AppendToObj called with shared object");
+ panic("TclAppendLimitedToObj called with shared object");
}
-
+
SetStringFromAny(NULL, objPtr);
if (length < 0) {
@@ -1029,6 +1036,15 @@ Tcl_AppendToObj(objPtr, bytes, length)
return;
}
+ if (length <= limit) {
+ toCopy = length;
+ } else {
+ if (ellipsis == NULL) {
+ ellipsis = "...";
+ }
+ toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
+ }
+
/*
* If objPtr has a valid Unicode rep, then append the Unicode
* conversion of "bytes" to the objPtr's Unicode rep, otherwise
@@ -1037,12 +1053,51 @@ Tcl_AppendToObj(objPtr, bytes, length)
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
- AppendUtfToUnicodeRep(objPtr, bytes, length);
+ AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
+ } else {
+ AppendUtfToUtfRep(objPtr, bytes, toCopy);
+ }
- stringPtr = GET_STRING(objPtr);
+ if (length <= limit) {
+ return;
+ }
+
+ stringPtr = GET_STRING(objPtr);
+ if (stringPtr->hasUnicode != 0) {
+ AppendUtfToUnicodeRep(objPtr, ellipsis, -1);
} else {
- AppendUtfToUtfRep(objPtr, bytes, length);
+ AppendUtfToUtfRep(objPtr, ellipsis, -1);
}
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendToObj --
+ *
+ * This procedure appends a sequence of bytes to an object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The bytes at *bytes are appended to the string representation
+ * of objPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendToObj(objPtr, bytes, length)
+ register Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST char *bytes; /* Points to the bytes to append to the
+ * object. */
+ register int length; /* The number of bytes to append from
+ * "bytes". If < 0, then append all bytes
+ * up to NULL byte. */
+{
+ TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
}
/*
diff --git a/library/init.tcl b/library/init.tcl
index 8957ae4..5f69a88 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.57 2003/09/23 04:49:40 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.58 2003/10/14 15:44:53 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -220,8 +220,12 @@ proc unknown args {
# construct the stack trace.
#
set cinfo $args
- if {[string length $cinfo] > 150} {
- set cinfo "[string range $cinfo 0 149]..."
+ if {[string bytelength $cinfo] > 153} {
+ set cinfo [string range $cinfo 0 152]
+ while {[string bytelength $cinfo] > 150} {
+ set cinfo [string range $cinfo 0 end-1]
+ }
+ append cinfo ...
}
append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
@@ -253,7 +257,7 @@ proc unknown args {
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $expect $errorInfo]
+ [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
}
return -code error -errorcode $errorCode \
-errorinfo $einfo $msg
diff --git a/mac/tclMacResource.c b/mac/tclMacResource.c
index 52b3587..2403ebf 100644
--- a/mac/tclMacResource.c
+++ b/mac/tclMacResource.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMacResource.c,v 1.17 2003/10/01 14:33:49 das Exp $
+ * RCS: @(#) $Id: tclMacResource.c,v 1.18 2003/10/14 15:44:53 dgp Exp $
*/
#include <Errors.h>
@@ -1254,7 +1254,6 @@ Tcl_MacEvalResource(
{
Handle sourceText;
Str255 rezName;
- char msg[200];
int result, iOpenedResFile = false;
short saveRef, fileRef = -1;
char idStr[64];
@@ -1334,10 +1333,17 @@ Tcl_MacEvalResource(
if (result == TCL_RETURN) {
result = TCL_OK;
} else if (result == TCL_ERROR) {
- sprintf(msg, "\n (rsrc \"%.150s\" line %d)",
- resourceName,
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
+ Tcl_Obj *msg = Tcl_NewStringObj("\n (rsrc \"", -1);
+ Tcl_IncrRefCount(errorLine);
+ Tcl_IncrRefCount(msg);
+ TclAppendLimitedToObj(msg, resourceName, -1, 150, "");
+ Tcl_AppendToObj(msg, "\" line ", -1);
+ Tcl_AppendObjToObj(msg, errorLine);
+ Tcl_DecrRefCount(errorLine);
+ Tcl_AppendToObj(msg, ")", -1);
+ TclAppendObjToErrorInfo(interp, msg);
+ Tcl_DecrRefCount(msg);
}
goto rezEvalCleanUp;