summaryrefslogtreecommitdiffstats
path: root/generic/tclInterp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r--generic/tclInterp.c412
1 files changed, 261 insertions, 151 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 49d324f..0da5d47 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -179,6 +179,37 @@ typedef struct ScriptLimitCallbackKey {
} ScriptLimitCallbackKey;
/*
+ * TIP#143 limit handler internal representation.
+ */
+
+struct LimitHandler {
+ int flags; /* The state of this particular handler. */
+ Tcl_LimitHandlerProc *handlerProc;
+ /* The handler callback. */
+ ClientData clientData; /* Opaque argument to the handler callback. */
+ Tcl_LimitHandlerDeleteProc *deleteProc;
+ /* How to delete the clientData. */
+ LimitHandler *prevPtr; /* Previous item in linked list of
+ * handlers. */
+ LimitHandler *nextPtr; /* Next item in linked list of handlers. */
+};
+
+/*
+ * Values for the LimitHandler flags field.
+ * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
+ * processed; handlers are never to be entered reentrantly.
+ * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
+ * should not normally be observed because when a handler is
+ * deleted it is also spliced out of the list of handlers, but
+ * even so we will be careful.
+ */
+
+#define LIMIT_HANDLER_ACTIVE 0x01
+#define LIMIT_HANDLER_DELETED 0x02
+
+
+
+/*
* Prototypes for local static functions:
*/
@@ -248,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;
+
/*
*----------------------------------------------------------------------
@@ -300,8 +337,8 @@ Tcl_Init(
{
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return (TCL_ERROR);
- };
+ return TCL_ERROR;
+ }
}
/*
@@ -436,7 +473,7 @@ TclInterpInit(
Master *masterPtr;
Slave *slavePtr;
- interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
+ interpInfoPtr = ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
masterPtr = &interpInfoPtr->master;
@@ -450,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;
@@ -532,7 +570,7 @@ InterpInfoDeleteProc(
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
- ckfree((char *) interpInfoPtr);
+ ckfree(interpInfoPtr);
}
/*
@@ -559,6 +597,17 @@ 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 *const options[] = {
"alias", "aliases", "bgerror", "cancel",
@@ -588,7 +637,7 @@ Tcl_InterpObjCmd(
}
switch ((enum option) index) {
case OPT_ALIAS: {
- Tcl_Interp *slaveInterp, *masterInterp;
+ Tcl_Interp *masterInterp;
if (objc < 4) {
aliasArgs:
@@ -622,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;
@@ -643,10 +687,8 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
- }
case OPT_CANCEL: {
int i, flags;
- Tcl_Interp *slaveInterp;
Tcl_Obj *resultObjPtr;
static const char *const cancelOptions[] = {
"-unwind", "--", NULL
@@ -680,8 +722,7 @@ Tcl_InterpObjCmd(
}
}
- endOfForLoop:
-
+ endOfForLoop:
if ((i + 2) < objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
@@ -689,35 +730,34 @@ Tcl_InterpObjCmd(
}
/*
- * Did they specify a slave interp to cancel the script in
- * progress in? If not, use the current interp.
+ * 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 (slaveInterp != NULL) {
- if (i < objc) {
- resultObjPtr = objv[i];
-
- /*
- * Tcl_CancelEval removes this reference.
- */
+ if (i < objc) {
+ resultObjPtr = objv[i];
- Tcl_IncrRefCount(resultObjPtr);
- i++;
- } else {
- resultObjPtr = NULL;
- }
+ /*
+ * Tcl_CancelEval removes this reference.
+ */
- return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
+ Tcl_IncrRefCount(resultObjPtr);
+ i++;
} else {
- return TCL_ERROR;
+ resultObjPtr = NULL;
}
+
+ return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int i, last, safe;
@@ -787,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;
@@ -803,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]);
@@ -816,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;
@@ -824,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;
@@ -836,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) {
@@ -853,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;
@@ -865,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;
@@ -878,30 +906,22 @@ 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;
const char *namespaceName;
- Tcl_Interp *slaveInterp;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
@@ -944,7 +964,6 @@ Tcl_InterpObjCmd(
objv + i);
}
case OPT_LIMIT: {
- Tcl_Interp *slaveInterp;
static const char *const limitTypes[] = {
"commands", "time", NULL
};
@@ -973,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;
@@ -985,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;
@@ -998,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;
@@ -1024,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) {
@@ -1060,7 +1071,6 @@ Tcl_InterpObjCmd(
return TCL_OK;
}
case OPT_TARGET: {
- Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
@@ -1081,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;
@@ -1270,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;
}
@@ -1289,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]);
}
@@ -1331,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;
}
@@ -1419,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;
@@ -1434,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;
}
@@ -1492,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;
@@ -1544,7 +1559,7 @@ AliasCreate(
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
- ckfree((char *) aliasPtr);
+ ckfree(aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
@@ -1601,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) {
@@ -1656,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;
@@ -1831,9 +1846,9 @@ AliasNRCmd(
*/
if (isRootEnsemble) {
- TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
@@ -1988,8 +2003,8 @@ AliasObjCmdDeleteProc(
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
- ckfree((char *) targetPtr);
- ckfree((char *) aliasPtr);
+ ckfree(targetPtr);
+ ckfree(aliasPtr);
}
/*
@@ -2189,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;
}
@@ -2253,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);
}
@@ -2291,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]);
@@ -2359,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;
}
@@ -2369,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);
@@ -2459,6 +2479,16 @@ 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 *const options[] = {
@@ -2729,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) {
@@ -2739,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;
}
@@ -2848,6 +2880,8 @@ SlaveExpose(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot expose commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -2889,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) {
@@ -2899,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);
@@ -2906,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]);
@@ -2947,6 +2986,8 @@ SlaveHide(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot hide commands",
-1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+ NULL);
return TCL_ERROR;
}
@@ -3029,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;
}
@@ -3036,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;
@@ -3055,6 +3102,23 @@ SlaveInvokeHidden(
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;
+}
/*
*----------------------------------------------------------------------
@@ -3083,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;
@@ -3338,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;
}
@@ -3363,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;
}
@@ -3440,7 +3508,7 @@ RunLimitHandlers(
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
}
@@ -3487,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;
@@ -3606,7 +3674,7 @@ Tcl_LimitRemoveHandler(
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
return;
}
@@ -3666,7 +3734,7 @@ TclLimitRemoveAllHandlers(
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
@@ -3699,7 +3767,7 @@ TclLimitRemoveAllHandlers(
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
- ckfree((char *) handlerPtr);
+ ckfree(handlerPtr);
}
}
@@ -4094,7 +4162,7 @@ DeleteScriptLimitCallback(
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
- ckfree((char *) limitCBPtr);
+ ckfree(limitCBPtr);
}
/*
@@ -4194,7 +4262,7 @@ SetScriptLimitCallback(
limitCBPtr);
}
- limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback));
+ limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
@@ -4361,6 +4429,20 @@ SlaveCommandLimitCmd(
ScriptLimitCallback *limitCBPtr;
Tcl_HashEntry *hPtr;
+ /*
+ * First, ensure that we are not reading or writing the calling
+ * interpreter's limits; it may only manipulate its children. Note that
+ * the low level API enforces this with Tcl_Panic, which we want to
+ * avoid. [Bug 3398794]
+ */
+
+ if (interp == slaveInterp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
+ return TCL_ERROR;
+ }
+
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
@@ -4430,8 +4512,7 @@ SlaveCommandLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, limitLen = 0;
@@ -4454,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;
@@ -4469,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;
@@ -4532,6 +4617,20 @@ SlaveTimeLimitCmd(
ScriptLimitCallback *limitCBPtr;
Tcl_HashEntry *hPtr;
+ /*
+ * First, ensure that we are not reading or writing the calling
+ * interpreter's limits; it may only manipulate its children. Note that
+ * the low level API enforces this with Tcl_Panic, which we want to
+ * avoid. [Bug 3398794]
+ */
+
+ if (interp == slaveInterp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
+ return TCL_ERROR;
+ }
+
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
@@ -4618,8 +4717,7 @@ SlaveTimeLimitCmd(
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv,
- "?-option value ...?");
+ Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i, scriptLen = 0, milliLen = 0, secLen = 0;
@@ -4646,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;
@@ -4661,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];
@@ -4677,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;
@@ -4693,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 2025-10-23 09:50:00 (GMT)