From bf722c6315c4ee0b75907cb81d40c7d7a68bc938 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 12 Feb 2009 09:27:43 +0000
Subject: Fix tricky point that meant it was next to impossible to extend
 [oo::define].

---
 ChangeLog                 |  7 +++++++
 generic/tclOODefineCmds.c |  8 ++++----
 tests/oo.test             | 21 ++++++++++++++++++++-
 3 files changed, 31 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index cb2db93..3bbfd36 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2009-02-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOODefineCmds.c (TclOOGetDefineCmdContext): Use the
+	correct field in the Interp structure for retrieving the frame to get
+	the context object so that people can extend [oo::define] without deep
+	shenanigans. Bug found by Federico Ferri.
+
 2009-02-11  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclStringObj.c:	Re-implemented AppendUnicodeToUtfRep
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index ac65ee4..b732eec 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.9 2009/01/27 11:11:47 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.10 2009/02/12 09:27:43 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -594,14 +594,14 @@ TclOOGetDefineCmdContext(
 {
     Interp *iPtr = (Interp *) interp;
 
-    if ((iPtr->framePtr == NULL)
-	    || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+    if ((iPtr->varFramePtr == NULL)
+	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
 	Tcl_AppendResult(interp, "this command may only be called from within"
 		" the context of an ::oo::define or ::oo::objdefine command",
 		NULL);
 	return NULL;
     }
-    return (Tcl_Object) iPtr->framePtr->clientData;
+    return (Tcl_Object) iPtr->varFramePtr->clientData;
 }
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index e0b07b2..1f5573b 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.22 2009/01/29 15:57:54 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.23 2009/02/12 09:27:44 dkf Exp $
 
 package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -2164,6 +2164,25 @@ test oo-27.11 {variables declaration - no instance var leaks with class resolver
     inst1 step
     list [inst1 value] [inst2 value]
 } -result {3 2}
+
+# A feature that's not supported because the mechanism may change without
+# warning, but is supposed to work...
+test oo-28.1 {scripted extensions to oo::define} -setup {
+    interp create foo
+    foo eval {oo::class create cls {export eval}}
+} -cleanup {
+    interp delete foo
+} -body {
+    foo eval {
+	proc oo::define::privateMethod {name arguments body} {
+	    uplevel 1 [list method $name $arguments $body]
+	    uplevel 1 [list unexport $name]
+	}
+	oo::define cls privateMethod m {x y} {return $x,$y}
+	cls create obj
+	list [catch {obj m 1 2}] [obj eval my m 3 4]
+    }
+} -result {1 3,4}
 
 cleanupTests
 return
-- 
cgit v0.12