From 4c3c492b67b48506cdf77c1f146af9f4318f24c1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 6 Aug 2008 21:23:13 +0000
Subject:         * generic/tclOO.c:      Revised TclOO's check for an interp  
       being deleted during handling of object command deletion.  The        
 old code was relying on documented features of command delete         traces
 that do not in fact work.  [Bug 2039178].

        * tests/oo.test (oo-26.*):      Added tests that demonstrate
        failure of TclOO to check for various kinds of invalid bytecode
        during method dispatch.  [Bug 2037727].
---
 ChangeLog       | 11 +++++++++++
 generic/tclOO.c |  4 ++--
 tests/oo.test   | 30 +++++++++++++++++++++++++++++-
 3 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b6b2194..f97328a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2008-08-04  Don Porter  <dgp@users.sourceforge.net>S
+
+	* generic/tclOO.c:	Revised TclOO's check for an interp
+	being deleted during handling of object command deletion.  The
+	old code was relying on documented features of command delete
+	traces that do not in fact work.  [Bug 2039178].
+
+	* tests/oo.test (oo-26.*):	Added tests that demonstrate
+	failure of TclOO to check for various kinds of invalid bytecode
+	during method dispatch.  [Bug 2037727].
+
 2008-08-06  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclVar.c (TclLookupSimpleVar): fix bug that the core
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6f078e4..4db39c3 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.13 2008/07/18 23:29:44 msofer Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.14 2008/08/06 21:23:14 dgp Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -562,7 +562,7 @@ ObjectRenamedTrace(
 
     AddRef(oPtr);
     oPtr->flags |= OBJECT_DELETED;
-    if (!(flags & TCL_INTERP_DESTROYED)) {
+    if (!Tcl_InterpDeleted(interp)) {
 	CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
 
 	if (contextPtr != NULL) {
diff --git a/tests/oo.test b/tests/oo.test
index 8ff06e8..ea97bf2 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.9 2008/07/25 22:11:21 andreas_kupries Exp $
+# RCS: @(#) $Id: oo.test,v 1.10 2008/08/06 21:23:15 dgp Exp $
 
 package require TclOO 0.4 ;# Must match value in configure.in
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1787,6 +1787,34 @@ test oo-25.1 {call chain caching} -setup {
     lappend result [foo $m1] [bar $m2]
 } -result {ok ok ok ok ok ok good ok}
 
+test oo-26.1 {Bug 2037727} -setup {
+    proc succeed args {}
+    oo::object create example
+} -body {
+    oo::objdefine example method foo {} {succeed}
+    example foo
+    proc succeed {} {return succeed}
+    example foo
+} -cleanup {
+    example destroy
+    rename succeed {}
+} -result succeed
+
+test oo-26.2 {Bug 2037727} -setup {
+    oo::class create example {
+	method namespace {} {self namespace}
+	method foo {} {succeed}
+    }
+    example create i1
+    example create i2
+    namespace eval [i1 namespace] {proc succeed args {}}
+    namespace eval [i2 namespace] {proc succeed args {return succeed}}
+} -body {
+    list [i1 foo] [i2 foo]
+} -cleanup {
+    example destroy
+} -result {{} succeed}
+
 cleanupTests
 return
 
-- 
cgit v0.12