summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclBasic.c126
-rw-r--r--generic/tclStringObj.c22
-rw-r--r--generic/tclTimer.c34
-rw-r--r--generic/tclTrace.c8
-rw-r--r--generic/tclUtil.c11
6 files changed, 125 insertions, 82 deletions
diff --git a/ChangeLog b/ChangeLog
index 63e4391..4724598 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-04 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c,
+ * generic/tclTrace.c, generic/tclUtil.c: More generation of error
+ codes ([format], [after], [trace], RE optimizer).
+
2011-04-04 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclCmdAH.c: Better error-message in case of errors
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b34209b..f00864f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2498,7 +2498,8 @@ TclRenameCommand(
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
Tcl_AppendResult(interp, "can't rename to \"", newName,
"\": command already exists", NULL);
- Tcl_SetErrorCode(interp, "TCL", "RENAME", "TARGET_EXISTS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
+ "TARGET_EXISTS", NULL);
result = TCL_ERROR;
goto done;
}
@@ -3883,82 +3884,79 @@ Tcl_Canceled(
register Interp *iPtr = (Interp *) interp;
/*
- * Has the current script in progress for this interpreter been
- * canceled or is the stack being unwound due to the previous script
- * cancellation?
- */
+ * Has the current script in progress for this interpreter been canceled
+ * or is the stack being unwound due to the previous script cancellation?
+ */
- if (TclCanceled(iPtr)) {
- /*
- * The CANCELED flag is a one-shot flag that is reset immediately
- * upon being detected; however, if the TCL_CANCEL_UNWIND flag is
- * set we will continue to report that the script in progress has
- * been canceled thereby allowing the evaluation stack for the
- * interp to be fully unwound.
- */
+ if (!TclCanceled(iPtr)) {
+ return TCL_OK;
+ }
- iPtr->flags &= ~CANCELED;
+ /*
+ * The CANCELED flag is a one-shot flag that is reset immediately upon
+ * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
+ * continue to report that the script in progress has been canceled
+ * thereby allowing the evaluation stack for the interp to be fully
+ * unwound.
+ */
- /*
- * The CANCELED flag was detected and reset; however, if the
- * caller specified the TCL_CANCEL_UNWIND flag, we only return
- * TCL_ERROR (indicating that the script in progress has been
- * canceled) if the evaluation stack for the interp is being fully
- * unwound.
- */
+ iPtr->flags &= ~CANCELED;
- if (!(flags & TCL_CANCEL_UNWIND)
- || (iPtr->flags & TCL_CANCEL_UNWIND)) {
- /*
- * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error
- * in the interp's result; otherwise, we leave it alone.
- */
+ /*
+ * The CANCELED flag was detected and reset; however, if the caller
+ * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
+ * (indicating that the script in progress has been canceled) if the
+ * evaluation stack for the interp is being fully unwound.
+ */
- if (flags & TCL_LEAVE_ERR_MSG) {
- const char *id, *message = NULL;
- int length;
+ if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
+ return TCL_OK;
+ }
- /*
- * Setup errorCode variables so that we can differentiate
- * between being canceled and unwound.
- */
+ /*
+ * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
+ * interp's result; otherwise, we leave it alone.
+ */
- if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg,
- &length);
- } else {
- length = 0;
- }
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ const char *id, *message = NULL;
+ int length;
- if (iPtr->flags & TCL_CANCEL_UNWIND) {
- id = "IUNWIND";
- if (length == 0) {
- message = "eval unwound";
- }
- } else {
- id = "ICANCEL";
- if (length == 0) {
- message = "eval canceled";
- }
- }
+ /*
+ * Setup errorCode variables so that we can differentiate between
+ * being canceled and unwound.
+ */
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, NULL);
- Tcl_SetErrorCode(interp, "TCL", id, message, NULL);
- }
+ if (iPtr->asyncCancelMsg != NULL) {
+ message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ } else {
+ length = 0;
+ }
- /*
- * Return TCL_ERROR to the caller (not necessarily just the
- * Tcl core itself) that indicates further processing of the
- * script or command in progress should halt gracefully and as
- * soon as possible.
- */
+ if (iPtr->flags & TCL_CANCEL_UNWIND) {
+ id = "IUNWIND";
+ if (length == 0) {
+ message = "eval unwound";
+ }
+ } else {
+ id = "ICANCEL";
+ if (length == 0) {
+ message = "eval canceled";
+ }
+ }
- return TCL_ERROR;
- }
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
}
- return TCL_OK;
+ /*
+ * Return TCL_ERROR to the caller (not necessarily just the Tcl core
+ * itself) that indicates further processing of the script or command in
+ * progress should halt gracefully and as soon as possible.
+ */
+
+ return TCL_ERROR;
}
/*
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index cf635bc..fe6d0af 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1609,7 +1609,6 @@ AppendUtfToUtfRep(
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
}
-
/*
*----------------------------------------------------------------------
@@ -1706,7 +1705,7 @@ Tcl_AppendFormatToObj(
int objc,
Tcl_Obj *const objv[])
{
- const char *span = format, *msg;
+ const char *span = format, *msg, *errCode;
int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
int originalLength, limit;
static const char *mixedXPG =
@@ -1744,6 +1743,7 @@ Tcl_AppendFormatToObj(
if (numBytes) {
if (numBytes > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(appendObj, span, numBytes);
@@ -1783,18 +1783,21 @@ Tcl_AppendFormatToObj(
if (newXpg) {
if (gotSequential) {
msg = mixedXPG;
+ errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotXpg = 1;
} else {
if (gotXpg) {
msg = mixedXPG;
+ errCode = "MIXEDSPECTYPES";
goto errorMsg;
}
gotSequential = 1;
}
if ((objIndex < 0) || (objIndex >= objc)) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
@@ -1842,6 +1845,7 @@ Tcl_AppendFormatToObj(
} else if (ch == '*') {
if (objIndex >= objc - 1) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
@@ -1857,6 +1861,7 @@ Tcl_AppendFormatToObj(
}
if (width > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
@@ -1877,6 +1882,7 @@ Tcl_AppendFormatToObj(
} else if (ch == '*') {
if (objIndex >= objc - 1) {
msg = badIndex[gotXpg];
+ errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
if (TclGetIntFromObj(interp, objv[objIndex], &precision)
@@ -1934,6 +1940,7 @@ Tcl_AppendFormatToObj(
switch (ch) {
case '\0':
msg = "format string ended in middle of field specifier";
+ errCode = "INCOMPLETE";
goto errorMsg;
case 's':
if (gotPrecision) {
@@ -1963,6 +1970,7 @@ Tcl_AppendFormatToObj(
case 'u':
if (useBig) {
msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
goto errorMsg;
}
case 'd':
@@ -2110,6 +2118,7 @@ Tcl_AppendFormatToObj(
}
if (toAppend > segmentLimit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(segment, bytes, toAppend);
@@ -2165,6 +2174,7 @@ Tcl_AppendFormatToObj(
}
if (numDigits > INT_MAX) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
} else if (!useBig) {
@@ -2232,6 +2242,7 @@ Tcl_AppendFormatToObj(
}
if (toAppend > segmentLimit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendObjToObj(segment, pure);
@@ -2285,6 +2296,7 @@ Tcl_AppendFormatToObj(
p += sprintf(p, "%d", precision);
if (precision > INT_MAX - length) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
length += precision;
@@ -2301,11 +2313,13 @@ Tcl_AppendFormatToObj(
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
break;
@@ -2314,6 +2328,7 @@ Tcl_AppendFormatToObj(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
}
goto error;
}
@@ -2345,6 +2360,7 @@ Tcl_AppendFormatToObj(
Tcl_DecrRefCount(segment);
}
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendObjToObj(appendObj, segment);
@@ -2367,6 +2383,7 @@ Tcl_AppendFormatToObj(
if (numBytes) {
if (numBytes > limit) {
msg = overflow;
+ errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(appendObj, span, numBytes);
@@ -2379,6 +2396,7 @@ Tcl_AppendFormatToObj(
errorMsg:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
}
error:
Tcl_SetObjLength(appendObj, originalLength);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index b6c9208..6682d21 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -831,9 +831,12 @@ Tcl_AfterObjCmd(
&index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
- Tcl_AppendResult(interp, "bad argument \"",
- Tcl_GetString(objv[1]),
+ const char *arg = Tcl_GetString(objv[1]);
+
+ Tcl_AppendResult(interp, "bad argument \"", arg,
"\": must be cancel, idle, info, or an integer", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
+ arg, NULL);
return TCL_ERROR;
}
}
@@ -947,9 +950,7 @@ Tcl_AfterObjCmd(
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
- case AFTER_INFO: {
- Tcl_Obj *resultListPtr;
-
+ case AFTER_INFO:
if (objc == 2) {
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
@@ -966,17 +967,22 @@ Tcl_AfterObjCmd(
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]),
- "\" doesn't exist", NULL);
+ const char *eventStr = TclGetString(objv[2]);
+
+ Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
- }
- resultListPtr = Tcl_NewObj();
- Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
- Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (afterPtr->token == NULL) ? "idle" : "timer", -1));
- Tcl_SetObjResult(interp, resultListPtr);
+ } else {
+ Tcl_Obj *resultListPtr = Tcl_NewObj();
+
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ afterPtr->commandPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (afterPtr->token == NULL) ? "idle" : "timer", -1));
+ Tcl_SetObjResult(interp, resultListPtr);
+ }
break;
- }
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index d5fb6f6..a60a80b 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -368,6 +368,7 @@ Tcl_TraceObjCmd(
badVarOps:
Tcl_AppendResult(interp, "bad operations \"", flagOps,
"\": should be one or more of rwua", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
@@ -436,6 +437,8 @@ TraceExecutionObjCmd(
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of enter, leave, enterstep, or leavestep",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
@@ -676,6 +679,8 @@ TraceCommandObjCmd(
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of delete or rename", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
@@ -872,6 +877,8 @@ TraceVariableObjCmd(
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of array, read, unset, or write", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
@@ -2021,6 +2028,7 @@ TraceVarProc(
}
if (code != TCL_OK) { /* copy error msg to result */
Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 5e1efde..64aa824 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -470,6 +470,8 @@ Tcl_SplitList(
if (interp != NULL) {
Tcl_SetResult(interp, "internal error in Tcl_SplitList",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
+ NULL);
}
return TCL_ERROR;
}
@@ -3270,7 +3272,7 @@ TclReToGlob(
{
int anchorLeft, anchorRight, lastIsStar, numStars;
char *dsStr, *dsStrStart;
- const char *msg, *p, *strEnd;
+ const char *msg, *p, *strEnd, *code;
strEnd = reStr + reStrLen;
Tcl_DStringInit(dsPtr);
@@ -3324,6 +3326,7 @@ TclReToGlob(
*/
msg = NULL;
+ code = NULL;
p = reStr;
anchorRight = 0;
lastIsStar = 0;
@@ -3380,6 +3383,7 @@ TclReToGlob(
break;
default:
msg = "invalid escape sequence";
+ code = "BADESCAPE";
goto invalidGlob;
}
break;
@@ -3408,6 +3412,7 @@ TclReToGlob(
case '$':
if (p+1 != strEnd) {
msg = "$ not anchor";
+ code = "NONANCHOR";
goto invalidGlob;
}
anchorRight = 1;
@@ -3415,8 +3420,8 @@ TclReToGlob(
case '*': case '+': case '?': case '|': case '^':
case '{': case '}': case '(': case ')': case '[': case ']':
msg = "unhandled RE special char";
+ code = "UNHANDLED";
goto invalidGlob;
- break;
default:
*dsStr++ = *p;
break;
@@ -3430,6 +3435,7 @@ TclReToGlob(
*/
msg = "excessive recursive glob backtrack potential";
+ code = "OVERCOMPLEX";
goto invalidGlob;
}
@@ -3458,6 +3464,7 @@ TclReToGlob(
#endif
if (interp != NULL) {
Tcl_AppendResult(interp, msg, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
generated by cgit v0.12 at 2024-07-15 19:57:08 (GMT)