summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog14
-rw-r--r--generic/tclBasic.c19
-rw-r--r--generic/tclCmdMZ.c22
-rw-r--r--generic/tclIOUtil.c20
-rw-r--r--generic/tclStringObj.c36
-rw-r--r--library/init.tcl6
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]
}