Merge tip-468 branch

1 files changed, 137 insertions, 34 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 8cb80e5..13c98f4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -83,7 +83,7 @@ TclOO_Class_Constructor(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    Tcl_Obj **invoke;
+    Tcl_Obj **invoke, *nameObj;
 
     if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,6 +94,17 @@ TclOO_Class_Constructor(
     }
 
     /*
+     * Make the class definition delegate. This is special; it doesn't reenter
+     * here (and the class definition delegate doesn't run any constructors).
+     */
+
+    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+	    TclGetString(nameObj), NULL, -1, NULL, -1);
+    Tcl_DecrRefCount(nameObj);
+
+    /*
      * Delegate to [oo::define] to do the work.
      */
 
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
     Tcl_IncrRefCount(invoke[1]);
     Tcl_IncrRefCount(invoke[2]);
     TclNRAddCallback(interp, DecrRefsPostClassConstructor,
-	    invoke, NULL, NULL, NULL);
+	    invoke, oPtr, NULL, NULL);
 
     /*
      * Tricky point: do not want the extra reported level in the Tcl stack
@@ -128,12 +139,27 @@ DecrRefsPostClassConstructor(
     int result)
 {
     Tcl_Obj **invoke = data[0];
+    Object *oPtr = data[1];
+    Tcl_InterpState saved;
+    int code;
 
     TclDecrRefCount(invoke[0]);
     TclDecrRefCount(invoke[1]);
     TclDecrRefCount(invoke[2]);
+    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+    invoke[1] = TclOOObjectName(interp, oPtr);
+    Tcl_IncrRefCount(invoke[0]);
+    Tcl_IncrRefCount(invoke[1]);
+    saved = Tcl_SaveInterpState(interp, result);
+    code = Tcl_EvalObjv(interp, 2, invoke, 0);
+    TclDecrRefCount(invoke[0]);
+    TclDecrRefCount(invoke[1]);
     ckfree(invoke);
-    return result;
+    if (code != TCL_OK) {
+	Tcl_DiscardInterpState(saved);
+	return code;
+    }
+    return Tcl_RestoreInterpState(interp, saved);
 }
 
 /*
@@ -347,7 +373,8 @@ TclOO_Object_Destroy(
     }
     if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
 	oPtr->flags |= DESTRUCTOR_CALLED;
-	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
+		NULL);
 	if (contextPtr != NULL) {
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
@@ -499,9 +526,12 @@ TclOO_Object_Unknown(
     Tcl_Obj *const *objv)	/* The actual arguments. */
 {
     CallContext *contextPtr = (CallContext *) context;
+    Object *callerObj = NULL;
+    Class *callerCls = NULL;
     Object *oPtr = contextPtr->oPtr;
     const char **methodNames;
     int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
     Tcl_Obj *errorMsg;
 
     /*
@@ -516,10 +546,31 @@ TclOO_Object_Unknown(
     }
 
     /*
+     * Determine if the calling context should know about extra private
+     * methods, and if so, which.
+     */
+
+    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	CallContext *callerContext = framePtr->clientData;
+	Method *mPtr = callerContext->callPtr->chain[
+		    callerContext->index].mPtr;
+
+	if (mPtr->declaringObjectPtr) {
+	    if (oPtr == mPtr->declaringObjectPtr) {
+		callerObj = mPtr->declaringObjectPtr;
+	    }
+	} else {
+	    if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
+		callerCls = mPtr->declaringClassPtr;
+	    }
+	}
+    }
+
+    /*
      * Get the list of methods that we want to know about.
      */
 
