summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-03-24 10:46:03 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-03-24 10:46:03 (GMT)
commit0dde2f0c154556f8f812078b8eb894e2d248974e (patch)
treef2cdaf7eb9bc628eb19e39845f3b0692bb49b4fd
parent08383aee88a03fe8cc880c10b9fc242fe3804ebd (diff)
downloadtcl-0dde2f0c154556f8f812078b8eb894e2d248974e.zip
tcl-0dde2f0c154556f8f812078b8eb894e2d248974e.tar.gz
tcl-0dde2f0c154556f8f812078b8eb894e2d248974e.tar.bz2
Fix [Bug 2704302]
-rw-r--r--ChangeLog3
-rw-r--r--doc/self.n9
-rw-r--r--generic/tclOOBasic.c19
-rw-r--r--tests/oo.test27
4 files changed, 39 insertions, 19 deletions
diff --git a/ChangeLog b/ChangeLog
index c857492..0422af5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2009-03-24 Donal K. Fellows <dkf@users.sf.net>
+ * generic/tclOOBasic.c (TclOOSelfObjCmd): [Bug 2704302]: Make 'self
+ class' better defined in the context of objects that change class.
+
* generic/tclVar.c (Tcl_UpvarObjCmd): [Bug 2673163] (ferrieux)
* generic/tclProc.c (TclObjGetFrame): Make the upvar command more able
to handle its officially documented syntax.
diff --git a/doc/self.n b/doc/self.n
index 7e564b7..a82be96 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: self.n,v 1.2 2008/10/17 10:22:25 dkf Exp $
+'\" RCS: @(#) $Id: self.n,v 1.3 2009/03/24 10:46:04 dkf Exp $
'\"
.so man.macros
.TH self n 0.1 TclOO "TclOO Commands"
@@ -39,9 +39,10 @@ destructors respectively).
.TP
\fBself class\fR
.
-This returns the name of the class or object that the current method was
-defined within. Note that this will change as the chain of method
-implementations is traversed with \fBnext\fR.
+This returns the name of the class that the current method was defined within.
+Note that this will change as the chain of method implementations is traversed
+with \fBnext\fR, and that if the method was defined on an object then this
+will fail.
.TP
\fBself filter\fR
.
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 8be8773..f70d4f9 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.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: tclOOBasic.c,v 1.17 2009/02/10 22:49:55 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.18 2009/03/24 10:46:04 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -740,23 +740,14 @@ TclOOSelfObjCmd(
contextPtr->oPtr->namespacePtr->fullName,-1));
return TCL_OK;
case SELF_CLASS: {
- Method *mPtr = CurrentlyInvoked(contextPtr).mPtr;
- Object *declarerPtr;
+ Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
- if (mPtr->declaringClassPtr != NULL) {
- declarerPtr = mPtr->declaringClassPtr->thisPtr;
- } else if (mPtr->declaringObjectPtr != NULL) {
- declarerPtr = mPtr->declaringObjectPtr;
- } else {
- /*
- * This should be unreachable code.
- */
-
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ if (clsPtr == NULL) {
+ Tcl_AppendResult(interp, "method not defined by a class", NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclOOObjectName(interp, declarerPtr));
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
return TCL_OK;
}
case SELF_METHOD:
diff --git a/tests/oo.test b/tests/oo.test
index 1f5573b..6c3187b 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.23 2009/02/12 09:27:44 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.24 2009/03/24 10:46:04 dkf Exp $
package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -979,6 +979,20 @@ test oo-13.3 {OO: changing an object's class} -body {
} -cleanup {
foo destroy
} -returnCodes 1 -result {may not change a class object into a non-class object}
+test oo-13.4 {OO: changing an object's class} -body {
+ oo::class create foo {
+ method m {} {
+ set result [list [self class] [info object class [self]]]
+ oo::objdefine [self] class ::bar
+ lappend result [self class] [info object class [self]]
+ }
+ }
+ oo::class create bar
+ [foo new] m
+} -cleanup {
+ foo destroy
+ bar destroy
+} -result {::foo ::foo ::foo ::bar}
# todo: changing a class subtype (metaclass) to another class subtype
test oo-14.1 {OO: mixins} {
@@ -2183,6 +2197,17 @@ test oo-28.1 {scripted extensions to oo::define} -setup {
list [catch {obj m 1 2}] [obj eval my m 3 4]
}
} -result {1 3,4}
+
+test oo-29.1 {self class with object-defined methods} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj method demo {} {
+ self class
+ }
+ obj demo
+} -returnCodes error -cleanup {
+ obj destroy
+} -result {method not defined by a class}
cleanupTests
return