Backout [c1a376375e0e6488]: imported namespace ensemble command name distorted during deletion trace on the import.

According to Travis, there's a memory leak which needs to be fixed first.

9 files changed, 48 insertions, 174 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 75f8527..4cc579b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2785,8 +2785,6 @@ TclCreateObjCommandInNs(
 	    Command *refCmdPtr = oldRefPtr->importedCmdPtr;
 
 	    dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
-	    cmdPtr->refCount++;
-	    TclCleanupCommandMacro(dataPtr->realCmdPtr);
 	    dataPtr->realCmdPtr = cmdPtr;
 	    oldRefPtr = oldRefPtr->nextPtr;
 	}
@@ -3376,7 +3374,7 @@ Tcl_GetCommandFullName(
      * separator, and the command name.
      */
 
-    if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
+    if (cmdPtr != NULL) {
 	if (cmdPtr->nsPtr != NULL) {
 	    Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
 	    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
@@ -3466,7 +3464,7 @@ Tcl_DeleteCommandFromToken(
      * and skip nested deletes.
      */
 
-    if (cmdPtr->flags & CMD_DYING) {
+    if (cmdPtr->flags & CMD_IS_DELETED) {
 	/*
 	 * Another deletion is already in progress. Remove the hash table
 	 * entry now, but don't invoke a callback or free the command
@@ -3498,7 +3496,7 @@ Tcl_DeleteCommandFromToken(
      * be ignored.
      */
 
-    cmdPtr->flags |= CMD_DYING;
+    cmdPtr->flags |= CMD_IS_DELETED;
 
     /*
      * Call trace functions for the command being deleted. Then delete its
@@ -3528,7 +3526,7 @@ Tcl_DeleteCommandFromToken(
     }
 
     /*
-     * The list of commands exported from the namespace might have changed.
+     * The list of command 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.
      */
@@ -3663,7 +3661,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_DYING) and returns immediately when a
+	 * (cmdPtr->flags & CMD_IS_DELETED) 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
@@ -5216,7 +5214,7 @@ TEOV_RunLeaveTraces(
     int length;
     const char *command = TclGetStringFromObj(commandPtr, &length);
 
-    if (!(cmdPtr->flags & CMD_DYING)) {
+    if (!(cmdPtr->flags & CMD_IS_DELETED)) {
 	if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
 	    traceCode = TclCheckExecutionTraces(interp, command, length,
 		    cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -6462,7 +6460,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 of the refCounts for
+	 * we always make a copy. The callback takes care od the refCounts for
 	 * both listPtr and objPtr.
 	 *
 	 * TODO: Create a test to demo this need, or eliminate it.
@@ -9515,7 +9513,7 @@ NRCoroutineCallerCallback(
     SAVE_CONTEXT(corPtr->running);
     RESTORE_CONTEXT(corPtr->caller);
 
-    if (cmdPtr->flags & CMD_DYING) {
+    if (cmdPtr->flags & CMD_IS_DELETED) {
 	/*
 	 * The command was deleted while it was running: wind down the
 	 * execEnv, this will do the complete cleanup. RewindCoroutine will
@@ -10284,7 +10282,7 @@ TclInfoCoroutineCmd(
 	return TCL_ERROR;
     }
 
-    if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
+    if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
 	Tcl_Obj *namePtr;
 
 	TclNewObj(namePtr);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 7d67e12..fd63da3 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 && TclRoutineHasName(cmdPtr)) {
+    if (cmdPtr) {
 	TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
     }
     TclEmitPush(cmdLitIdx, envPtr);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 16bf8f7..3c99631 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3161,7 +3161,7 @@ TclCompileEnsemble(
     }
 
     /*
-     * Now that the mapping process is done we actually try to compile.
+     * Now we've done the mapping process, can now 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 need 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 needed 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 786fffb..0f1c2cc 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_DYING)) {
+	if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
 	    Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
 		    objResultPtr);
 	}
@@ -4524,18 +4524,6 @@ 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();
@@ -4545,6 +4533,12 @@ 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 2f12b8f..792b675 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1707,18 +1707,18 @@ typedef struct Command {
 /*
  * Flag bits for commands.
  *
- * CMD_DYING -			If 1 the command is in the process of
+ * CMD_IS_DELETED -		Means that 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 -		If 1 the trace processing is currently
+ * CMD_TRACE_ACTIVE -		1 means that 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 -	If 1 means that this command has at least one
+ * CMD_HAS_EXEC_TRACES -	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 -	If 1 this command has a compiler that
+ * CMD_COMPILES_EXPANDED -	1 means that 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_DYING		    0x01
+#define CMD_IS_DELETED		    0x01
 #define CMD_TRACE_ACTIVE	    0x02
 #define CMD_HAS_EXEC_TRACES	    0x04
 #define CMD_COMPILES_EXPANDED	    0x08
@@ -4960,30 +4960,10 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
  * the internal stubs, but the core can use the macro instead.
  */
 
-#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)
+#define TclCleanupCommandMacro(cmdPtr) \
+    if ((cmdPtr)->refCount-- <= 1) { \
+	ckfree(cmdPtr);\
+    }
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 673acb0..26dca62 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1770,8 +1770,6 @@ 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);
@@ -2079,7 +2077,6 @@ DeleteImportedCmd(
 		prevPtr->nextPtr = refPtr->nextPtr;
 	    }
 	    ckfree(refPtr);
-	    TclCleanupCommandMacro(realCmdPtr);
 	    ckfree(dataPtr);
 	    return;
 	}
@@ -3891,7 +3888,7 @@ NamespaceOriginCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    Tcl_Command cmd, origCmd;
+    Tcl_Command command, origCommand;
     Tcl_Obj *resultPtr;
 
     if (objc != 2) {
@@ -3899,29 +3896,30 @@ NamespaceOriginCmd(
 	return TCL_ERROR;
     }
 
-    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:
+    command = Tcl_GetCommandFromObj(interp, objv[1]);
+    if (command == NULL) {
 	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 21018ac..85f4470 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1177,7 +1177,7 @@ ObjectNamespaceDeleted(
      * freed memory.
      */
 
-    if (((Command *) oPtr->command)->flags && CMD_DYING) {
+    if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
 	/*
 	 * 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 44b2785..dbe6686 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 || !TclRoutineHasName(cmdPtr)) {
+    if (cmdPtr == NULL) {
 	return TCL_ERROR;
     }
 
diff --git a/tests/namespace.test b/tests/namespace.test
index d09a853..8209cf3 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -618,102 +618,6 @@ 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