summaryrefslogtreecommitdiffstats
path: root/generic/tclInterp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r--generic/tclInterp.c693
1 files changed, 487 insertions, 206 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0231909..0da5d47 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]);
@@ -648,18 +671,13 @@ Tcl_InterpObjCmd(
}
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 +687,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 + 2) < objc) {
+ 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 +780,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 +827,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 +841,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 +852,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 +862,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 +872,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 +886,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 +896,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 +906,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 +964,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 +973,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 +992,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 +1002,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 +1012,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 +1036,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 +1049,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 +1064,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 +1091,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 +1181,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 +1282,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 +1302,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 +1344,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 +1417,7 @@ TclPreventAliasLoop(
* chain then we have a loop.
*/
- aliasPtr = (Alias *) cmdPtr->objClientData;
+ aliasPtr = cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
@@ -1370,9 +1433,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 +1448,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 +1465,7 @@ TclPreventAliasLoop(
if (aliasCmdPtr->objProc != AliasObjCmd) {
return TCL_OK;
}
- nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
+ nextAliasPtr = aliasCmdPtr->objClientData;
}
/* NOTREACHED */
@@ -1443,8 +1508,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 +1526,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 +1559,7 @@ AliasCreate(
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
- ckfree((char *) aliasPtr);
+ ckfree(aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
@@ -1507,7 +1577,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 +1616,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 +1671,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 +1789,70 @@ AliasList(
*/
static int
+AliasNRCmd(
+ ClientData clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Alias *aliasPtr = clientData;
+ int prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ 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 (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 1;
+ iPtr->ensembleRewrite.numInsertedObjs = prefc;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += prefc - 1;
+ }
+
+ /*
+ * We are sending a 0-refCount obj, do not need a callback: it will be
+ * cleaned up automatically. But we may need to clear the rootEnsemble
+ * stuff ...
+ */
+
+ if (isRootEnsemble) {
+ 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. */
@@ -1745,7 +1879,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 *));
}
prefv = &aliasPtr->objPtr;
@@ -1804,7 +1938,7 @@ AliasObjCmd(
*/
if (targetInterp != interp) {
- TclTransferResult(targetInterp, result, interp);
+ Tcl_TransferResult(targetInterp, result, interp);
Tcl_Release(targetInterp);
}
@@ -1869,8 +2003,8 @@ AliasObjCmdDeleteProc(
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
- ckfree((char *) targetPtr);
- ckfree((char *) aliasPtr);
+ ckfree(targetPtr);
+ ckfree(aliasPtr);
}
/*
@@ -1975,6 +2109,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
@@ -2004,17 +2204,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;
}
@@ -2068,8 +2270,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);
}
@@ -2106,8 +2308,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]);
@@ -2145,7 +2349,7 @@ SlaveCreate(
Slave *slavePtr;
InterpInfo *masterInfoPtr;
Tcl_HashEntry *hPtr;
- char *path;
+ const char *path;
int isNew, objc;
Tcl_Obj **objv;
@@ -2174,8 +2378,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;
}
@@ -2184,8 +2389,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);
@@ -2243,7 +2448,7 @@ SlaveCreate(
return slaveInterp;
error:
- TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
error2:
Tcl_DeleteInterp(slaveInterp);
@@ -2274,17 +2479,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) {
@@ -2315,7 +2532,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) {
@@ -2331,7 +2548,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) {
@@ -2371,9 +2588,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 {
@@ -2411,7 +2628,7 @@ SlaveObjCmd(
objc - i, objv + i);
}
case OPT_LIMIT: {
- static const char *limitTypes[] = {
+ static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
@@ -2420,7 +2637,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,
@@ -2510,7 +2727,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.
*
*----------------------------------------------------------------------
*/
@@ -2523,7 +2740,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 {
@@ -2542,8 +2759,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) {
@@ -2552,11 +2769,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;
}
@@ -2593,7 +2812,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);
@@ -2603,19 +2831,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;
@@ -2645,19 +2874,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;
@@ -2692,8 +2923,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) {
@@ -2702,6 +2935,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);
@@ -2709,6 +2944,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]);
@@ -2744,18 +2980,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;
@@ -2832,6 +3070,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;
}
@@ -2839,7 +3079,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;
@@ -2849,12 +3093,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;
}
@@ -2886,6 +3147,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;
@@ -3141,8 +3404,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;
}
@@ -3166,8 +3430,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;
}
@@ -3220,7 +3485,7 @@ RunLimitHandlers(
*/
handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
- (handlerPtr->handlerProc)(handlerPtr->clientData, interp);
+ handlerPtr->handlerProc(handlerPtr->clientData, interp);
handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;
/*
@@ -3241,9 +3506,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);
}
}
}
@@ -3290,7 +3555,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;
@@ -3407,9 +3672,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;
}
@@ -3467,9 +3732,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);
}
}
@@ -3500,9 +3765,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);
}
}
@@ -3765,7 +4030,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);
}
@@ -3897,7 +4162,7 @@ DeleteScriptLimitCallback(
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
- ckfree((char *) limitCBPtr);
+ ckfree(limitCBPtr);
}
/*
@@ -3933,7 +4198,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);
}
@@ -3988,7 +4253,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);
@@ -3997,7 +4262,7 @@ SetScriptLimitCallback(
limitCBPtr);
}
- limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback));
+ limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
@@ -4152,7 +4417,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 {
@@ -4172,8 +4437,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;
}
@@ -4246,8 +4512,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;
@@ -4270,8 +4535,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;
@@ -4285,8 +4552,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;
@@ -4336,7 +4605,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 {
@@ -4356,8 +4625,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;
}
@@ -4447,8 +4717,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;
@@ -4475,8 +4744,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;
@@ -4490,11 +4761,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];
@@ -4506,8 +4779,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;
@@ -4522,13 +4797,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;
}
}
generated by cgit v0.12 at 2024-11-03 15:04:47 (GMT)