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

4 files changed, 152 insertions, 42 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 11a7cbd..e161563 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.17 2008/09/23 05:05:48 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.18 2008/10/31 22:08:32 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -246,6 +246,8 @@ InitFoundation(
     Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
     Tcl_IncrRefCount(fPtr->constructorName);
     Tcl_IncrRefCount(fPtr->destructorName);
+    Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
+	    TclOONRUpcatch, NULL, NULL);
     Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
 	    TclOOUnknownDefinition, NULL, NULL);
     namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
@@ -309,6 +311,10 @@ InitFoundation(
      * Finish setting up the class of classes by marking the 'new' method as
      * private; classes, unlike general objects, must have explicit names. We
      * also need to create the constructor for classes.
+     *
+     * The 0xDeadBeef is a special signal to the errorInfo logger that is used
+     * by constructors that stops it from generating extra error information
+     * that is confusing.
      */
 
     namePtr = Tcl_NewStringObj("new", -1);
@@ -318,12 +324,12 @@ InitFoundation(
     argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
     Tcl_IncrRefCount(argsPtr);
     bodyPtr = Tcl_NewStringObj(
-	    "if {[catch {define [self] $definitionScript} msg opt]} {\n"
-	    "set ei [split [dict get $opt -errorinfo] \\n]\n"
-	    "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"
-	    "dict set opt -errorline 0xdeadbeef\n"
+	    "set script [list ::oo::define [self] $definitionScript];"
+	    "lassign [::oo::UpCatch $script] msg opts\n"
+	    "if {[dict get $opts -code] == 1} {"
+	    "    dict set opts -errorline 0xDeadBeef\n"
 	    "}\n"
-	    "return -options $opt $msg", -1);
+	    "return -options $opts $msg", -1);
     fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
 	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
     Tcl_DecrRefCount(argsPtr);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index cbece15..394ea60 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.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: tclOOBasic.c,v 1.13 2008/10/16 22:34:18 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.14 2008/10/31 22:08:32 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -975,6 +975,75 @@ TclOOCopyObjectCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOUpcatchCmd --
+ *
+ *	Implementation of the [oo::UpCatch] command, which is a combination of
+ *	[uplevel 1] and [catch] that makes it easier to write transparent
+ *	error handling in scripts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOUpcatchCmd(
+    ClientData ignored,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
+}
+
+static int
+UpcatchCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *savedFramePtr = data[0];
+    Tcl_Obj *resultObj[2];
+    int rewind = iPtr->execEnvPtr->rewind;
+
+    iPtr->varFramePtr = savedFramePtr;
+    if (rewind || Tcl_LimitExceeded(interp)) {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		"\n    (\"UpCatch\" body line %d)", interp->errorLine));
+	return TCL_ERROR;
+    }
+    resultObj[0] = Tcl_GetObjResult(interp);
+    resultObj[1] = Tcl_GetReturnOptions(interp, result);
+    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
+    return TCL_OK;
+}
+
+int
+TclOONRUpcatch(
+    ClientData ignored,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *savedFramePtr = iPtr->varFramePtr;
+    Tcl_Obj *scriptObj;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "script");
+	return TCL_ERROR;
+    }
+    if (iPtr->varFramePtr->callerVarPtr != NULL) {
+	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+    }
+
+    Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
+    return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
+	    iPtr->cmdFramePtr, 1);
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
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;
     }
 
     /*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 4b6b8a0..3221fcc 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.9 2008/10/13 13:13:45 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.10 2008/10/31 22:08:32 dkf Exp $
  */
 
 #ifndef TCL_OO_INTERNAL_H
@@ -525,6 +525,8 @@ MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
 			    Tcl_Obj *const *objv, int skip);
 MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
 			    const DeclaredClassMethod *dcm);
+MODULE_SCOPE int	TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
 MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
 MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
@@ -534,6 +536,9 @@ MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
 MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
 			    CallContext *contextPtr);
 MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
+MODULE_SCOPE int	TclOOUpcatchCmd(ClientData ignored,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 
 /*
  * Include all the private API, generated from tclOO.decls.