From 875ed401f93f459fbac8cfd682d6e015b10f7ad3 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 13:55:06 +0000 Subject: More generation of error codes ([format], [after], [trace], RE optimizer). --- ChangeLog | 6 +++ generic/tclBasic.c | 126 ++++++++++++++++++++++++------------------------- generic/tclStringObj.c | 22 ++++++++- generic/tclTimer.c | 34 +++++++------ generic/tclTrace.c | 8 ++++ generic/tclUtil.c | 11 ++++- 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 + + * 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 * 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; -- cgit v0.12