summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c20
-rw-r--r--generic/tclCompile.c2
-rw-r--r--generic/tclDecls.h8
-rw-r--r--generic/tclEnsemble.c8
-rw-r--r--generic/tclExecute.c20
-rw-r--r--generic/tclInt.h38
-rw-r--r--generic/tclInterp.c16
-rw-r--r--generic/tclNamesp.c34
-rw-r--r--generic/tclOO.c2
-rw-r--r--generic/tclObj.c2
-rw-r--r--tests/interp.test8
11 files changed, 99 insertions, 59 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9398aff..d2a017d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2713,6 +2713,8 @@ TclCreateObjCommandInNs(
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
+ cmdPtr->refCount++;
+ TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -3295,7 +3297,7 @@ Tcl_GetCommandFullName(
* separator, and the command name.
*/
- if (cmdPtr != NULL) {
+ if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
@@ -3385,7 +3387,7 @@ Tcl_DeleteCommandFromToken(
* and skip nested deletes.
*/
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* Another deletion is already in progress. Remove the hash table
* entry now, but don't invoke a callback or free the command
@@ -3417,7 +3419,7 @@ Tcl_DeleteCommandFromToken(
* be ignored.
*/
- cmdPtr->flags |= CMD_IS_DELETED;
+ cmdPtr->flags |= CMD_DYING;
/*
* Call trace functions for the command being deleted. Then delete its
@@ -3447,7 +3449,7 @@ Tcl_DeleteCommandFromToken(
}
/*
- * The list of command exported from the namespace might have changed.
+ * The list of commands exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we need
* the info will be soon enough.
*/
@@ -3582,7 +3584,7 @@ CallCommandTraces(
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
- * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
+ * (cmdPtr->flags & CMD_DYING) and returns immediately when a
* command deletion is in progress. For all other traces, delete
* traces will not be invoked but a call to TraceCommandProc will
* ensure that tracePtr->clientData is freed whenever the command
@@ -4750,7 +4752,7 @@ TEOV_RunLeaveTraces(
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -5870,7 +5872,7 @@ TclNREvalObjEx(
/*
* Shimmer protection! Always pass an unshared obj. The caller could
* incr the refCount of objPtr AFTER calling us! To be completely safe
- * we always make a copy. The callback takes care od the refCounts for
+ * we always make a copy. The callback takes care of the refCounts for
* both listPtr and objPtr.
*
* TODO: Create a test to demo this need, or eliminate it.
@@ -8757,7 +8759,7 @@ NRCoroutineCallerCallback(
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* The command was deleted while it was running: wind down the
* execEnv, this will do the complete cleanup. RewindCoroutine will
@@ -9526,7 +9528,7 @@ TclInfoCoroutineCmd(
return TCL_ERROR;
}
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 9d90d61..55914c8 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1815,7 +1815,7 @@ CompileCmdLiteral(
bytes = TclGetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
- if (cmdPtr) {
+ if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index cc115ca..b15d548 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3931,8 +3931,10 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= TCL_UTF_MAX) : tclStubsPtr->tcl_UtfCharComplete((src), (length)))
#endif
-#define Tcl_CreateSlave Tcl_CreateChild
-#define Tcl_GetSlave Tcl_GetChild
-#define Tcl_GetMaster Tcl_GetParent
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_CreateSlave Tcl_CreateChild
+# define Tcl_GetSlave Tcl_GetChild
+# define Tcl_GetMaster Tcl_GetParent
+#endif
#endif /* _TCLDECLS */
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index faa0263..02405f5 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3162,7 +3162,7 @@ TclCompileEnsemble(
}
/*
- * Now we've done the mapping process, can now actually try to compile.
+ * Now that the mapping process is done we actually try to compile.
* If there is a subcommand compiler and that successfully produces code,
* we'll use that. Otherwise, we fall back to generating opcodes to do the
* invoke at runtime.
@@ -3262,9 +3262,9 @@ TclAttemptCompileProc(
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
- * This will be wrong, but it will not matter, and it will put the
- * tokens for the arguments in the right place without the needed to
- * allocate a synthetic Tcl_Parse struct, or copy tokens around.
+ * This will be wrong but it will not matter, and it will put the
+ * tokens for the arguments in the right place without the need to
+ * allocate a synthetic Tcl_Parse struct or copy tokens around.
*/
for (i = 0; i < depth - 1; i++) {
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 6809d3c..b04a5c5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4254,7 +4254,7 @@ TEBCresume(
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
@@ -4314,6 +4314,18 @@ TEBCresume(
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
+ goto instOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+
+ TclNewObj(objResultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
+ if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(objResultPtr);
+ instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
@@ -4323,12 +4335,6 @@ TEBCresume(
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
- origCmd = TclGetOriginalCommand(cmd);
- if (origCmd == NULL) {
- origCmd = cmd;
- }
- TclNewObj(objResultPtr);
- Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4632887..7ca9a8c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1691,18 +1691,18 @@ typedef struct Command {
/*
* Flag bits for commands.
*
- * CMD_IS_DELETED - Means that the command is in the process of
+ * CMD_DYING - If 1 the command is in the process of
* being deleted (its deleteProc is currently
* executing). Other attempts to delete the
* command should be ignored.
- * CMD_TRACE_ACTIVE - 1 means that trace processing is currently
+ * CMD_TRACE_ACTIVE - If 1 the trace processing is currently
* underway for a rename/delete change. See the
* two flags below for which is currently being
* processed.
- * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
+ * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
- * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that
* can handle expansion (provided it is not the
* first word).
* TCL_TRACE_RENAME - A rename trace is in progress. Further
@@ -1712,7 +1712,7 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x01
+#define CMD_DYING 0x01
#define CMD_TRACE_ACTIVE 0x02
#define CMD_HAS_EXEC_TRACES 0x04
#define CMD_COMPILES_EXPANDED 0x08
@@ -4910,10 +4910,30 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* the internal stubs, but the core can use the macro instead.
*/
-#define TclCleanupCommandMacro(cmdPtr) \
- if ((cmdPtr)->refCount-- <= 1) { \
- Tcl_Free(cmdPtr);\
- }
+#define TclCleanupCommandMacro(cmdPtr) \
+ do { \
+ if ((cmdPtr)->refCount-- <= 1) { \
+ Tcl_Free(cmdPtr); \
+ } \
+ } while (0)
+
+
+/*
+ * inside this routine crement refCount first incase cmdPtr is replacing itself
+ */
+#define TclRoutineAssign(location, cmdPtr) \
+ do { \
+ (cmdPtr)->refCount++; \
+ if ((location) != NULL \
+ && (location--) <= 1) { \
+ Tcl_Free(((location))); \
+ } \
+ (location) = (cmdPtr); \
+ } while (0)
+
+
+#define TclRoutineHasName(cmdPtr) \
+ ((cmdPtr)->hPtr != NULL)
/*
*----------------------------------------------------------------
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 5857c23..3883a07 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -624,7 +624,10 @@ NRInterpCmd(
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
- "slaves", "share", "target", "transfer",
+#ifndef TCL_NO_DEPRECATED
+ "slaves",
+#endif
+ "share", "target", "transfer",
NULL
};
enum option {
@@ -633,7 +636,10 @@ NRInterpCmd(
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
+#ifndef TCL_NO_DEPRECATED
+ OPT_SLAVES,
+#endif
+ OPT_SHARE, OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
@@ -1017,8 +1023,10 @@ NRInterpCmd(
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
- case OPT_CHILDREN:
- case OPT_SLAVES: {
+#ifndef TCL_NO_DEPRECATED
+ case OPT_SLAVES:
+#endif
+ case OPT_CHILDREN: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 86823c4..bf59eac 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1771,6 +1771,8 @@ DoImport(
TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
+ /* corresponding decrement is in DeleteImportedCmd */
+ cmdPtr->refCount++;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
@@ -2078,6 +2080,7 @@ DeleteImportedCmd(
prevPtr->nextPtr = refPtr->nextPtr;
}
Tcl_Free(refPtr);
+ TclCleanupCommandMacro(realCmdPtr);
Tcl_Free(dataPtr);
return;
}
@@ -3889,7 +3892,7 @@ NamespaceOriginCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Command command, origCommand;
+ Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
@@ -3897,30 +3900,29 @@ NamespaceOriginCmd(
return TCL_ERROR;
}
- command = Tcl_GetCommandFromObj(interp, objv[1]);
- if (command == NULL) {
+ cmd = Tcl_GetCommandFromObj(interp, objv[1]);
+ if (cmd == NULL) {
+ goto namespaceOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+ TclNewObj(resultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, resultPtr);
+ if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(resultPtr);
+ namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
- origCommand = TclGetOriginalCommand(command);
- TclNewObj(resultPtr);
- if (origCommand == NULL) {
- /*
- * The specified command isn't an imported command. Return the
- * command's name qualified by the full name of the namespace it was
- * defined in.
- */
-
- Tcl_GetCommandFullName(interp, command, resultPtr);
- } else {
- Tcl_GetCommandFullName(interp, origCommand, resultPtr);
- }
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
+
/*
*----------------------------------------------------------------------
diff --git a/generic/tclOO.c b/generic/tclOO.c
index bc8303c..5b685bc 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1177,7 +1177,7 @@ ObjectNamespaceDeleted(
* freed memory.
*/
- if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
+ if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
diff --git a/generic/tclObj.c b/generic/tclObj.c
index c9d0e03..6f4e9e8 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4223,7 +4223,7 @@ SetCmdNameFromAny(
* report the failure to find the command as an error.
*/
- if (cmdPtr == NULL) {
+ if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
return TCL_ERROR;
}
diff --git a/tests/interp.test b/tests/interp.test
index 4453d90..68e8d20 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
-} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -match glob -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, *share, target, or transfer}
test interp-1.3 {options for interp command} {
interp delete
} ""
@@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp children ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
interp hello
-} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -match glob -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, *share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
interp -froboz
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -match glob -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, *share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
interp -froboz -safe
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -match glob -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, *share, target, or transfer}
test interp-1.10 {options for interp command} -returnCodes error -body {
interp target
} -result {wrong # args: should be "interp target path alias"}
generated by cgit v0.12 at 2024-11-16 09:33:59 (GMT)