summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-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
12 files changed, 247 insertions, 191 deletions
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);
}
/*
generated by cgit v0.12 at 2024-11-18 19:07:56 (GMT)