* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut

	the amount of hackiness in class constructors, and refactor some of
	the error message handling from [oo::define] to be saner in the face
	of odd happenings.

7 files changed, 286 insertions, 158 deletions

diff --git a/ChangeLog b/ChangeLog
index e8cecb8..842695f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-05-20  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
+	the amount of hackiness in class constructors, and refactor some of
+	the error message handling from [oo::define] to be saner in the face
+	of odd happenings.
+
 2012-05-17  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected
diff --git a/generic/tclOO.c b/generic/tclOO.c
index d5cc6e1..26e6d75 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -123,6 +123,16 @@ static const DeclaredClassMethod objMethods[] = {
 };
 
 /*
+ * And for the oo::class constructor...
+ */
+
+static const Tcl_MethodType classConstructor = {
+    TCL_OO_METHOD_VERSION_CURRENT,
+    "oo::class constructor",
+    TclOO_Class_Constructor, NULL, NULL
+};
+
+/*
  * Scripted parts of TclOO. First, the master script (cannot be outside this
  * file).
  */
@@ -135,18 +145,6 @@ static const char *initScript =
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
 /*
- * The body of the constructor for oo::class.
- */
-
-static const char *classConstructorBody =
-"set script [list ::oo::define [self] $definitionScript];"
-"lassign [::oo::UpCatch $script] msg opts;"
-"if {[dict get $opts -code] == 1} {"
-"    dict set opts -errorline 0xDeadBeef"
-"};"
-"return -options $opts $msg;";
-
-/*
  * The scripted part of the definitions of slots.
  */
 
@@ -340,12 +338,12 @@ InitFoundation(
     TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
     TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
     TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
+    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
     Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
     Tcl_IncrRefCount(fPtr->constructorName);
     Tcl_IncrRefCount(fPtr->destructorName);
     Tcl_IncrRefCount(fPtr->clonedName);
-    Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
-	    TclOONRUpcatch, NULL, NULL);
+    Tcl_IncrRefCount(fPtr->defineName);
     Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
 	    TclOOUnknownDefinition, NULL, NULL);
     TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
@@ -418,28 +416,19 @@ InitFoundation(
     bodyPtr = Tcl_NewStringObj(clonedBody, -1);
     TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
 	    bodyPtr, NULL);
-    Tcl_DecrRefCount(argsPtr);
+    TclDecrRefCount(argsPtr);
 
     /*
      * 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.
      */
 
     TclNewLiteralStringObj(namePtr, "new");
     Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
 	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
