From 0dde2f0c154556f8f812078b8eb894e2d248974e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 24 Mar 2009 10:46:03 +0000
Subject: Fix [Bug 2704302]

---
 ChangeLog            |  3 +++
 doc/self.n           |  9 +++++----
 generic/tclOOBasic.c | 19 +++++--------------
 tests/oo.test        | 27 ++++++++++++++++++++++++++-
 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
-- 
cgit v0.12