diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 702 |
1 files changed, 477 insertions, 225 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c index dbbf10a..8a0d653 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -19,7 +19,7 @@ * above. This variable can be modified by the function below. */ -static char *tclPreInitScript = NULL; +static const char *tclPreInitScript = NULL; /* Forward declaration */ struct Target; @@ -225,6 +225,9 @@ static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static int AliasObjCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); +static int AliasNRCmd(ClientData dummy, + Tcl_Interp *currentInterp, int objc, + Tcl_Obj *const objv[]); static void AliasObjCmdDeleteProc(ClientData clientData); static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, @@ -276,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ +static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -294,11 +303,11 @@ static void TimeLimitCallback(ClientData clientData); *---------------------------------------------------------------------- */ -char * +const char * TclSetPreInitScript( - char *string) /* Pointer to a script. */ + const char *string) /* Pointer to a script. */ { - char *prevString = tclPreInitScript; + const char *prevString = tclPreInitScript; tclPreInitScript = string; return(prevString); } @@ -328,8 +337,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -464,7 +473,7 @@ TclInterpInit( Master *masterPtr; Slave *slavePtr; - interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + interpInfoPtr = ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; masterPtr = &interpInfoPtr->master; @@ -478,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -560,7 +570,7 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree(interpInfoPtr); } /* @@ -587,21 +597,34 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; int index; - static const char *options[] = { - "alias", "aliases", "bgerror", "create", - "debug", "delete", "eval", "exists", "expose", - "hide", "hidden", "issafe", "invokehidden", - "limit", "marktrusted", "recursionlimit","slaves", - "share", "target", "transfer", + static const char *const options[] = { + "alias", "aliases", "bgerror", "cancel", + "create", "debug", "delete", + "eval", "exists", "expose", + "hide", "hidden", "issafe", + "invokehidden", "limit", "marktrusted", "recursionlimit", + "slaves", "share", "target", "transfer", NULL }; enum option { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, - OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, - OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, - OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, - OPT_SHARE, OPT_TARGET, OPT_TRANSFER + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, + OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, + OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; if (objc < 2) { @@ -614,12 +637,12 @@ Tcl_InterpObjCmd( } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + Tcl_Interp *masterInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); + "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); @@ -637,29 +660,19 @@ Tcl_InterpObjCmd( if (masterInterp == NULL) { return TCL_ERROR; } - if (TclGetString(objv[5])[0] == '\0') { - if (objc == 6) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - } else { - return AliasCreate(interp, slaveInterp, masterInterp, objv[3], - objv[5], objc - 6, objv + 6); - } + + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); } goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - + case OPT_ALIASES: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - + case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; @@ -669,12 +682,83 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + case OPT_CANCEL: { + int i, flags; + Tcl_Obj *resultObjPtr; + static const char *const cancelOptions[] = { + "-unwind", "--", NULL + }; + enum option { + OPT_UNWIND, OPT_LAST + }; + + flags = 0; + + for (i = 2; i < objc; i++) { + if (TclGetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum option) index) { + case OPT_UNWIND: + /* + * The evaluation stack in the target interp is to be unwound. + */ + + flags |= TCL_CANCEL_UNWIND; + break; + case OPT_LAST: + i++; + goto endOfForLoop; + } + } + + endOfForLoop: + if (i < objc - 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-unwind? ?--? ?path? ?result?"); + return TCL_ERROR; + } + + /* + * Did they specify a slave interp to cancel the script in progress + * in? If not, use the current interp. + */ + + if (i < objc) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + i++; + } else { + slaveInterp = interp; + } + + if (i < objc) { + resultObjPtr = objv[i]; + + /* + * Tcl_CancelEval removes this reference. + */ + + Tcl_IncrRefCount(resultObjPtr); + i++; + } else { + resultObjPtr = NULL; + } + + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; Tcl_Obj *slavePtr; char buf[16 + TCL_INTEGER_SPACE]; - static const char *options[] = { + static const char *const createOptions[] = { "-safe", "--", NULL }; enum option { @@ -691,8 +775,8 @@ Tcl_InterpObjCmd( last = 0; for (i = 2; i < objc; i++) { if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, + "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_SAFE) { @@ -738,13 +822,11 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } - case OPT_DEBUG: { - /* TIP #378 */ - Tcl_Interp *slaveInterp; - + case OPT_DEBUG: /* TIP #378 */ /* * Currently only -frame supported, otherwise ?-option ?value?? */ + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; @@ -754,11 +836,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_DELETE: { int i; InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); @@ -767,6 +847,8 @@ Tcl_InterpObjCmd( } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "DELETESELF", NULL); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; @@ -775,9 +857,7 @@ Tcl_InterpObjCmd( } return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - + case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; @@ -787,12 +867,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + int exists = 1; - exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { @@ -804,9 +881,7 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - + case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; @@ -816,10 +891,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; @@ -829,31 +901,23 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDDEN: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; - + case OPT_ISSAFE: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; - } case OPT_INVOKEHID: { - int i, index; + int i; const char *namespaceName; - Tcl_Interp *slaveInterp; - static const char *hiddenOptions[] = { + static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { @@ -895,8 +959,7 @@ Tcl_InterpObjCmd( objv + i); } case OPT_LIMIT: { - Tcl_Interp *slaveInterp; - static const char *limitTypes[] = { + static const char *const limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { @@ -905,7 +968,8 @@ Tcl_InterpObjCmd( int limitType; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path limitType ?-option value ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); @@ -923,9 +987,7 @@ Tcl_InterpObjCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - + case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; @@ -935,10 +997,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - + case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; @@ -948,9 +1007,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_SLAVES: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -974,8 +1031,7 @@ Tcl_InterpObjCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Interp *masterInterp; /* The master of the slave. */ Tcl_Channel chan; if (objc != 5) { @@ -988,7 +1044,7 @@ Tcl_InterpObjCmd( } chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[4]); @@ -1003,18 +1059,17 @@ Tcl_InterpObjCmd( */ if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - TclTransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } } return TCL_OK; } case OPT_TARGET: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; - char *aliasName; + const char *aliasName; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path alias"); @@ -1031,18 +1086,20 @@ Tcl_InterpObjCmd( iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[2]), "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" in path \"%s\" not found", + aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "target interpreter for alias \"%s\" in path \"%s\" is " + "not my descendant", aliasName, Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; @@ -1119,8 +1176,7 @@ Tcl_CreateAlias( int i; int result; - objv = (Tcl_Obj **) - TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); @@ -1221,7 +1277,8 @@ Tcl_GetAlias( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1240,7 +1297,7 @@ Tcl_GetAlias( } if (argvPtr != NULL) { *argvPtr = (const char **) - ckalloc((unsigned) sizeof(const char *) * (objc - 1)); + ckalloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } @@ -1282,7 +1339,8 @@ Tcl_GetAliasObj( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1354,7 +1412,7 @@ TclPreventAliasLoop( * chain then we have a loop. */ - aliasPtr = (Alias *) cmdPtr->objClientData; + aliasPtr = cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; @@ -1370,9 +1428,9 @@ TclPreventAliasLoop( * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": interpreter deleted", + Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; @@ -1385,9 +1443,11 @@ TclPreventAliasLoop( } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": would create a loop", + Tcl_GetCommandName(cmdInterp, cmd))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "ALIASLOOP", NULL); return TCL_ERROR; } @@ -1400,7 +1460,7 @@ TclPreventAliasLoop( if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + nextAliasPtr = aliasCmdPtr->objClientData; } /* NOTREACHED */ @@ -1443,8 +1503,7 @@ AliasCreate( Tcl_Obj **prefv; int isNew, i; - aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) - + objc * sizeof(Tcl_Obj *))); + aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; @@ -1462,9 +1521,15 @@ AliasCreate( Tcl_Preserve(slaveInterp); Tcl_Preserve(masterInterp); + if (slaveInterp == masterInterp) { + aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, + TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, + AliasObjCmdDeleteProc); + } else { aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, TclGetString(namePtr), AliasObjCmd, aliasPtr, AliasObjCmdDeleteProc); + } if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { @@ -1489,7 +1554,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - ckfree((char *) aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1507,7 +1572,7 @@ AliasCreate( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; - char *string; + const char *string; string = TclGetString(aliasPtr->token); hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); @@ -1546,11 +1611,11 @@ AliasCreate( * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr = ckalloc(sizeof(Target)); targetPtr->slaveCmd = aliasPtr->slaveCmd; targetPtr->slaveInterp = slaveInterp; - masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master; + masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; targetPtr->nextPtr = masterPtr->targetsPtr; targetPtr->prevPtr = NULL; if (masterPtr->targetsPtr != NULL) { @@ -1601,8 +1666,8 @@ AliasDelete( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), - "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; @@ -1719,6 +1784,54 @@ AliasList( */ static int +AliasNRCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ + Alias *aliasPtr = clientData; + int prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + Tcl_Obj *listPtr; + List *listRep; + int flags = TCL_EVAL_INVOKE; + + /* + * Append the arguments to the command prefix and invoke the command in + * the target interp's global namespace. + */ + + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + + listPtr = Tcl_NewListObj(cmdc, NULL); + listRep = listPtr->internalRep.twoPtrValue.ptr1; + listRep->elemCount = cmdc; + cmdv = &listRep->elements; + + prefv = &aliasPtr->objPtr; + memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + for (i=0; i<cmdc; i++) { + Tcl_IncrRefCount(cmdv[i]); + } + + /* + * Use the ensemble rewriting machinery to ensure correct error messages: + * only the source command should show, not the full target prefix. + */ + + if (TclInitRewriteEnsemble(interp, 1, prefc, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + } + TclSkipTailcall(interp); + return Tcl_NREvalObj(interp, listPtr, flags); +} + +static int AliasObjCmd( ClientData clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -1732,7 +1845,7 @@ AliasObjCmd( Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; Interp *tPtr = (Interp *) targetInterp; - int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); + int isRootEnsemble; /* * Append the arguments to the command prefix and invoke the command in @@ -1745,7 +1858,7 @@ AliasObjCmd( if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*)); + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); @@ -1762,13 +1875,7 @@ AliasObjCmd( * only the source command should show, not the full target prefix. */ - if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = objv; - tPtr->ensembleRewrite.numRemovedObjs = 1; - tPtr->ensembleRewrite.numInsertedObjs = prefc; - } else { - tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; - } + isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)tPtr, 1, prefc, objv); /* * Protect the target interpreter if it isn't the same as the source @@ -1791,9 +1898,7 @@ AliasObjCmd( */ if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = NULL; - tPtr->ensembleRewrite.numRemovedObjs = 0; - tPtr->ensembleRewrite.numInsertedObjs = 0; + TclResetRewriteEnsemble((Tcl_Interp *)tPtr, 1); } /* @@ -1803,7 +1908,7 @@ AliasObjCmd( */ if (targetInterp != interp) { - TclTransferResult(targetInterp, result, interp); + Tcl_TransferResult(targetInterp, result, interp); Tcl_Release(targetInterp); } @@ -1868,8 +1973,8 @@ AliasObjCmdDeleteProc( targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - ckfree((char *) targetPtr); - ckfree((char *) aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* @@ -1974,6 +2079,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * TclSetSlaveCancelFlags -- + * + * This function marks all slave interpreters belonging to a given + * interpreter as being canceled or not canceled, depending on the + * provided flags. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclSetSlaveCancelFlags( + Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ + int flags, /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ + int force) /* Non-zero to ignore numLevels for the purpose + * of resetting the cancellation flags. */ +{ + Master *masterPtr; /* Master record of given interpreter. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hashSearch; /* Search variable. */ + Slave *slavePtr; /* Slave record of interpreter. */ + Interp *iPtr; + + if (interp == NULL) { + return; + } + + flags &= (CANCELED | TCL_CANCEL_UNWIND); + + masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + + hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + slavePtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) slavePtr->slaveInterp; + + if (iPtr == NULL) { + continue; + } + + if (flags == 0) { + TclResetCancellation((Tcl_Interp *) iPtr, force); + } else { + TclSetCancelFlags(iPtr, flags); + } + + /* + * Now, recursively handle this for the slaves of this slave + * interpreter. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list @@ -2003,17 +2174,19 @@ Tcl_GetInterpPath( InterpInfo *iiPtr; if (targetInterp == askingInterp) { + Tcl_SetObjResult(askingInterp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; } @@ -2067,8 +2240,8 @@ GetInterp( } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - TclGetString(pathPtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } @@ -2105,8 +2278,10 @@ SlaveBgerror( if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cmdPrefix must be list of length >= 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BGERRORFORMAT", NULL); return TCL_ERROR; } TclSetBgErrorHandler(slaveInterp, objv[0]); @@ -2144,7 +2319,7 @@ SlaveCreate( Slave *slavePtr; InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; - char *path; + const char *path; int isNew, objc; Tcl_Obj **objv; @@ -2173,8 +2348,9 @@ SlaveCreate( hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "interpreter named \"%s\" already exists, cannot create", + path)); return NULL; } @@ -2183,8 +2359,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2242,7 +2418,7 @@ SlaveCreate( return slaveInterp; error: - TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); error2: Tcl_DeleteInterp(slaveInterp); @@ -2273,17 +2449,29 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; - static const char *options[] = { - "alias", "aliases", "bgerror", "debug", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + static const char *const options[] = { + "alias", "aliases", "bgerror", "debug", + "eval", "expose", "hide", "hidden", + "issafe", "invokehidden", "limit", "marktrusted", + "recursionlimit", NULL }; enum options { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, + OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, + OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, + OPT_RECLIMIT }; if (slaveInterp == NULL) { @@ -2314,7 +2502,7 @@ SlaveObjCmd( objv[3], objc - 4, objv + 4); } } - Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); + Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?"); return TCL_ERROR; case OPT_ALIASES: if (objc != 2) { @@ -2330,7 +2518,7 @@ SlaveObjCmd( return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); case OPT_DEBUG: /* - * TIP #378 * + * TIP #378 * Currently only -frame supported, otherwise ?-option ?value? ...? */ if (objc > 4) { @@ -2370,9 +2558,9 @@ SlaveObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { - int i, index; + int i; const char *namespaceName; - static const char *hiddenOptions[] = { + static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { @@ -2410,7 +2598,7 @@ SlaveObjCmd( objc - i, objv + i); } case OPT_LIMIT: { - static const char *limitTypes[] = { + static const char *const limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { @@ -2419,7 +2607,7 @@ SlaveObjCmd( int limitType; if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, @@ -2509,7 +2697,7 @@ SlaveObjCmdDeleteProc( * A standard Tcl result. * * Side effects: - * May modify INTERP_DEBUG flag in the slave. + * May modify INTERP_DEBUG_FRAME flag in the slave. * *---------------------------------------------------------------------- */ @@ -2522,7 +2710,7 @@ SlaveDebugCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *debugTypes[] = { + static const char *const debugTypes[] = { "-frame", NULL }; enum DebugTypes { @@ -2541,8 +2729,8 @@ SlaveDebugCmd( Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); Tcl_SetObjResult(interp, resultPtr); } else { - if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, - "debug option", 0, &debugType) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option", + 0, &debugType) != TCL_OK) { return TCL_ERROR; } if (debugType == DEBUG_TYPE_FRAME) { @@ -2551,11 +2739,13 @@ SlaveDebugCmd( != TCL_OK) { return TCL_ERROR; } + /* - * Quietly ignore attempts to disable interp debugging. - * This is a one-way switch as frame debug info is maintained - * in a stack that must be consistent once turned on. + * Quietly ignore attempts to disable interp debugging. This + * is a one-way switch as frame debug info is maintained in a + * stack that must be consistent once turned on. */ + if (debugType) { iPtr->flags |= INTERP_DEBUG_FRAME; } @@ -2592,7 +2782,16 @@ SlaveEval( Tcl_Obj *const objv[]) /* Argument objects. */ { int result; - Tcl_Obj *objPtr; + + /* + * TIP #285: If necessary, reset the cancellation flags for the slave + * interpreter now; otherwise, canceling a script in a master interpreter + * can result in a situation where a slave interpreter can no longer + * evaluate any scripts unless somebody calls the TclResetCancellation + * function for that particular Tcl_Interp. + */ + + TclSetSlaveCancelFlags(slaveInterp, 0, 0); Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); @@ -2602,19 +2801,20 @@ SlaveEval( * TIP #280: Make actual argument location available to eval'd script. */ - Interp *iPtr = (Interp *) interp; - CmdFrame* invoker = iPtr->cmdFramePtr; - int word = 0; + Interp *iPtr = (Interp *) interp; + CmdFrame *invoker = iPtr->cmdFramePtr; + int word = 0; + + TclArgumentGet(interp, objv[0], &invoker, &word); - TclArgumentGet (interp, objv[0], &invoker, &word); result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); } else { - objPtr = Tcl_ConcatObj(objc, objv); + Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - TclTransferResult(slaveInterp, result, interp); + Tcl_TransferResult(slaveInterp, result, interp); Tcl_Release(slaveInterp); return result; @@ -2644,19 +2844,21 @@ SlaveExpose( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { - char *name; + const char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2691,8 +2893,10 @@ SlaveRecursionLimit( if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_AppendResult(interp, "permission denied: " - "safe interpreters cannot change recursion limit", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " + "safe interpreters cannot change recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -2701,6 +2905,8 @@ SlaveRecursionLimit( if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", + NULL); return TCL_ERROR; } Tcl_SetRecursionLimit(slaveInterp, limit); @@ -2708,6 +2914,7 @@ SlaveRecursionLimit( if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); @@ -2743,18 +2950,20 @@ SlaveHide( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { - char *name; + const char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2831,6 +3040,8 @@ SlaveInvokeHidden( Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2838,7 +3049,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -2848,12 +3063,29 @@ SlaveInvokeHidden( | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { result = TclObjInvokeNamespace(slaveInterp, objc, objv, - (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); + (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } - TclTransferResult(slaveInterp, result, interp); + Tcl_TransferResult(slaveInterp, result, interp); + + Tcl_Release(slaveInterp); + return result; +} + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } Tcl_Release(slaveInterp); return result; } @@ -2885,6 +3117,8 @@ SlaveMarkTrusted( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; @@ -3140,8 +3374,9 @@ Tcl_LimitCheck( if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command count limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3165,8 +3400,9 @@ Tcl_LimitCheck( iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3219,7 +3455,7 @@ RunLimitHandlers( */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; - (handlerPtr->handlerProc)(handlerPtr->clientData, interp); + handlerPtr->handlerProc(handlerPtr->clientData, interp); handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* @@ -3240,9 +3476,9 @@ RunLimitHandlers( if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } } @@ -3289,7 +3525,7 @@ Tcl_LimitAddHandler( * Allocate a handler record. */ - handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + handlerPtr = ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3406,9 +3642,9 @@ Tcl_LimitRemoveHandler( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } return; } @@ -3466,9 +3702,9 @@ TclLimitRemoveAllHandlers( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3499,9 +3735,9 @@ TclLimitRemoveAllHandlers( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3764,7 +4000,7 @@ TimeLimitCallback( code = Tcl_LimitCheck(interp); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); - TclBackgroundException(interp, code); + Tcl_BackgroundException(interp, code); } Tcl_Release(interp); } @@ -3896,7 +4132,7 @@ DeleteScriptLimitCallback( if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - ckfree((char *) limitCBPtr); + ckfree(limitCBPtr); } /* @@ -3932,7 +4168,7 @@ CallScriptLimitCallback( code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, TCL_EVAL_GLOBAL); if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { - TclBackgroundException(limitCBPtr->interp, code); + Tcl_BackgroundException(limitCBPtr->interp, code); } Tcl_Release(limitCBPtr->interp); } @@ -3987,7 +4223,7 @@ SetScriptLimitCallback( return; } - hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, &isNew); if (!isNew) { limitCBPtr = Tcl_GetHashValue(hashPtr); @@ -3996,7 +4232,7 @@ SetScriptLimitCallback( limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4151,7 +4387,7 @@ SlaveCommandLimitCmd( int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *options[] = { + static const char *const options[] = { "-command", "-granularity", "-value", NULL }; enum Options { @@ -4171,8 +4407,9 @@ SlaveCommandLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4245,8 +4482,7 @@ SlaveCommandLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option? ?value? ?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4269,8 +4505,10 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4284,8 +4522,10 @@ SlaveCommandLimitCmd( return TCL_ERROR; } if (limit < 0) { - Tcl_AppendResult(interp, "command limit value must be at " - "least 0", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command limit value must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4335,7 +4575,7 @@ SlaveTimeLimitCmd( int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *options[] = { + static const char *const options[] = { "-command", "-granularity", "-milliseconds", "-seconds", NULL }; enum Options { @@ -4355,8 +4595,9 @@ SlaveTimeLimitCmd( */ if (interp == slaveInterp) { - Tcl_AppendResult(interp, - "limits on current interpreter inaccessible", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "limits on current interpreter inaccessible", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4446,8 +4687,7 @@ SlaveTimeLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option? ?value? ?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4474,8 +4714,10 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at " - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4489,11 +4731,13 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "milliseconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "milliseconds must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long)tmp)*1000; + limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4505,8 +4749,10 @@ SlaveTimeLimitCmd( return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "seconds must be at least 0", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "seconds must be at least 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.sec = tmp; @@ -4521,13 +4767,19 @@ SlaveTimeLimitCmd( */ if (secObj != NULL && secLen == 0 && milliLen > 0) { - Tcl_AppendResult(interp, "may only set -milliseconds " - "if -seconds is not also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only set -milliseconds if -seconds is not " + "also being reset", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { - Tcl_AppendResult(interp, "may only reset -milliseconds " - "if -seconds is also being reset", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may only reset -milliseconds if -seconds is " + "also being reset", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } } |