[MJ] - Will add some documentation here. One disadvantage of dragging around a class for every object, is that it is more expensive to clone objects (a class also will be created). Also a provision to send a message to receiver but start method lookup on its parents is missing (super in self). ====== package require TclOO namespace import ::oo::* namespace eval self { namespace export Object namespace eval _ { proc create_prototype {name parent} { # doesn't work: # class create ::self::cl::$name [list mixin $parent] # I really want to use mixins here. Now a destroy of a parent destroys all its children class create ::self::cl::$name [list superclass $parent] ::oo::define ::self::cl::$name destructor { [self class] destroy } set res [namespace eval :: [list ::self::cl::$name create $name]] $res parents*: [string map [list ::self::cl {}] $parent] ::oo::define ::self::cl::$name method parents* {} { set res {} foreach class [oo::InfoClass superclasses [oo::InfoObject class [self]] ] { if {$class eq "::oo::object"} {return {}} lappend res [string map [list ::self::cl {}] $class] } return [lsort $res] } ::oo::define ::self::cl::$name method parents*: {args} { set classnames {} foreach parent $args { lappend classnames ::self::cl::$parent } ::oo::define [oo::InfoObject class [self]] superclass {*}$classnames } return $res } } } class create ::self::cl::Object { method clone name { ::self::_::create_prototype $name [oo::InfoObject class [self]] } method destroy {} { foreach subclass [::oo::InfoClass subclasses [::oo::InfoObject class [self]]] { set current [oo::InfoClass superclasses $subclass] set new [lsearch -inline -all -not $current [::oo::InfoObject class [self]]] # prevent orphans if {$new eq {}} { set new ::self::cl::Object } ::oo::define $subclass superclass $new } next } method slot {name args} { if {[llength $args]==1} { ::oo::define [oo::InfoObject class [self]] method $name {} [list return [lindex $args 0]] set body "\[self\] slot [list $name] \$val" ::oo::define [oo::InfoObject class [self]] method $name: {val} $body } else { ::oo::define [oo::InfoObject class [self]] method $name [lindex $args 0] [lindex $args 1] } } method parents* {} { set res {} foreach class [oo::InfoClass superclasses [oo::InfoObject class [self]] ] { if {$class eq "::oo::object"} {return {}} lappend res [string map [list ::self::cl {}] $class] } return [lsort $res] } method parents*: {args} { set classnames {} foreach parent $args { lappend classnames ::self::cl::$parent } ::oo::define [oo::InfoObject class [self]] superclass {*}$classnames } method slots {} { oo::InfoClass methods [oo::InfoObject class [self]] } } ::self::cl::Object create ::self::Object namespace import ::self::Object package provide self 0.6 if {$argv0 eq [info script]} { puts "#### Examples ####" Object clone test test slot test {} {puts "test slot in [self]"} test slot nop {} {#} test test puts "test slots: [test slots]" test destroy puts "#### Point demo ####" Object clone Point # add a to_s slot to display information of the object Object slot to_s {} { return "[self]" } # add x and y slots for the point, notice that these slots give an error when called. Point slot x {args} {error "abstract slot, override in clone"} Point slot y {args} {error "abstract slot, override in clone"} # extend default behavior from parent (Object) Point slot to_s {} { return "id: [next] ([my x],[my y])" # Here next will search for a slot named to_s in the parents of the implementor of the current method (Point) # finding the Object slot to_s and the execute it in the context of the receiver (which will be a clone of Point) } # define a point factory Point slot create {name x y} { my clone $name $name slot x $x $name slot y $y return $name } # clone a Point Point clone p1 # to_s will fail because the x and y slots in Point are called which were defined as abstract catch {p1 to_s} err puts $err p1 destroy # use the Point factory which will define x and y slots Point create p1 0 0 # to_s will now work puts [p1 to_s] p1 x: 12 puts [p1 to_s] # some debugging aids Point clone DPoint DPoint slot to_s {} { puts "calling to_s" next } # make p1 use the debugging version of Point p1 parents* DPoint puts [p1 to_s] puts "parents* of p1: [p1 parents*]" puts "parents* of Point: [Point parents*]" puts "parents* of Object: [Object parents*]" puts "##### Benchmarks #####" puts "clone/destroy: [time {Object clone a ; a destroy} 1000]" Object clone test0 test0 slot nop {} {#} for {set i 0} {$i < 999} {} { test$i clone test[incr i] } puts "nested slot dispatch 999 deep: [time {test999 nop} 1000]" } ====== ---- [MJ] - It seems that with clever use of mixins the same can be achieved with much less effort (first demonstrated by [dkf] on the Tcl [chat]) ====== package require TclOO namespace eval self { namespace export Object oo::class create Object { superclass ::oo::class self mixin ::self::Object method clone {name} { set o [my new [list superclass [self]]] ::oo::objdefine $o mixin $o uplevel 1 [list rename $o $name]\;[list namespace which $name] } method slot {name arguments body} { oo::define [self] method $name $arguments $body } method parents {} { return [info class superclasses [self]] } method parents! {parents} { ::oo::define [self] superclass {*}$parents } unexport create new self unexport create new } } ====== [DKF]: It's based on an example in the TclOO test suite, and that in turn is based on something I saw someone do with [XOTcl]. ---- See also [tclOO], [self - TclOO%|%self] <> Example | Object Orientation