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

6 files changed, 233 insertions, 58 deletions

diff --git a/ChangeLog b/ChangeLog
index e2d4608..6880855 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2008-10-31  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOBasic.c (TclOONRUpcatch): Reworked the code that does
+	* generic/tclOO.c (InitFoundation):	 class constructor handling so
+	that it is more robust and runs the constructor call in the context of
+	the caller of the class's constructor method. Needed because the
+	previously used code did not work at all after applying the fix below;
+	no Tcl existing command could reliably do what was needed any more.
+
+	* generic/tclOODefineCmds.c (GetClassInOuterContext): Rework and
+	factor out the code to resolve class names in definitions so that
+	classes are resolved from the perspective of the caller of the
+	[oo::define] command, rather than from the oo::define namespace! This
+	makes much code simpler by reducing how often fully-qualified names
+	are required (previously always in practice, so no back-compat issues
+	exist). [Bug 2200824]
+
 2008-10-28  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclCompile.h:      CONSTify TclDTraceInfo
@@ -8,27 +25,26 @@
 
 2008-10-27  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclEncoding.c:	Use "iso8859-1" and not "identity"
-	as the default and original [encoding system] value.  Since
-	"iso8859-1" is built in to the C source code for Tcl now, there's no
-	availability issue, and it has the good feature of "identity" that
-	we must have ("bytes in" == "bytes out") without the bad feature of
-	"identity" ("broken as designed") that makes us want to abandon it.
-	[RFE 2008609]
-	*** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and
-	any other code expecting a particular value for Tcl's default
-	system encoding ***
+	* generic/tclEncoding.c:	Use "iso8859-1" and not "identity" as
+	the default and original [encoding system] value. Since "iso8859-1" is
+	built in to the C source code for Tcl now, there's no availability
+	issue, and it has the good feature of "identity" that we must have
+	("bytes in" == "bytes out") without the bad feature of "identity"
+	("broken as designed") that makes us want to abandon it. [RFE 2008609]
+	*** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and any
+	other code expecting a particular value for Tcl's default system
+	encoding ***
 
 2008-10-24  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
 	* library/http/http.tcl: Fixed a failure to read SHOUTcast streams
-	with the new 2.7 package. Introduced a new intial state as the
-	first response may not be HTTP*.
+	with the new 2.7 package. Introduced a new intial state as the first
+	response may not be HTTP*.
 
 2008-10-23  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in
-	the for body [Bug 2186888].
+	* generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in the for
+	body [Bug 2186888].
 
 2008-10-22  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -53,7 +69,7 @@
 2008-10-19  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclProc.c:    Reset -level and -code values to defaults
-	after they are used.  [Bug 2152286].
+	after they are used. [Bug 2152286]
 
 2008-10-19  Donal K. Fellows  <dkf@users.sf.net>
 
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.
diff --git a/tests/oo.test b/tests/oo.test
index 2df1d4d..ff2f79f 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: oo.test,v 1.15 2008/10/10 13:04:09 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.16 2008/10/31 22:08:32 dkf Exp $
 
 package require TclOO 0.4 ;# Must match value in configure.in
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -594,6 +594,25 @@ test oo-7.8 {OO: next at the end of the method chain} -setup {
     }
     lappend result [catch {[foo2 new] bar} msg] $msg
 } -result {foo2 foo 1 {no next method implementation}}
+test oo-7.9 {OO: defining inheritance in namespaces} -setup {
+    set ::result {}
+    oo::class create ::master
+    namespace eval ::foo {
+	oo::class create mixin {superclass ::master}
+    }
+} -cleanup {
+    ::master destroy
+    namespace delete ::foo
+} -body {
+    namespace eval ::foo {
+	oo::class create bar {superclass master}
+	oo::class create boo
+	oo::define boo {superclass bar}
+	oo::define boo {mixin mixin}
+	oo::class create spong {superclass boo}
+	return
+    }
+} -result {}
 
 test oo-8.1 {OO: global must work in methods} {
     oo::object create foo
@@ -1324,6 +1343,36 @@ test oo-18.3 {OO: define command support} {
     (in definition script for object "::foo" line 1)
     invoked from within
 "oo::class create foo {error bar}"}}
+test oo-18.3a {OO: define command support} {
+    list [catch {oo::class create foo {
+    error bar
+}} msg] $msg $errorInfo
+} {1 bar {bar
+    while executing
+"error bar"
+    (in definition script for object "::foo" line 2)
+    invoked from within
+"oo::class create foo {
+    error bar
+}"}}
+test oo-18.3b {OO: define command support} {
+    list [catch {oo::class create foo {
+    eval eval error bar
+}} msg] $msg $errorInfo
+} {1 bar {bar
+    while executing
+"error bar"
+    ("eval" body line 1)
+    invoked from within
+"eval error bar"
+    ("eval" body line 1)
+    invoked from within
+"eval eval error bar"
+    (in definition script for object "::foo" line 2)
+    invoked from within
+"oo::class create foo {
+    eval eval error bar
+}"}}
 test oo-18.4 {OO: more error traces from the guts} -setup {
     oo::object create obj
 } -body {