Fix segmentation fault in TclOO that was noted in [16fe1b5807]. Update

coroutine and TclOO object creation routines to use TclCreateObjCommandInNs.

6 files changed, 55 insertions, 68 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a51578c..2acd2e7 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2281,11 +2281,11 @@ Tcl_CreateObjCommand(
 	tail = cmdName;
     }
 
-    return tclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
+    return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
 	proc, clientData, deleteProc);
 }
 
-Tcl_Command tclCreateObjCommandInNs (
+Tcl_Command TclCreateObjCommandInNs (
     Tcl_Interp *interp,
     const char *cmdName,	/* Name of command, without any namespace components */
     Tcl_Namespace *namespace,   /* The namespace to create the command in */
@@ -8210,7 +8210,7 @@ Tcl_NRCreateCommand(
     return (Tcl_Command) cmdPtr;
 }
 
-Tcl_Command tclNRCreateCommandInNs (
+Tcl_Command TclNRCreateCommandInNs (
     Tcl_Interp *interp,
     const char *cmdName,
     Tcl_Namespace *nsPtr,
@@ -8219,7 +8219,7 @@ Tcl_Command tclNRCreateCommandInNs (
     ClientData clientData,
     Tcl_CmdDeleteProc *deleteProc) {
     Command *cmdPtr = (Command *)
-	tclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+	TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
 
     cmdPtr->nreProc = nreProc;
     return (Tcl_Command) cmdPtr;
@@ -9009,9 +9009,9 @@ TclNRCoroutineObjCmd(
 {
     Command *cmdPtr;
     CoroutineData *corPtr;
-    const char *fullName, *procName;
-    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
-    Tcl_DString ds;
+    const char *procName, *simpleName;
+    Namespace *nsPtr, *altNsPtr, *cxtNsPtr,
+	*inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
     Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
 
     if (objc < 3) {
@@ -9019,27 +9019,22 @@ TclNRCoroutineObjCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
-     * something in tclUtil.c to find the FQ name.
-     */
-
-    fullName = TclGetString(objv[1]);
-    TclGetNamespaceForQualName(interp, fullName, NULL, 0,
-	    &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+    procName = TclGetString(objv[1]);
+    TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
+	    &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
 
     if (nsPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                 "can't create procedure \"%s\": unknown namespace",
-                fullName));
+                procName));
         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
 	return TCL_ERROR;
     }
-    if (procName == NULL) {
+    if (simpleName == NULL) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                 "can't create procedure \"%s\": bad procedure name",
-                fullName));
-        Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
+                procName));
+        Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
 	return TCL_ERROR;
     }
 
@@ -9050,16 +9045,9 @@ TclNRCoroutineObjCmd(
 
     corPtr = ckalloc(sizeof(CoroutineData));
 
-    Tcl_DStringInit(&ds);
-    if (nsPtr != iPtr->globalNsPtr) {
-	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
-	TclDStringAppendLiteral(&ds, "::");
-    }
-    Tcl_DStringAppend(&ds, procName, -1);
-
-    cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
-	    /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
-    Tcl_DStringFree(&ds);
+    cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
+	    (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
+	    corPtr, DeleteCoroutine);
 
     corPtr->cmdPtr = cmdPtr;
     cmdPtr->refCount++;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 28802b0..cce7666 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -665,7 +665,7 @@ TclCreateEnsembleInNs(
     Tcl_Command token;
 
     ensemblePtr = ckalloc(sizeof(EnsembleConfig));
-    token = tclNRCreateCommandInNs(interp, name,
+    token = TclNRCreateCommandInNs(interp, name,
 	(Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
 	NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
     if (token == NULL) {
@@ -2605,12 +2605,7 @@ BuildEnsembleConfig(
 	     * the programmer's responsibility (or [::unknown] of course).
 	     */
 
-	    cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
-	    if (ensemblePtr->nsPtr->parentPtr != NULL) {
-		Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
-	    } else {
-		Tcl_AppendStringsToObj(cmdObj, name, NULL);
-	    }
+	    cmdObj = Tcl_NewStringObj(name, -1);
 	    cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
 	    Tcl_SetHashValue(hPtr, cmdPrefixObj);
 	    Tcl_IncrRefCount(cmdPrefixObj);
@@ -2671,8 +2666,7 @@ BuildEnsembleConfig(
 		    if (isNew) {
 			Tcl_Obj *cmdObj, *cmdPrefixObj;
 
-			TclNewObj(cmdObj);
-			Tcl_AppendStringsToObj(cmdObj, nsCmdName, NULL);
+			cmdObj = Tcl_NewStringObj(nsCmdName, -1);
 			cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
 			Tcl_SetHashValue(hPtr, cmdPrefixObj);
 			Tcl_IncrRefCount(cmdPrefixObj);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 480ae5a..7078ba0 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2917,7 +2917,7 @@ MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
 			    Tcl_Obj *originObjPtr);
 MODULE_SCOPE int	TclConvertElement(const char *src, int length,
 			    char *dst, int flags);
-MODULE_SCOPE Tcl_Command tclCreateObjCommandInNs (
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
 			    Tcl_Interp *interp,
 			    const char *cmdName,
 			    Tcl_Namespace *nsPtr,
@@ -2988,7 +2988,7 @@ MODULE_SCOPE double	TclFloor(const mp_int *a);
 MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
 MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
 			    const char *attributeName, int *indexPtr);
-MODULE_SCOPE Tcl_Command tclNRCreateCommandInNs (
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
 			    Tcl_Interp *interp,
 			    const char *cmdName,
 			    Tcl_Namespace *nsPtr,
diff --git a/generic/tclOO.c b/generic/tclOO.c
index e48158c..7feeb5d 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -562,7 +562,10 @@ AllocObject(
     Object *oPtr;
     Command *cmdPtr;
     CommandTrace *tracePtr;
+    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+    Tcl_Namespace *inNsPtr;
     int creationEpoch, ignored;
+    const char *simpleName;
 
     oPtr = ckalloc(sizeof(Object));
     memset(oPtr, 0, sizeof(Object));
@@ -652,24 +655,18 @@ AllocObject(
      * command is deleted).
      */
 
-    if (!nameStr) {
-	oPtr->command = Tcl_CreateObjCommand(interp,
-		oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
-    } else if (nameStr[0] == ':' && nameStr[1] == ':') {
-	oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
-		PublicObjectCmd, oPtr, NULL);
+    if (nameStr) {
+	inNsPtr = TclGetCurrentNamespace(interp);
     } else {
-	Tcl_DString buffer;
-
-	Tcl_DStringInit(&buffer);
-	Tcl_DStringAppend(&buffer,
-		Tcl_GetCurrentNamespace(interp)->fullName, -1);
-	TclDStringAppendLiteral(&buffer, "::");
-	Tcl_DStringAppend(&buffer, nameStr, -1);
-	oPtr->command = Tcl_CreateObjCommand(interp,
-		Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
-	Tcl_DStringFree(&buffer);
+	nameStr = oPtr->namespacePtr->name;
+	inNsPtr = oPtr->namespacePtr;
     }
+    
+    TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0,
+	    &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
+
+    oPtr->command = TclCreateObjCommandInNs(interp, simpleName,
+	(Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
 
     /*
      * Add the NRE command and trace directly. While this breaks a number of
@@ -1795,6 +1792,11 @@ TclNRNewObjectInstance(
     Object *oPtr;
 
     /*
+     * Protect classPtr from getting cleaned up when the command is created.
+     */
+    AddRef(classPtr);
+
+    /*
      * Check if we're going to create an object over an existing command;
      * that's not allowed.
      */
@@ -1841,11 +1843,13 @@ TclNRNewObjectInstance(
 
     if (objc < 0) {
 	*objectPtr = (Tcl_Object) oPtr;
+	DelRef(classPtr);
 	return TCL_OK;
     }
     contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
     if (contextPtr == NULL) {
 	*objectPtr = (Tcl_Object) oPtr;
+	DelRef(classPtr);
 	return TCL_OK;
     }
 
@@ -1869,6 +1873,7 @@ TclNRNewObjectInstance(
     TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
 	    objectPtr);
     TclPushTailcallPoint(interp);
+    DelRef(classPtr);
     return TclOOInvokeContext(contextPtr, interp, objc, objv);
 }
 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 3c30623..b89357c 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -124,8 +124,8 @@ Tcl_ProcObjCmd(
 {
     register Interp *iPtr = (Interp *) interp;
     Proc *procPtr;
-    const char *fullName;
-    const char *procName, *procArgs, *procBody;
+    const char *procName;
+    const char *simpleName, *procArgs, *procBody;
     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
     Tcl_Command cmd;
 
@@ -140,21 +140,21 @@ Tcl_ProcObjCmd(
      * namespace.
      */
 
-    fullName = TclGetString(objv[1]);
-    TclGetNamespaceForQualName(interp, fullName, NULL, 0,
-	    &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+    procName = TclGetString(objv[1]);
+    TclGetNamespaceForQualName(interp, procName, NULL, 0,
+	    &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
 
     if (nsPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"can't create procedure \"%s\": unknown namespace",
-		fullName));
+		procName));
 	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
 	return TCL_ERROR;
     }
-    if (procName == NULL) {
+    if (simpleName == NULL) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"can't create procedure \"%s\": bad procedure name",
-		fullName));
+		procName));
 	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
 	return TCL_ERROR;
     }
@@ -163,15 +163,15 @@ Tcl_ProcObjCmd(
      * Create the data structure to represent the procedure.
      */
 
-    if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+    if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
 	    &procPtr) != TCL_OK) {
 	Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
-	Tcl_AddErrorInfo(interp, procName);
+	Tcl_AddErrorInfo(interp, simpleName);
 	Tcl_AddErrorInfo(interp, "\")");
 	return TCL_ERROR;
     }
 
-    cmd = tclNRCreateCommandInNs(interp, procName, (Tcl_Namespace *) nsPtr,
+    cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
 	TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
 
     /*
diff --git a/tests/namespace.test b/tests/namespace.test
index 220fa53..de96682 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1920,7 +1920,7 @@ test namespace-44.5 {ensemble: errors} -setup {
     foobar foobarcon
 } -cleanup {
     rename foobar {}
-} -returnCodes error -result {invalid command name "::foobarconfigure"}
+} -returnCodes error -result {invalid command name "foobarconfigure"}
 test namespace-44.6 {ensemble: errors} -returnCodes error -body {
     namespace ensemble create gorp
 } -result {wrong # args: should be "namespace ensemble create ?option value ...?"}