* generic/tclStringObj.c: Bug fixes: ObjPrintfVA needed to

        support "*" fields and needed to interpret precision limits on
        %s conversions as a number of bytes, not Tcl_UniChars, to take
        from the (char *) argument.

        * generic/tclBasic.c:   Updated several callers to use
        * generic/tclCmdMZ.c:   TclFormatToErrorInfo().
        * generic/tclIOUtil.c:

        * library/init.tcl:     Keep [unknown] in sync with errorInfo
        formatting rules.

6 files changed, 70 insertions, 47 deletions

diff --git a/ChangeLog b/ChangeLog
index 7ca05b0..73e0bc6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,19 @@
 2005-09-13  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclStringObj.c:	Bug fixes: ObjPrintfVA needed to
+	support "*" fields and needed to interpret precision limits on
+	%s conversions as a number of bytes, not Tcl_UniChars, to take
+	from the (char *) argument.
+
+	* generic/tclBasic.c:	Updated several callers to use
+	* generic/tclCmdMZ.c:	TclFormatToErrorInfo().
+	* generic/tclIOUtil.c:
+
+	* library/init.tcl:	Keep [unknown] in sync with errorInfo
+	formatting rules.
+
+2005-09-13  Don Porter  <dgp@users.sourceforge.net>
+
 	* generic/tclBasic.c:	First caller of TclFormatToErrorInfo.
 
 	* generic/tclInt.h:		Using stdarg.h conventions, add more
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a038550..c70b5ad 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.171 2005/09/14 03:46:50 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.172 2005/09/14 17:13:18 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3540,7 +3540,7 @@ Tcl_LogCommandInfo(interp, script, command, length)
 {
     register CONST char *p;
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *message;
+    int overflow, limit = 150;
 
     if (iPtr->flags & ERR_ALREADY_LOGGED) {
 	/*
@@ -3562,16 +3562,11 @@ Tcl_LogCommandInfo(interp, script, command, length)
 	}
     }
 
-    if (iPtr->errorInfo == NULL) {
-	message = Tcl_NewStringObj("\n    while executing\n\"", -1);
-    } else {
-	message = Tcl_NewStringObj("\n    invoked from within\n\"", -1);
-    }
-    Tcl_IncrRefCount(message);
-    TclAppendLimitedToObj(message, command, length, 153, NULL);
-    Tcl_AppendToObj(message, "\"", -1);
-    TclAppendObjToErrorInfo(interp, message);
-    Tcl_DecrRefCount(message);
+    overflow = (length > limit);
+    TclFormatToErrorInfo(interp, "\n    %s\n\"%.*s%s\"",
+	    ((iPtr->errorInfo == NULL)
+	    ? "while executing" : "invoked from within"),
+	    (overflow ? limit : length), command, (overflow ? "..." : ""));
 }
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2a94eb8..e59360d 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,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.128 2005/08/26 13:26:55 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.129 2005/09/14 17:13:18 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2566,6 +2566,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase;
+    int patternLength;
     char *pattern;
     Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
     Tcl_Obj *CONST *savedObjv = objv;
@@ -2745,7 +2746,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
 	 * See if the pattern matches the string.
 	 */
 
-	pattern = TclGetString(objv[i]);
+	pattern = Tcl_GetStringFromObj(objv[i], &patternLength);
 
 	if ((i == objc - 2) && (*pattern == 'd')
 		&& (strcmp(pattern, "default") == 0)) {
@@ -2920,18 +2921,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
      */
 
     if (result == TCL_ERROR) {
-	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);
+	int limit = 50;
+	int overflow = (patternLength > limit);
+	TclFormatToErrorInfo(interp, "\n    (\"%.*s%s\" arm line %d)",
+		(overflow ? limit : patternLength), pattern,
+		(overflow ? "..." : ""), interp->errorLine);
     }
     return result;
 }
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index b540f90..124da3a 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.122 2005/08/31 15:12:18 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.123 2005/09/14 17:13:18 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1812,19 +1812,13 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
 	/*
 	 * Record information telling where the error occurred.
 	 */
-
-	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);
+	int limit = 150;
+	int overflow = (length > limit);
+
+	TclFormatToErrorInfo(interp, "\n    (file \"%.*s%s\" line %d)",
+		(overflow ? limit : length), pathString,
+		(overflow ? "..." : ""), interp->errorLine);
     }
 
   end:
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 802e94a..a2bce94 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.45 2005/09/14 03:46:50 dgp Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.46 2005/09/14 17:13:18 dgp Exp $ */
 
 #include "tclInt.h"
 
@@ -2284,12 +2284,14 @@ ObjPrintfVA(
     int code, objc;
     Tcl_Obj **objv, *list = Tcl_NewObj();
     CONST char *p;
+    char *end;
 
     p = format;
     Tcl_IncrRefCount(list);
     while (*p != '\0') {
-	int size = 0;
-	int seekingConversion = 1;
+	int size = 0, seekingConversion = 1, gotPrecision = 0;
+	int lastNum = -1, numBytes = -1;
+
 	if (*p++ != '%') {
 	    continue;
 	}
@@ -2304,9 +2306,18 @@ ObjPrintfVA(
 		seekingConversion = 0;
 		break;
 	    case 's':
-		Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(
-			va_arg(argList, char *), -1));
 		seekingConversion = 0;
+		if (gotPrecision) {
+		    numBytes = lastNum;
+		}
+		Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(
+			va_arg(argList, char *), numBytes));
+		/* We took no more than numBytes bytes from the (char *).
+		 * In turn, [format] will take no more than numBytes
+		 * characters from the Tcl_Obj.  Since numBytes characters
+		 * must be no less than numBytes bytes, the character limit
+		 * will have no effect and we can just pass it through.
+		 */
 		break;
 	    case 'c':
 	    case 'i':
@@ -2337,6 +2348,21 @@ ObjPrintfVA(
 			va_arg(argList, double)));
 		seekingConversion = 0;
 		break;
+	    case '*':
+		lastNum = (int)va_arg(argList, int);
+		Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
+		p++;
+		break;
+	    case '0': case '1': case '2': case '3': case '4':
+	    case '5': case '6': case '7': case '8': case '9':
+		lastNum = (int) strtoul(p, &end, 10);
+		p = end;
+		break;
+	    case '.':
+		gotPrecision = 1;
+		p++;
+		break;
+	    /* TODO: support for wide (and bignum?) arguments */
 	    case 'l':
 		size = 1;
 		p++;
diff --git a/library/init.tcl b/library/init.tcl
index 527f0b9..bd04e08 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.80 2005/08/24 17:56:23 andreas_kupries Exp $
+# RCS: @(#) $Id: init.tcl,v 1.81 2005/09/14 17:13:18 dgp Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -272,8 +272,8 @@ proc unknown args {
 		set errorInfo [dict get $opts -errorinfo]
 		set errorCode [dict get $opts -errorcode]
 		set cinfo $args
-		if {[string bytelength $cinfo] > 153} {
-		    set cinfo [string range $cinfo 0 152]
+		if {[string bytelength $cinfo] > 150} {
+		    set cinfo [string range $cinfo 0 150]
 		    while {[string bytelength $cinfo] > 150} {
 			set cinfo [string range $cinfo 0 end-1]
 		    }