diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclBasic.c | 59 | ||||
| -rw-r--r-- | generic/tclCompile.c | 10 | ||||
| -rw-r--r-- | generic/tclProc.c | 18 | ||||
| -rw-r--r-- | library/init.tcl | 10 | ||||
| -rw-r--r-- | tests/init.test | 12 |
6 files changed, 82 insertions, 33 deletions
@@ -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 |