summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2011-03-29 15:06:26 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2011-03-29 15:06:26 (GMT)
commitce1706f3395619dee86a51d89a76c9537e4d8fe3 (patch)
tree7b42e235b3c15fbe37739b245bd70c1458f5fe72 /generic
parent5b43ec40f8e8d1787c1d12eec18205bfbf1fef1e (diff)
downloadtcl-ce1706f3395619dee86a51d89a76c9537e4d8fe3.zip
tcl-ce1706f3395619dee86a51d89a76c9537e4d8fe3.tar.gz
tcl-ce1706f3395619dee86a51d89a76c9537e4d8fe3.tar.bz2
More generation of errorCode information, notably when lists are mis-parsed.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCmdMZ.c42
-rw-r--r--generic/tclConfig.c7
-rw-r--r--generic/tclUtil.c101
3 files changed, 103 insertions, 47 deletions
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;
}