-
-    TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
-    Tcl_IncrRefCount(argsPtr);
-    bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
-    fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
-	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
-    Tcl_DecrRefCount(argsPtr);
+    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
 
     /*
      * Create non-object commands and plug ourselves into the Tcl [info]
@@ -529,10 +518,11 @@ KillFoundation(
 
     DelRef(fPtr->objectCls->thisPtr);
     DelRef(fPtr->objectCls);
-    Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
-    Tcl_DecrRefCount(fPtr->constructorName);
-    Tcl_DecrRefCount(fPtr->destructorName);
-    Tcl_DecrRefCount(fPtr->clonedName);
+    TclDecrRefCount(fPtr->unknownMethodNameObj);
+    TclDecrRefCount(fPtr->constructorName);
+    TclDecrRefCount(fPtr->destructorName);
+    TclDecrRefCount(fPtr->clonedName);
+    TclDecrRefCount(fPtr->defineName);
     ckfree(fPtr);
 }
 
@@ -789,7 +779,7 @@ ObjectRenamedTrace(
 
     if (flags & TCL_TRACE_RENAME) {
 	if (oPtr->cachedNameObj) {
-	    Tcl_DecrRefCount(oPtr->cachedNameObj);
+	    TclDecrRefCount(oPtr->cachedNameObj);
 	    oPtr->cachedNameObj = NULL;
 	}
 	return;
@@ -1044,7 +1034,7 @@ ReleaseClassContents(
 	Tcl_Obj *filterObj;
 
 	FOREACH(filterObj, clsPtr->filters) {
-	    Tcl_DecrRefCount(filterObj);
+	    TclDecrRefCount(filterObj);
 	}
 	ckfree(clsPtr->filters.list);
 	clsPtr->filters.num = 0;
@@ -1123,7 +1113,7 @@ ObjectNamespaceDeleted(
     }
 
     FOREACH(filterObj, oPtr->filters) {
-	Tcl_DecrRefCount(filterObj);
+	TclDecrRefCount(filterObj);
     }
     if (i) {
 	ckfree(oPtr->filters.list);
@@ -1138,7 +1128,7 @@ ObjectNamespaceDeleted(
     }
 
     FOREACH(variableObj, oPtr->variables) {
-	Tcl_DecrRefCount(variableObj);
+	TclDecrRefCount(variableObj);
     }
     if (i) {
 	ckfree(oPtr->variables.list);
@@ -1149,7 +1139,7 @@ ObjectNamespaceDeleted(
     }
 
     if (oPtr->cachedNameObj) {
-	Tcl_DecrRefCount(oPtr->cachedNameObj);
+	TclDecrRefCount(oPtr->cachedNameObj);
 	oPtr->cachedNameObj = NULL;
     }
 
@@ -1180,7 +1170,7 @@ ObjectNamespaceDeleted(
 	}
 
 	FOREACH(filterObj, clsPtr->filters) {
-	    Tcl_DecrRefCount(filterObj);
+	    TclDecrRefCount(filterObj);
 	}
 	if (i) {
 	    ckfree(clsPtr->filters.list);
@@ -1225,7 +1215,7 @@ ObjectNamespaceDeleted(
 	TclOODelMethodRef(clsPtr->destructorPtr);
 
 	FOREACH(variableObj, clsPtr->variables) {
-	    Tcl_DecrRefCount(variableObj);
+	    TclDecrRefCount(variableObj);
 	}
 	if (i) {
 	    ckfree(clsPtr->variables.list);
@@ -2490,7 +2480,7 @@ TclOOObjectCmdCore(
 	result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
 		(Tcl_Class *) startClsPtr, mappedMethodName);
 	if (result != TCL_OK) {
-	    Tcl_DecrRefCount(mappedMethodName);
+	    TclDecrRefCount(mappedMethodName);
 	    if (result == TCL_BREAK) {
 		goto noMapping;
 	    } else if (result == TCL_ERROR) {
@@ -2506,7 +2496,7 @@ TclOOObjectCmdCore(
 	Tcl_IncrRefCount(mappedMethodName);
 	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
 		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
-	Tcl_DecrRefCount(mappedMethodName);
+	TclDecrRefCount(mappedMethodName);
 	if (contextPtr == NULL) {
 	    Tcl_AppendResult(interp, "impossible to invoke method \"",
 		    TclGetString(methodNamePtr),
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 329f0a4..5e983fc 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,6 +19,8 @@
 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
 static int		AfterNRDestructor(ClientData data[],
 			    Tcl_Interp *interp, int result);
+static int		DecrRefsPostClassConstructor(ClientData data[],
+			    Tcl_Interp *interp, int result);
 static int		FinalizeConstruction(ClientData data[],
 			    Tcl_Interp *interp, int result);
 static int		FinalizeEval(ClientData data[],
@@ -70,6 +72,74 @@ FinalizeConstruction(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOO_Class_Constructor --
+ *
+ *	Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Tcl_Obj *invoke[3];
+
+    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"?definitionScript?");
+	return TCL_ERROR;
+    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+	return TCL_OK;
+    }
+
+    /*
+     * Delegate to [oo::define] to do the work.
+     */
+
+    invoke[0] = oPtr->fPtr->defineName;
+    invoke[1] = TclOOObjectName(interp, oPtr);
+    invoke[2] = objv[objc-1];
+
+    /*
+     * Must add references or errors in configuration script will cause
+     * trouble.
+     */
+
+    Tcl_IncrRefCount(invoke[0]);
+    Tcl_IncrRefCount(invoke[1]);
+    Tcl_IncrRefCount(invoke[2]);
+    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+	    invoke[0], invoke[1], invoke[2], NULL);
+
+    /*
+     * Tricky point: do not want the extra reported level in the Tcl stack
+     * trace, so use TCL_EVAL_NOERR.
+     */
+
+    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    TclDecrRefCount((Tcl_Obj *) data[0]);
+    TclDecrRefCount((Tcl_Obj *) data[1]);
+    TclDecrRefCount((Tcl_Obj *) data[2]);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Class_Create --
  *
  *	Implementation for oo::class->create method.
