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

1 files changed, 12 insertions, 6 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);