diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | generic/tclBasic.c | 19 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 22 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 20 | ||||
| -rw-r--r-- | generic/tclStringObj.c | 36 | ||||
| -rw-r--r-- | library/init.tcl | 6 |
6 files changed, 70 insertions, 47 deletions
@@ -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] } |