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

[Bug 1895546]

1 files changed, 38 insertions, 22 deletions

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