From e0064189465e2ea63ca9e2dd531928a14c968f52 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 18 Oct 2018 14:58:28 +0000
Subject: Tests for advanced object mutation issues.

---
 generic/tclOODefineCmds.c | 22 +++++++++++++-
 tests/oo.test             | 77 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 98 insertions(+), 1 deletion(-)

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index c924d2b..f5fe676 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -1083,6 +1083,8 @@ TclOODefineClassObjCmd(
 {
     Object *oPtr;
     Class *clsPtr;
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    int wasClass, willBeClass;
 
     /*
      * Parse the context to get the object to operate on.
@@ -1118,12 +1120,20 @@ TclOODefineClassObjCmd(
     if (clsPtr == NULL) {
 	return TCL_ERROR;
     }
-
+    if (oPtr == clsPtr->thisPtr) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"may not change classes into an instance of themselves", -1));
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    }
 
     /*
      * Set the object's class.
      */
 
+    wasClass = (oPtr->classPtr != NULL);
+    willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr));
+
     if (oPtr->selfCls != clsPtr) {
 	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
 	TclOODecrRefCount(oPtr->selfCls->thisPtr);
@@ -1131,6 +1141,16 @@ TclOODefineClassObjCmd(
 	AddRef(oPtr->selfCls->thisPtr);
 	TclOOAddToInstances(oPtr, oPtr->selfCls);
 
+	/*
+	 * Create or delete the class guts if necessary.
+	 */
+
+	if (wasClass && !willBeClass) {
+	    /* TODO: DELETE THE STRUCTURE */
+	} else if (!wasClass && willBeClass) {
+	    /* TODO: CREATE THE STRUCTURE */
+	}
+
 	if (oPtr->classPtr != NULL) {
 	    BumpGlobalEpoch(interp, oPtr->classPtr);
 	} else {
diff --git a/tests/oo.test b/tests/oo.test
index 024f890..7f0de4a 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1804,6 +1804,83 @@ test oo-13.4 {OO: changing an object's class} -body {
     foo destroy
     bar destroy
 } -result {::foo ::foo ::foo ::bar}
+test oo-13.5 {OO: changing an object's class} -setup {
+    oo::object create fooObj
+} -body {
+    oo::objdefine fooObj {
+	class oo::class
+    }
+    oo::define fooObj {
+	method x {} {expr 1+2+3}
+    }
+    [fooObj new] x
+} -cleanup {
+    fooObj destroy
+} -result 6
+test oo-13.6 {OO: changing an object's class} -setup {
+    oo::class create foo
+} -body {
+    oo::define foo {
+	method x {} {expr 1+2+3}
+    }
+    foo create bar
+    oo::objdefine foo {
+	class oo::object
+    }
+    list [catch {bar x} msg] $msg
+} -cleanup {
+    catch {bar destroy}
+    foo destroy
+} -result {1 {}}
+test oo-13.7 {OO: changing an object's class} -setup {
+    oo::class create foo
+    oo::class create bar
+    unset -nocomplain result
+} -body {
+    oo::define bar method x {} {return ok}
+    oo::define foo {
+	method x {} {expr 1+2+3}
+	self mixin foo
+    }
+    lappend result [foo x]
+    oo::objdefine foo class bar
+    lappend result [foo x]
+} -cleanup {
+    foo destroy
+    bar destroy
+} -result {6 ok}
+test oo-13.7 {OO: changing an object's class to itself} -setup {
+    oo::class create foo
+} -body {
+    oo::define foo {
+	method x {} {expr 1+2+3}
+    }
+    oo::objdefine foo class foo
+} -cleanup {
+    foo destroy
+} -returnCodes error -result {may not change classes into an instance of themselves}
+test oo-13.9 {OO: changing an object's class: roots are special} -setup {
+    set i [interp create]
+} -body {
+    $i eval {
+	oo::objdefine oo::object {
+	    class oo::class
+	}
+    }
+} -cleanup {
+    interp delete $i
+} -returnCodes error -result {may not modify the class of the root object class}
+test oo-13.10 {OO: changing an object's class: roots are special} -setup {
+    set i [interp create]
+} -body {
+    $i eval {
+	oo::objdefine oo::class {
+	    class oo::object
+	}
+    }
+} -cleanup {
+    interp delete $i
+} -returnCodes error -result {may not modify the class of the class of classes}
 # todo: changing a class subtype (metaclass) to another class subtype
 
 test oo-14.1 {OO: mixins} {
-- 
cgit v0.12