diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 42 | ||||
| -rw-r--r-- | generic/tclConfig.c | 7 | ||||
| -rw-r--r-- | generic/tclUtil.c | 101 |
4 files changed, 107 insertions, 47 deletions
@@ -1,5 +1,9 @@ 2011-03-28 Donal K. Fellows <dkf@users.sf.net> + * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More + generation of errorCode information, notably when lists are + mis-parsed. + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the error messages generated by the variable management code rather than creating our own. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e39ae06..61de8de 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1794,6 +1794,8 @@ StringMapCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -1856,6 +1858,8 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } } @@ -2057,6 +2061,8 @@ StringMatchCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -2189,6 +2195,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } length2 = length1 * count; @@ -2209,6 +2216,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } for (index = 0; index < count; index++) { @@ -2514,6 +2522,8 @@ StringEqualCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -2661,6 +2671,8 @@ StringCmpCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -3558,6 +3570,8 @@ TclNRSwitchObjCmd( Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); return TCL_ERROR; } foundmode = 1; @@ -3574,6 +3588,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-indexvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3584,6 +3600,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-matchvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3601,11 +3619,15 @@ TclNRSwitchObjCmd( if (indexVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-indexvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-matchvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } @@ -3653,6 +3675,8 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3669,6 +3693,8 @@ TclNRSwitchObjCmd( "comment incorrectly placed outside of a " "switch body - see the \"switch\" " "documentation", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -3686,6 +3712,8 @@ TclNRSwitchObjCmd( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -4006,6 +4034,8 @@ Tcl_ThrowObjCmd( return TCL_ERROR; } else if (len < 1) { Tcl_AppendResult(interp, "type must be non-empty list", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); return TCL_ERROR; } @@ -4189,12 +4219,16 @@ TclNRTryObjCmd( if (i < objc-2) { Tcl_AppendResult(interp, "finally clause must be last", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "NONTERMINAL", NULL); return TCL_ERROR; } else if (i == objc-1) { Tcl_AppendResult(interp, "wrong # args to finally clause: ", "must be \"", TclGetString(objv[0]), " ... finally script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); return TCL_ERROR; } finallyObj = objv[++i]; @@ -4206,6 +4240,8 @@ TclNRTryObjCmd( "must be \"", TclGetString(objv[0]), " ... on code variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); return TCL_ERROR; } if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { @@ -4221,6 +4257,8 @@ TclNRTryObjCmd( "must be \"... trap pattern variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); return TCL_ERROR; } code = 1; @@ -4229,6 +4267,8 @@ TclNRTryObjCmd( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); return TCL_ERROR; } info[2] = objv[i+1]; @@ -4260,6 +4300,8 @@ TclNRTryObjCmd( "last non-finally clause must not have a body of \"-\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); return TCL_ERROR; } if (!haveHandlers) { diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 8d42e21..3ad5dfd 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -237,6 +237,8 @@ QueryConfigObjCmd( */ Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } @@ -247,9 +249,11 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } @@ -268,6 +272,7 @@ QueryConfigObjCmd( if (!listPtr) { Tcl_SetResult(interp, "insufficient memory to create list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 69bd4d2..5e1efde 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -221,6 +221,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -280,6 +282,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -297,12 +301,16 @@ TclFindElement( if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + NULL); } return TCL_ERROR; } @@ -451,9 +459,6 @@ Tcl_SplitList( &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL); - } ckfree(argv); return result; } @@ -2119,10 +2124,9 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char* digits; - char* end; - - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + char *digits; + char *end; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * Handle NaN. @@ -2156,26 +2160,26 @@ Tcl_PrintDouble( if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having - * $tcl_precision digits of significance that is nearest to the - * given number, breaking ties by rounding to even, and then - * trimming trailing zeros." This gives the greatest possible - * precision in the decimal string, but offers the anomaly that - * [expr 0.1] will be "0.10000000000000001". + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". * - * The second is "choose the decimal representation having at - * most $tcl_precision digits of significance that is nearest - * to the given number. If no such representation converts - * exactly to the given number, choose the one that is closest, - * breaking ties by rounding to even. If more than one such - * representation converts exactly to the given number, choose - * the shortest, breaking ties in favour of the nearest, breaking - * remaining ties in favour of the one ending in an even digit." + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: @@ -2188,13 +2192,13 @@ Tcl_PrintDouble( * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, - * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we - * prefer the first (the recommended zero value for tcl_precision - * avoids the problem entirely). + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). * - * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the - * method that allows floating point values to be shortened if - * it can be done without loss of precision. + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, @@ -2219,10 +2223,12 @@ Tcl_PrintDouble( c = *++p; } } + /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ + if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { @@ -2410,6 +2416,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -2434,19 +2441,19 @@ TclNeedSpace( * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%ld", n) but is faster - * as proven in benchmarks. This is key to UpdateStringOfInt, which - * is a common path for a lot of code (e.g. int-indexed arrays). + * the end of the formatted characters. It is the caller's responsibility + * to ensure that enough storage is available. This procedure has the + * effect of sprintf(buffer, "%ld", n) but is faster as proven in + * benchmarks. This is key to UpdateStringOfInt, which is a common path + * for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. + * The formatted characters are written into the storage pointer to by + * the "buffer" argument. * *---------------------------------------------------------------------- */ @@ -2733,7 +2740,7 @@ SetEndOffsetFromAny( */ if (isspace(UCHAR(bytes[4]))) { - return TCL_ERROR; + goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -2746,6 +2753,7 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, @@ -2853,7 +2861,8 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2910,7 +2919,7 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); @@ -2996,8 +3005,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3273,9 +3281,10 @@ TclReToGlob( if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to - * backslash escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to backslash + * escape every character and have * at each end. */ + Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; @@ -3299,8 +3308,8 @@ TclReToGlob( } /* - * At most, the glob pattern has length reStrLen + 2 to account - * for possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account for + * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); @@ -3310,9 +3319,8 @@ TclReToGlob( * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent - * multiple instances. Simpler than checking that the last star - * may be escaped. + * Keep track of the last char being an unescaped star to prevent multiple + * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; @@ -3420,6 +3428,7 @@ TclReToGlob( * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ + msg = "excessive recursive glob backtrack potential"; goto invalidGlob; } |