From b48c6ea6c1f6c8a6cf870c15799cf33cb88d0b7d Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 18 Jul 2003 23:35:37 +0000
Subject: * generic/tclBasic.c: Corrected several instances of unsafe
* generic/tclCompile.c: truncation of UTF-8 strings that might
* generic/tclProc.c: break apart a multi-byte character. *
library/init.tcl: [Bug 760872] * tests/init.test:
---
ChangeLog | 6 ++++++
generic/tclBasic.c | 59 ++++++++++++++++++++++++++++++++++------------------
generic/tclCompile.c | 10 ++++++++-
generic/tclProc.c | 18 +++++++++++++++-
library/init.tcl | 10 +++++----
tests/init.test | 12 +++++------
6 files changed, 82 insertions(+), 33 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 71a314b..bc64fd4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -14,6 +14,12 @@
2003-07-18 Don Porter <dgp@users.sourceforge.net>
+ * generic/tclBasic.c: Corrected several instances of unsafe
+ * generic/tclCompile.c: truncation of UTF-8 strings that might
+ * generic/tclProc.c: break apart a multi-byte character.
+ * library/init.tcl: [Bug 760872]
+ * tests/init.test:
+
* doc/tcltest.n: Restored the [Eval] proc to replace
* library/tcltest/tcltest.tcl: the [::puts] command when either the
-output or -error option for [test] is in use, in order to capture
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 80f5bda..629293f 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.75.2.4 2003/06/10 19:58:34 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.5 2003/07/18 23:35:38 dgp Exp $
*/
#include "tclInt.h"
@@ -3304,6 +3304,14 @@ Tcl_LogCommandInfo(interp, script, command, length)
length = 150;
ellipsis = "...";
}
+ while ( (command[length] & 0xC0) == 0x80 ) {
+ /*
+ * Back up truncation point so that we don't truncate in the
+ * middle of a multi-byte character (in UTF-8)
+ */
+ length--;
+ ellipsis = "...";
+ }
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buffer, "\n while executing\n\"%.*s%s\"",
length, command, ellipsis);
@@ -4562,8 +4570,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;
@@ -4656,29 +4663,41 @@ 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_Obj *msg;
- Tcl_DStringInit(&ds);
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
+ msg = Tcl_NewStringObj("\n while invoking\n\"", -1);
} else {
- Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
+ msg = Tcl_NewStringObj("\n invoked from within\n\"", -1);
}
+ Tcl_IncrRefCount(msg);
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;
- }
+ CONST char *bytes;
+ int length;
+
+ Tcl_AppendObjToObj(msg, objv[i]);
+ bytes = Tcl_GetStringFromObj(msg, &length);
+ if (length > 100) {
+ /*
+ * Back up truncation point so that we don't truncate
+ * in the middle of a multi-byte character.
+ */
+ length = 100;
+ while ( (bytes[length] & 0xC0) == 0x80 ) {
+ length--;
+ }
+ Tcl_SetObjLength(msg, length);
+ Tcl_AppendToObj(msg, "...", -1);
+ break;
+ }
+ if (i != (objc - 1)) {
+ Tcl_AppendToObj(msg, " ", -1);
+ }
}
-
- Tcl_DStringAppend(&ds, "\"", -1);
- Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
- Tcl_DStringFree(&ds);
+
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
+ Tcl_DecrRefCount(msg);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 46628b1..6c619e9 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.43.2.2 2003/04/18 21:54:24 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.43.2.3 2003/07/18 23:35:38 dgp Exp $
*/
#include "tclInt.h"
@@ -1727,6 +1727,14 @@ LogCompilationInfo(interp, script, command, length)
length = 150;
ellipsis = "...";
}
+ while ( (command[length] & 0xC0) == 0x80 ) {
+ /*
+ * Back up truncation point so that we don't truncate in the
+ * middle of a multi-byte character (in UTF-8)
+ */
+ length--;
+ ellipsis = "...";
+ }
sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
length, command, ellipsis);
Tcl_AddObjErrorInfo(interp, buffer, -1);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4e3d4b8..1ec50f1 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.44 2002/12/11 21:29:52 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.44.2.1 2003/07/18 23:35:39 dgp Exp $
*/
#include "tclInt.h"
@@ -1229,6 +1229,14 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
numChars = 50;
ellipsis = "...";
}
+ while ( (procName[numChars] & 0xC0) == 0x80 ) {
+ /*
+ * Back up truncation point so that we don't truncate
+ * in the middle of a multi-byte character (in UTF-8)
+ */
+ numChars--;
+ ellipsis = "...";
+ }
sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
description, numChars, procName, ellipsis,
interp->errorLine);
@@ -1313,6 +1321,14 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
nameLen = 60;
ellipsis = "...";
}
+ while ( (procName[nameLen] & 0xC0) == 0x80 ) {
+ /*
+ * Back up truncation point so that we don't truncate in the
+ * middle of a multi-byte character (in UTF-8)
+ */
+ nameLen--;
+ ellipsis = "...";
+ }
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
ellipsis, iPtr->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
diff --git a/library/init.tcl b/library/init.tcl
index e5a5d0f..8ad26f9 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.55 2002/11/23 01:41:35 hobbs Exp $
+# RCS: @(#) $Id: init.tcl,v 1.55.2.1 2003/07/18 23:35:39 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -220,10 +220,12 @@ proc unknown args {
# construct the stack trace.
#
set cinfo $args
- if {[string length $cinfo] > 150} {
- set cinfo "[string range $cinfo 0 149]..."
+ set ellipsis ""
+ while {[string bytelength $cinfo] > 150} {
+ set cinfo [string range $cinfo 0 end-1]
+ set ellipsis "..."
}
- append cinfo "\"\n (\"uplevel\" body line 1)"
+ append cinfo $ellipsis "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
#
diff --git a/tests/init.test b/tests/init.test
index 6881c93..67a23a6 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -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: init.test,v 1.9 2002/06/05 01:12:38 dgp Exp $
+# RCS: @(#) $Id: init.test,v 1.9.2.1 2003/07/18 23:35:39 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -67,10 +67,6 @@ interp eval $testInterp [list namespace import -force ::tcltest::*]
interp eval $testInterp {
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
-}
-
auto_reset
catch {rename parray {}}
@@ -154,7 +150,7 @@ test init-3.0 {random stuff in the auto_index, should still work} {
# should be the same.
set count 0
-foreach arg {
+foreach arg [subst -nocommands -novariables {
c
{argument
which spans
@@ -174,7 +170,8 @@ foreach arg {
error stack cannot be uniquely determined.
foo bar
"}
- } {
+ {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
+ }] {
test init-4.$count.0 {::errorInfo produced by [unknown]} {
auto_reset
@@ -200,6 +197,7 @@ foreach arg {
incr count
}
+cleanupTests
} ;# End of [interp eval $testInterp]
# cleanup
--
cgit v0.12