Reorganize method cache handling a bit to better support itcl nasty cases.

[Bug 1895546]

4 files changed, 60 insertions, 30 deletions

diff --git a/ChangeLog b/ChangeLog
index 015eb9a..4ba0279 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2009-07-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOCall.c (TclOOGetCallContext): [Bug 1895546]: Changed
+	* generic/tclOO.c (TclOOObjectCmdCore):	     the way that the cache is
+	managed so that when itcl does cunning things, those cunning things
+	can be cached properly.
+
 2009-07-11  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/vwait.n: Substantially increased the discussion of issues and
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1ba0ba8..c1e8678 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOO.c,v 1.22 2009/05/08 08:48:19 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.23 2009/07/12 14:51:30 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -625,7 +625,7 @@ ObjectRenamedTrace(
     AddRef(oPtr);
     oPtr->flags |= OBJECT_DELETED;
 
-    contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
+    contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
     if (contextPtr != NULL) {
 	int result;
 	Tcl_InterpState state;
@@ -1330,7 +1330,8 @@ Tcl_NewObjectInstance(
      */
 
     if (objc >= 0) {
-	CallContext *contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR);
+	CallContext *contextPtr =
+		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
 
 	if (contextPtr != NULL) {
 	    int result;
@@ -1426,7 +1427,7 @@ TclNRNewObjectInstance(
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
     }
-    contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR);
+    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
     if (contextPtr == NULL) {
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
@@ -2097,34 +2098,49 @@ TclOOObjectCmdCore(
     methodNamePtr = objv[1];
     if (oPtr->mapMethodNameProc != NULL) {
 	register Class **startClsPtr = &startCls;
+	Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
 
-	methodNamePtr = Tcl_DuplicateObj(methodNamePtr);
 	result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
-		(Tcl_Class *) startClsPtr, methodNamePtr);
+		(Tcl_Class *) startClsPtr, mappedMethodName);
 	if (result != TCL_OK) {
-	    if (result == TCL_ERROR) {
+	    Tcl_DecrRefCount(mappedMethodName);
+	    if (result == TCL_BREAK) {
+		goto noMapping;
+	    } else if (result == TCL_ERROR) {
 		Tcl_AddErrorInfo(interp, "\n    (while mapping method name)");
 	    }
-	    Tcl_DecrRefCount(methodNamePtr);
 	    return result;
 	}
-    }
-    Tcl_IncrRefCount(methodNamePtr);
 
-    /*
-     * Get the call chain.
-     */
+	/*
+	 * Get the call chain for the remapped name.
+	 */
 
-    contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
-	    flags | (oPtr->flags & FILTER_HANDLING));
-    if (contextPtr == NULL) {
-	Tcl_AppendResult(interp, "impossible to invoke method \"",
-		TclGetString(methodNamePtr),
-		"\": no defined method or unknown method", NULL);
-	Tcl_DecrRefCount(methodNamePtr);
-	return TCL_ERROR;
+	Tcl_IncrRefCount(mappedMethodName);
+	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
+		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+	Tcl_DecrRefCount(mappedMethodName);
+	if (contextPtr == NULL) {
+	    Tcl_AppendResult(interp, "impossible to invoke method \"",
+		    TclGetString(methodNamePtr),
+		    "\": no defined method or unknown method", NULL);
+	    return TCL_ERROR;
+	}
+    } else {
+	/*
+	 * Get the call chain.
+	 */
+
+    noMapping:
+	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
+		flags | (oPtr->flags & FILTER_HANDLING), NULL);
+	if (contextPtr == NULL) {
+	    Tcl_AppendResult(interp, "impossible to invoke method \"",
+		    TclGetString(methodNamePtr),
+		    "\": no defined method or unknown method", NULL);
+	    return TCL_ERROR;
+	}
     }
-    Tcl_DecrRefCount(methodNamePtr);
 
     /*
      * Check to see if we need to apply magical tricks to start part way
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index c4b9ab2..e9760f7 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOCall.c,v 1.13 2008/10/16 22:34:18 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOCall.c,v 1.14 2009/07/12 14:51:30 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -897,10 +897,13 @@ TclOOGetCallContext(
     Tcl_Obj *methodNameObj,	/* The name of the method to get the context
 				 * for. NULL when getting a constructor or
 				 * destructor chain. */
-    int flags)			/* What sort of context are we looking for.
+    int flags,			/* What sort of context are we looking for.
 				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
 				 * PRIVATE_METHOD, DESTRUCTOR and
 				 * FILTER_HANDLING are useful. */
+    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
+				 * to be in the same object as the
+				 * methodNameObj. */
 {
     CallContext *contextPtr;
     CallChain *callPtr;
@@ -909,6 +912,9 @@ TclOOGetCallContext(
     Tcl_HashEntry *hPtr;
     Tcl_HashTable doneFilters;
 
+    if (cacheInThisObj == NULL) {
+	cacheInThisObj = methodNameObj;
+    }
     if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
 	hPtr = NULL;
 	doFilters = 0;
@@ -944,13 +950,13 @@ TclOOGetCallContext(
 
 	const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
 
-	if (methodNameObj->typePtr == &methodNameType) {
-	    callPtr = methodNameObj->internalRep.otherValuePtr;
+	if (cacheInThisObj->typePtr == &methodNameType) {
+	    callPtr = cacheInThisObj->internalRep.otherValuePtr;
 	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
 		callPtr->refCount++;
 		goto returnContext;
 	    }
-	    methodNameObj->typePtr->freeIntRepProc(methodNameObj);
+	    cacheInThisObj->typePtr->freeIntRepProc(cacheInThisObj);
 	}
 
 	if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1067,7 +1073,7 @@ TclOOGetCallContext(
 	}
 	callPtr->refCount++;
 	Tcl_SetHashValue(hPtr, callPtr);
-	StashCallChain(methodNameObj, callPtr);
+	StashCallChain(cacheInThisObj, callPtr);
     } else if (flags & CONSTRUCTOR) {
 	if (oPtr->selfCls->constructorChainPtr) {
 	    TclOODeleteChain(oPtr->selfCls->constructorChainPtr);
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 1579ddb..17db3f1 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOInt.h,v 1.11 2009/04/11 11:18:51 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.12 2009/07/12 14:51:30 dkf Exp $
  */
 
 #ifndef TCL_OO_INTERNAL_H
@@ -512,7 +512,8 @@ MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
 MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
 MODULE_SCOPE void	TclOODelMethodRef(Method *method);
 MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
-			    Tcl_Obj *methodNameObj, int flags);
+			    Tcl_Obj *methodNameObj, int flags,
+			    Tcl_Obj *cacheInThisObj);
 MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
 MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);