diff options
| -rw-r--r-- | generic/tclOODefineCmds.c | 22 | ||||
| -rw-r--r-- | tests/oo.test | 77 |
2 files changed, 98 insertions, 1 deletions
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} { |