diff options
| -rw-r--r-- | ChangeLog | 30 | ||||
| -rw-r--r-- | generic/tclBasic.c | 98 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 18 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 16 | ||||
| -rw-r--r-- | generic/tclCompile.c | 26 | ||||
| -rw-r--r-- | generic/tclExecute.c | 13 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 18 | ||||
| -rw-r--r-- | generic/tclInt.h | 7 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 18 | ||||
| -rw-r--r-- | generic/tclObj.c | 59 | ||||
| -rw-r--r-- | generic/tclParseExpr.c | 21 | ||||
| -rw-r--r-- | generic/tclProc.c | 65 | ||||
| -rw-r--r-- | generic/tclStringObj.c | 79 | ||||
| -rw-r--r-- | library/init.tcl | 12 | ||||
| -rw-r--r-- | mac/tclMacResource.c | 18 |
15 files changed, 297 insertions, 201 deletions
@@ -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; |