-    numMethodNames = TclOOGetSortedMethodList(oPtr,
+    numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
 	    contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
 
     /*
@@ -684,6 +735,7 @@ TclOO_Object_VarName(
 {
     Var *varPtr, *aryVar;
     Tcl_Obj *varNamePtr, *argPtr;
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
     const char *arg;
 
     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -709,6 +761,58 @@ TclOO_Object_VarName(
 	Tcl_Namespace *namespacePtr =
 		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
 
+	/*
+	 * Private method handling. [TIP 500]
+	 *
+	 * If we're in a context that can see some private methods of an
+	 * object, we may need to precede a variable name with its prefix.
+	 * This is a little tricky as we need to check through the inheritance
+	 * hierarchy when the method was declared by a class to see if the
+	 * current object is an instance of that class.
+	 */
+
+	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+	    CallContext *callerContext = framePtr->clientData;
+	    Method *mPtr = callerContext->callPtr->chain[
+		    callerContext->index].mPtr;
+	    PrivateVariableMapping *pvPtr;
+	    int i;
+
+	    if (mPtr->declaringObjectPtr == oPtr) {
+		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
+		    if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+			    Tcl_GetString(argPtr))) {
+			argPtr = pvPtr->fullNameObj;
+			break;
+		    }
+		}
+	    } else if (mPtr->declaringClassPtr &&
+		    mPtr->declaringClassPtr->privateVariables.num) {
+		Class *clsPtr = mPtr->declaringClassPtr;
+		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
+		Class *mixinCls;
+
+		if (!isInstance) {
+		    FOREACH(mixinCls, oPtr->mixins) {
+			if (TclOOIsReachable(clsPtr, mixinCls)) {
+			    isInstance = 1;
+			    break;
+			}
+		    }
+		}
+		if (isInstance) {
+		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
+			if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+				Tcl_GetString(argPtr))) {
+			    argPtr = pvPtr->fullNameObj;
+			    break;
+			}
+		    }
+		}
+	    }
+	}
+
 	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
 	Tcl_AppendToObj(varNamePtr, "::", 2);
 	Tcl_AppendObjToObj(varNamePtr, argPtr);
@@ -729,26 +833,16 @@ TclOO_Object_VarName(
 
     varNamePtr = Tcl_NewObj();
     if (aryVar != NULL) {
-	Tcl_HashEntry *hPtr;
-	Tcl_HashSearch search;
-
 	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
 
 	/*
 	 * WARNING! This code pokes inside the implementation of hash tables!
 	 */
 
-	hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
-		&search);
-	while (hPtr != NULL) {
-	    if (varPtr == Tcl_GetHashValue(hPtr)) {
-		Tcl_AppendToObj(varNamePtr, "(", -1);
-		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
-		Tcl_AppendToObj(varNamePtr, ")", -1);
-		break;
-	    }
-	    hPtr = Tcl_NextHashEntry(&search);
-	}
+	Tcl_AppendToObj(varNamePtr, "(", -1);
+	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
+		varPtr)->entry.key.objPtr);
+	Tcl_AppendToObj(varNamePtr, ")", -1);
     } else {
 	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
     }
@@ -1183,8 +1277,9 @@ TclOOCopyObjectCmd(
 {
     Tcl_Object oPtr, o2Ptr;
 
-    if (objc < 2 || objc > 3) {
-	Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+    if (objc < 2 || objc > 4) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+			 "sourceName ?targetName? ?targetNamespace?");
 	return TCL_ERROR;
     }
 
@@ -1204,24 +1299,32 @@ TclOOCopyObjectCmd(
     if (objc == 2) {
 	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
     } else {
-	const char *name;
-	Tcl_DString buffer;
+	const char *name, *namespaceName;
 
 	name = TclGetString(objv[2]);
-	Tcl_DStringInit(&buffer);
-	if (name[0]!=':' || name[1]!=':') {
-	    Interp *iPtr = (Interp *) interp;
+	if (name[0] == '\0') {
+	    name = NULL;
+	}
+
+	/*
+	 * Choose a unique namespace name if the user didn't supply one.
+	 */
+
+	namespaceName = NULL;
+	if (objc == 4) {
+	    namespaceName = TclGetString(objv[3]);
 
-	    if (iPtr->varFramePtr != NULL) {
-		Tcl_DStringAppend(&buffer,
-			iPtr->varFramePtr->nsPtr->fullName, -1);
+	    if (namespaceName[0] == '\0') {
+		namespaceName = NULL;
+	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
+		    0) != NULL) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"%s refers to an existing namespace", namespaceName));
+		return TCL_ERROR;
 	    }
-	    TclDStringAppendLiteral(&buffer, "::");
-	    Tcl_DStringAppend(&buffer, name, -1);
-	    name = Tcl_DStringValue(&buffer);
 	}
-	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
-	Tcl_DStringFree(&buffer);
+
+	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
     }
 
     if (o2Ptr == NULL) {