diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 8 | ||||
| -rw-r--r-- | tests/oo.test | 21 |
3 files changed, 31 insertions, 5 deletions
@@ -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 |