summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclOODefineCmds.c8
-rw-r--r--tests/oo.test21
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