From 7afb51929c36eb56d586471d1411586a7f3c2a6e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 4 Aug 2008 04:49:23 +0000
Subject:         * generic/tclExecute.c: Stopped faulty double-logging of
 errors to         * tests/execute.test:   stack trace when a compile epoch
 bump triggers         fallback to direct evaluation of commands in a compiled
 script.         [Bug 2037338]

---
 ChangeLog            |  7 +++++++
 generic/tclExecute.c | 12 +++++++++++-
 tests/execute.test   | 23 ++++++++++++++++++++++-
 3 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index a37f982..2730b57 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-08-04  Don Porter  <dgp@users.sourceforge.net>S
+
+	* generic/tclExecute.c: Stopped faulty double-logging of errors to
+	* tests/execute.test:   stack trace when a compile epoch bump triggers
+	fallback to direct evaluation of commands in a compiled script.
+	[Bug 2037338]
+
 2008-08-03  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c:      new unsupported command atProcExit
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3f8f4a7..360525e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.394 2008/08/03 17:33:10 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.395 2008/08/04 04:49:24 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2294,6 +2294,16 @@ TclExecuteByteCode(
 	    CACHE_STACK_INFO();
 	    if (result != TCL_OK) {
 		cleanup = 0;
+		if (result == TCL_ERROR) {
+		    /*
+		     * Tcl_EvalEx already did the task of logging
+		     * the error to the stack trace for us, so set
+		     * a flag to prevent the TEBC exception handling
+		     * machinery from trying to do it again.
+		     * Tcl Bug 2037338.  See test execute-8.4.
+		     */
+		    iPtr->flags |= ERR_ALREADY_LOGGED;
+		}
 		goto processExceptionReturn;
 	    }
 	    opnd = TclGetUInt4AtPtr(pc+1);
diff --git a/tests/execute.test b/tests/execute.test
index a43e8e6..6c34dc1 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: execute.test,v 1.27 2008/03/07 19:04:10 dgp Exp $
+# RCS: @(#) $Id: execute.test,v 1.28 2008/08/04 04:49:24 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -937,6 +937,27 @@ test execute-8.3 {Stack restoration} -body {
      interp recursionlimit {} $limit
  } -result {too many nested evaluations (infinite loop?)}
 
+test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
+    proc foo {} {
+	error bar
+    }
+    proc FOO {} {
+	catch {error bar} m o
+	rename ::set ::dummy
+	rename ::dummy ::set
+	return -options $o $m
+    }
+} -body {
+    catch foo m o
+    set stack1 [dict get $o -errorinfo]
+    catch FOO m o
+    set stack2 [string map {FOO foo} [dict get $o -errorinfo]]
+    expr {$stack1 eq $stack2 ? {} : "These differ:\n$stack1\n$stack2"}
+} -cleanup {
+    rename foo {}
+    rename FOO {}
+} -result {}
+
 test execute-9.1 {Interp result resetting [Bug 1522803]} {
     set c 0
     catch {
-- 
cgit v0.12