Fix [Bug 2200824] and make class constructor error handling much more robust.

1 files changed, 64 insertions, 34 deletions

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 4d680ea..a96d267 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.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: tclOODefineCmds.c,v 1.6 2008/10/10 13:04:09 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.7 2008/10/31 22:08:32 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -25,6 +25,8 @@
 static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
 static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
 			    Tcl_Namespace *const namespacePtr);
+static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
+			    Tcl_Obj *className, const char *errMsg);
 static inline int	InitDefineContext(Tcl_Interp *interp,
 			    Tcl_Namespace *namespacePtr, Object *oPtr,
 			    int objc, Tcl_Obj *const objv[]);
@@ -605,6 +607,46 @@ TclOOGetDefineCmdContext(
 /*
  * ----------------------------------------------------------------------
  *
+ * GetClassInOuterContext --
+ *	Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
+ *	context that called oo::define (or equivalent). Note that this may
+ *	have to go up multiple levels to get the level that we started doing
+ *	definitions at.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Class *
+GetClassInOuterContext(
+    Tcl_Interp *interp,
+    Tcl_Obj *className,
+    const char *errMsg)
+{
+    Interp *iPtr = (Interp *) interp;
+    Object *oPtr;
+    CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+	if (iPtr->varFramePtr->callerVarPtr == NULL) {
+	    Tcl_Panic("getting outer context when already in global context");
+	}
+	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
+    iPtr->varFramePtr = savedFramePtr;
+    if (oPtr == NULL) {
+	return NULL;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, errMsg, NULL);
+	return NULL;
+    }
+    return oPtr->classPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineObjCmd --
  *	Implementation of the "oo::define" command. Works by effectively doing
  *	the same as 'namespace eval', but with extra magic applied so that the
@@ -982,7 +1024,8 @@ TclOODefineClassObjCmd(
     int objc,
     Tcl_Obj *const *objv)
 {
-    Object *oPtr, *o2Ptr;
+    Object *oPtr;
+    Class *clsPtr;
     Foundation *fPtr = TclOOGetFoundation(interp);
 
     /*
@@ -1012,13 +1055,9 @@ TclOODefineClassObjCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "className");
 	return TCL_ERROR;
     }
-    o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
-    if (o2Ptr == NULL) {
-	return TCL_ERROR;
-    }
-    if (o2Ptr->classPtr == NULL) {
-	Tcl_AppendResult(interp, "the class of an object must be a class",
-		NULL);
+    clsPtr = GetClassInOuterContext(interp, objv[1],
+	    "the class of an object must be a class");
+    if (clsPtr == NULL) {
 	return TCL_ERROR;
     }
 
@@ -1028,8 +1067,7 @@ TclOODefineClassObjCmd(
      * produce an error if any attempt is made to swap from one to the other.
      */
 
-    if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
-	    o2Ptr->classPtr)) {
+    if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
 	Tcl_AppendResult(interp, "may not change a ",
 		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
 		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
@@ -1040,9 +1078,9 @@ TclOODefineClassObjCmd(
      * Set the object's class.
      */
 
-    if (oPtr->selfCls != o2Ptr->classPtr) {
+    if (oPtr->selfCls != clsPtr) {
 	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
-	oPtr->selfCls = o2Ptr->classPtr;
+	oPtr->selfCls = clsPtr;
 	TclOOAddToInstances(oPtr, oPtr->selfCls);
 	if (oPtr->classPtr != NULL) {
 	    BumpGlobalEpoch(interp, oPtr->classPtr);
@@ -1513,23 +1551,17 @@ TclOODefineMixinObjCmd(
     mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
 
     for (i=1 ; i<objc ; i++) {
-	Object *o2Ptr;
+	Class *clsPtr = GetClassInOuterContext(interp, objv[i],
+		"may only mix in classes");
 
-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
-	if (o2Ptr == NULL) {
-	    goto freeAndError;
-	}
-	if (o2Ptr->classPtr == NULL) {
-	    Tcl_AppendResult(interp, "may only mix in classes; \"",
-		    TclGetString(objv[i]), "\" is not a class", NULL);
+	if (clsPtr == NULL) {
 	    goto freeAndError;
 	}
-	if (!isInstanceMixin &&
-		TclOOIsReachable(oPtr->classPtr,o2Ptr->classPtr)){
+	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
 	    goto freeAndError;
 	}
-	mixins[i-1] = o2Ptr->classPtr;
+	mixins[i-1] = clsPtr;
     }
 
     if (isInstanceMixin) {
@@ -1617,7 +1649,7 @@ TclOODefineSuperclassObjCmd(
     int objc,
     Tcl_Obj *const *objv)
 {
-    Object *oPtr, *o2Ptr;
+    Object *oPtr;
     Foundation *fPtr = TclOOGetFoundation(interp);
     Class **superclasses, *superPtr;
     int i, j;
@@ -1657,29 +1689,27 @@ TclOODefineSuperclassObjCmd(
      */
 
     for (i=0 ; i<objc-1 ; i++) {
-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
-	if (o2Ptr == NULL) {
-	    goto failedAfterAlloc;
-	}
-	if (o2Ptr->classPtr == NULL) {
-	    Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
+	Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
+		"only a class can be a superclass");
+
+	if (clsPtr == NULL) {
 	    goto failedAfterAlloc;
 	}
 	for (j=0 ; j<i ; j++) {
-	    if (superclasses[j] == o2Ptr->classPtr) {
+	    if (superclasses[j] == clsPtr) {
 		Tcl_AppendResult(interp,
 			"class should only be a direct superclass once",NULL);
 		goto failedAfterAlloc;
 	    }
 	}
-	if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
+	if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp,
 		    "attempt to form circular dependency graph", NULL);
 	failedAfterAlloc:
 	    ckfree((char *) superclasses);
 	    return TCL_ERROR;
 	}
-	superclasses[i] = o2Ptr->classPtr;
+	superclasses[i] = clsPtr;
     }
 
     /*