Fix for [c1a376375e0e6488], imported namespace ensemble command name distorted

during deletion trace on the import

9 files changed, 174 insertions, 48 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4cc579b..75f8527 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2785,6 +2785,8 @@ TclCreateObjCommandInNs(
 	    Command *refCmdPtr = oldRefPtr->importedCmdPtr;
 
 	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
+	    cmdPtr->refCount++;
+	    TclCleanupCommandMacro(dataPtr->realCmdPtr);
 	    dataPtr->realCmdPtr = cmdPtr;
 	    oldRefPtr = oldRefPtr->nextPtr;
 	}
@@ -3374,7 +3376,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) {
@@ -3464,7 +3466,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
@@ -3496,7 +3498,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
@@ -3526,7 +3528,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.
      */
@@ -3661,7 +3663,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
@@ -5214,7 +5216,7 @@ TEOV_RunLeaveTraces(
     int 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);
@@ -6460,7 +6462,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.
@@ -9513,7 +9515,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
@@ -10282,7 +10284,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 fd63da3..7d67e12 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1834,7 +1834,7 @@ CompileCmdLiteral(
     bytes = TclGetStringFromObj(cmdObj, &numBytes);
     cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
 
-    if (cmdPtr) {
+    if (cmdPtr && TclRoutineHasName(cmdPtr)) {
 	TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
     }
     TclEmitPush(cmdLitIdx, envPtr);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 3c99631..16bf8f7 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3161,7 +3161,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.
@@ -3261,9 +3261,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 0f1c2cc..786fffb 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4464,7 +4464,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);
 	}
@@ -4524,6 +4524,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();
@@ -4533,12 +4545,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 792b675..9ccb3c5 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1707,18 +1707,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
@@ -1728,7 +1728,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
@@ -4960,10 +4960,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) { \
-	ckfree(cmdPtr);\
-    }
+#define TclCleanupCommandMacro(cmdPtr)		\
+    do {					\
+	if ((cmdPtr)->refCount-- <= 1) {	\
+	    ckfree(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) {		    \
+	    ckfree(((location)));		    \
+	}					    \
+	(location) = (cmdPtr);			    \
+    } while (0)
+    
+
+#define TclRoutineHasName(cmdPtr) \
+    (cmdPtr)->hPtr != NULL
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 26dca62..673acb0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1770,6 +1770,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);
@@ -2077,6 +2079,7 @@ DeleteImportedCmd(
 		prevPtr->nextPtr = refPtr->nextPtr;
 	    }
 	    ckfree(refPtr);
+	    TclCleanupCommandMacro(realCmdPtr);
 	    ckfree(dataPtr);
 	    return;
 	}
@@ -3888,7 +3891,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) {
@@ -3896,30 +3899,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 85f4470..21018ac 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 dbe6686..44b2785 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4667,7 +4667,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/namespace.test b/tests/namespace.test
index 2b25803..9c4672f 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -616,6 +616,102 @@ test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
     namespace delete src
 } {}
 
+
+test namespace-13.3 {
+    deleting origin of import in trace on deletion of import
+} -setup {
+    namespace eval ns0 {
+	namespace export *
+	variable res {}
+
+	proc traced {oldname newname op} {
+		variable res
+
+		lappend res {Is oldname the name of the imported routine?}
+		set expected [namespace qualifiers [namespace current]::fake]::ns2::ns1
+		if {$oldname eq $expected} {
+		    lappend res 1
+		} else {
+		    lappend res 0
+		}
+
+		lappend res {[namespace which] finds the old name}
+		set which [namespace which $oldname]
+		if {$which eq $expected} {
+		    lappend res 1
+		} else {
+		    lappend res $which
+		}
+
+		lappend res {Is origin name correct}
+		catch {
+		    namespace origin $oldname
+		} cres copts
+		set expected [namespace qualifiers [namespace current]::fake]::ns1
+		if {$cres eq $expected} {
+		    lappend res 1
+		} else {
+		    lappend res $cres
+		}
+
+		set origin $cres
+		rename $origin {}
+
+		lappend res {After deletion of the origin is it an error to ask for the origin (compiled)?}
+		set status [catch {
+		    namespace origin $oldname
+		} cres copts]
+		if {$status && [string match {invalid command name "*::ns2::ns1"} $cres]} {
+		    lappend res 1
+		} else {
+		    lappend res $cres
+		}
+
+		lappend res {After deletion of the origin is it an error to ask for the origin (uncompiled)?}
+		set status [catch {
+		    namespace eval [namespace current] "namespace origin $oldname"
+		} cres copts]
+		if {$status && [string match {invalid command name "*::ns2::ns1"} $cres]} {
+		    lappend res 1
+		} else {
+		    lappend res $cres
+		}
+
+		lappend res {after deletion of origin, [namespace which] on the imported routine returns the empty string}
+		set which [namespace which $oldname]
+		if {$which eq {}} {
+		    lappend res 1
+		} else {
+		    lappend res $which
+		}
+
+		return
+	}
+
+    }
+} -body {
+    namespace eval ns0::ns1 {
+	    namespace ensemble create
+    }
+
+    namespace eval ns0::ns2 {
+	    namespace import [namespace parent]::ns1
+	    trace add command ns1 delete [namespace parent]::traced
+	    rename ns1 {}
+    }
+    return $ns0::res
+} -cleanup {
+    namespace delete ns0
+} -result [list \
+    {Is oldname the name of the imported routine?} 1 \
+    {[namespace which] finds the old name} 1 \
+    {Is origin name correct} 1 \
+    {After deletion of the origin is it an error to ask for the origin (compiled)?} 1 \
+    {After deletion of the origin is it an error to ask for the origin (uncompiled)?} 1 \
+    {after deletion of origin, [namespace which] on the imported routine returns the empty string} 1 \
+]
+
+
 test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     variable v 10