@@ -1141,74 +1211,6 @@ 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)", Tcl_GetErrorLine(interp)));
-	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;
-
-    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 3d72690..69cffb0 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,13 @@
 #include "tclOOInt.h"
 
 /*
+ * The maximum length of fully-qualified object name to use in an errorinfo
+ * message. Longer than this will be curtailed.
+ */
+
+#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30
+
+/*
  * Some things that make it easier to declare a slot.
  */
 
@@ -40,6 +47,8 @@ struct DeclaredSlot {
 static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
 static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
 			    Tcl_Namespace *const namespacePtr);
+static void		GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
 static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
 			    Tcl_Obj *className, const char *errMsg);
 static inline int	InitDefineContext(Tcl_Interp *interp,
@@ -673,6 +682,7 @@ TclOOGetDefineCmdContext(
     Tcl_Interp *interp)
 {
     Interp *iPtr = (Interp *) interp;
+    Tcl_Object object;
 
     if ((iPtr->varFramePtr == NULL)
 	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
@@ -682,7 +692,14 @@ TclOOGetDefineCmdContext(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return NULL;
     }
-    return (Tcl_Object) iPtr->varFramePtr->clientData;
+    object = iPtr->varFramePtr->clientData;
+    if (Tcl_ObjectDeleted(object)) {
+	Tcl_AppendResult(interp, "this command cannot be called when the "
+		"object has been deleted", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return NULL;
+    }
+    return object;
 }
 
 /*
@@ -730,6 +747,44 @@ GetClassInOuterContext(
 /*
  * ----------------------------------------------------------------------
  *
+ * GenerateErrorInfo --
+ *	Factored out code to generate part of the error trace messages.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+GenerateErrorInfo(
+    Tcl_Interp *interp,		/* Where to store the error info trace. */
+    Object *oPtr,		/* What object (or class) was being configured
+				 * when the error occurred? */
+    Tcl_Obj *savedNameObj,	/* Name of object saved from before script was
+				 * evaluated, which is needed if the object
+				 * goes away part way through execution. OTOH,
+				 * if the object isn't deleted then its
+				 * current name (post-execution) has to be
+				 * used. This matters, because the object
+				 * could have been renamed... */
+    const char *typeOfSubject)	/* Part of the message, saying whether it was
+				 * an object, class or class-as-object that
+				 * was being configured. */
+{
+    int length;
+    Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
+	    ? savedNameObj : TclOOObjectName(interp, oPtr);
+    const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
+    int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
+    int overflow = (length > limit);
+
+    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+	    "\n    (in definition script for %s \"%.*s%s\" line %d)",
+	    typeOfSubject, (overflow ? limit : length), objName,
+	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineObjCmd --
  *	Implementation of the "oo::define" command. Works by effectively doing
  *	the same as 'namespace eval', but with extra magic applied so that the
@@ -779,20 +834,15 @@ TclOODefineObjCmd(
 
     AddRef(oPtr);
     if (objc == 3) {
+	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+	Tcl_IncrRefCount(objNameObj);
 	result = TclEvalObjEx(interp, objv[2], 0,
 		((Interp *)interp)->cmdFramePtr, 2);
-
 	if (result == TCL_ERROR) {
-	    int length;
-	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
-	    int limit = 60;
-	    int overflow = (length > limit);
-
-	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		    "\n    (in definition script for object \"%.*s%s\" line %d)",
-		    (overflow ? limit : length), objName,
-		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+	    GenerateErrorInfo(interp, oPtr, objNameObj, "class");
 	}
+	TclDecrRefCount(objNameObj);
     } else {
 	Tcl_Obj *objPtr, *obj2Ptr, **objs;
 	Interp *iPtr = (Interp *) interp;
@@ -898,20 +948,15 @@ TclOOObjDefObjCmd(
 
     AddRef(oPtr);
     if (objc == 3) {
+	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+	Tcl_IncrRefCount(objNameObj);
 	result = TclEvalObjEx(interp, objv[2], 0,
 		((Interp *)interp)->cmdFramePtr, 2);
-
 	if (result == TCL_ERROR) {
-	    int length;
-	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
-	    int limit = 60;
-	    int overflow = (length > limit);
-
-	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		    "\n    (in definition script for object \"%.*s%s\" line %d)",
-		    (overflow ? limit : length), objName,
-		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+	    GenerateErrorInfo(interp, oPtr, objNameObj, "object");
 	}
+	TclDecrRefCount(objNameObj);
     } else {
 	Tcl_Obj *objPtr, *obj2Ptr, **objs;
 	Interp *iPtr = (Interp *) interp;
@@ -1017,21 +1062,15 @@ TclOODefineSelfObjCmd(
 
     AddRef(oPtr);
     if (objc == 2) {
+	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+	Tcl_IncrRefCount(objNameObj);
 	result = TclEvalObjEx(interp, objv[1], 0,
 		((Interp *)interp)->cmdFramePtr, 2);
-
 	if (result == TCL_ERROR) {
-	    int length;
-	    const char *objName = Tcl_GetStringFromObj(
-		    TclOOObjectName(interp, oPtr), &length);
-	    int limit = 60;
-	    int overflow = (length > limit);
-
-	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		    "\n    (in definition script for object \"%.*s%s\" line %d)",
-		    (overflow ? limit : length), objName,
-		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+	    GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
 	}
+	TclDecrRefCount(objNameObj);
     } else {
 	Tcl_Obj *objPtr, *obj2Ptr, **objs;
 	Interp *iPtr = (Interp *) interp;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 7988452..631961f 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -322,6 +322,7 @@ typedef struct Foundation {
 				 * destructor. */
     Tcl_Obj *clonedName;	/* Shared object containing the name of a
 				 * "<cloned>" pseudo-constructor. */
+    Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
 } Foundation;
 
 /*
@@ -453,6 +454,9 @@ MODULE_SCOPE int	TclOOSelfObjCmd(ClientData clientData,
  * Method implementations (in tclOOBasic.c).
  */
 
+MODULE_SCOPE int	TclOO_Class_Constructor(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOO_Class_Create(ClientData clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
@@ -519,8 +523,6 @@ 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,
@@ -532,9 +534,6 @@ MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
 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/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..877c3db 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1204,15 +1204,6 @@ ConstructorErrorHandler(
     const char *objectName, *kindName;
     int objectNameLen;
 
-    if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) {
-	/*
-	 * Horrible hack to deal with certain constructors that must not add
-	 * information to the error trace.
-	 */
-
-	return;
-    }
-
     if (mPtr->declaringObjectPtr != NULL) {
 	declarerPtr = mPtr->declaringObjectPtr;
 	kindName = "object";
diff --git a/tests/oo.test b/tests/oo.test
index f3c0bda..00663e9 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1974,7 +1974,7 @@ test oo-18.1 {OO: define command support} {
 } {1 foo {foo
     while executing
 "error foo"
-    (in definition script for object "oo::object" line 1)
+    (in definition script for class "::oo::object" line 1)
     invoked from within
 "oo::define oo::object {error foo}"}}
 test oo-18.2 {OO: define command support} {
@@ -1987,7 +1987,7 @@ test oo-18.3 {OO: define command support} {
 } {1 bar {bar
     while executing
 "error bar"
-    (in definition script for object "::foo" line 1)
+    (in definition script for class "::foo" line 1)
     invoked from within
 "oo::class create foo {error bar}"}}
 test oo-18.3a {OO: define command support} {
@@ -1997,7 +1997,7 @@ test oo-18.3a {OO: define command support} {
 } {1 bar {bar
     while executing
 "error bar"
-    (in definition script for object "::foo" line 2)
+    (in definition script for class "::foo" line 2)
     invoked from within
 "oo::class create foo {
     error bar
@@ -2015,7 +2015,7 @@ test oo-18.3b {OO: define command support} {
     ("eval" body line 1)
     invoked from within
 "eval eval error bar"
-    (in definition script for object "::foo" line 2)
+    (in definition script for class "::foo" line 2)
     invoked from within
 "oo::class create foo {
     eval eval error bar
@@ -2070,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
     (class "::cls" method "eval" line 1)
     invoked from within
 "obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+    oo::class create super_abc
+} -body {
+    catch {
+oo::class create abc {
+    superclass super_abc
+    ::rename abc ::def
+    ::error foo
+}
+    } msg opt
+    dict get $opt -errorinfo
+} -cleanup {
+    super_abc destroy
+} -result {foo
+    while executing
+"::error foo"
+    (in definition script for class "::def" line 4)
+    invoked from within
+"oo::class create abc {
+    superclass super_abc
+    ::rename abc ::def
+    ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+    oo::object create ::inst
+} -body {
+    list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+    catch {::inst destroy}
+    catch {::INST destroy}
+} -result {1 foo {foo
+    while executing
+"error foo"
+    (in definition script for object "::INST" line 1)
+    invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+    oo::class create master
+    oo::class create ::foo {superclass master}
+} -body {
+    catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+    dict get $opt -errorinfo
+} -cleanup {
+    master destroy
+} -result {foobar
+    while executing
+"error foobar"
+    (in definition script for class object "::bar" line 1)
+    invoked from within
+"self {error foobar}"
+    (in definition script for class "::bar" line 1)
+    invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+    oo::class create master
+    set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+        superclass master
+    }]
+} -body {
+    catch {oo::define $c {error err}} msg opt
+    dict get $opt -errorinfo
+} -cleanup {
+    master destroy
+} -result {err
+    while executing
+"error err"
+    (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+    invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+    oo::class create master
+    oo::class create ::foo {superclass master}
+} -body {
+    catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+    dict get $opt -errorinfo
+} -cleanup {
+    master destroy
+} -result {foobar
+    while executing
+"error foobar"
+    (in definition script for class object "::foo" line 1)
+    invoked from within
+"self {rename ::foo {}; error foobar}"
+    (in definition script for class "::foo" line 1)
+    invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+    oo::class create master
+    oo::class create ::foo {superclass master}
+} -body {
+    catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+    dict get $opt -errorinfo
+} -cleanup {
+    master destroy
+} -result {this command cannot be called when the object has been deleted
+    while executing
+"self {error foobar}"
+    (in definition script for class "::foo" line 1)
+    invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
 
 test oo-19.1 {OO: varname method} -setup {
     oo::object create inst
@@ -3189,7 +3289,7 @@ test oo-33.2 {TIP 380: slots - defaulting} -setup {
 } -cleanup {
     rename $s {}
 } -result {{} {a b c destroy unknown}}
-test oo-32.3 {TIP 380: slots - defaulting} -setup {
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
     set s [SampleSlot new]
 } -body {
     oo::objdefine $s forward --default-operation  my -set