I came up with this while on vacation, needing a really simple OO system for a growing app at work. Basically it's a wrapper around 'namespace'(object) and 'proc'(method). Methods have their name munged to identify them as such, and are provided an instance data namespace-variable "idata" automagically. There is, as of yet, no method for automatic garbage collection. Just like the Microsoft OO system I cribbed the structure from, you need to ->AddRef and ->Release objects manually, and when the reference count drops to zero, the object destroys itself. For an actual real use of simpleOO, check out Sudoku Solver
package provide simpleOO 0.3
namespace eval ClassFactory {
namespace export new object
###
# Request a new instance of object $cname
# with optional configuration in $args
###
proc new {cname args} {
set iname [uid $cname]
interp alias {} $iname-> {} ::${cname}::dispatch $iname
interp alias {} $iname {} ::${cname}::dispatch $iname
eval $iname Create $args
return $iname
}
###
# Define a new class/object
###
proc object {name body} {
set preCmd {
proc _Identify {this} {return %cname}
proc _isa {this class} {
upvar #0 ::%cname::cdata cdata
if {"%cname"==$class} {return 1}
if {[info exists cdata(inherits)]} {
::$cdata(inherits)::_isa $this $class
} {
return 0
}
}
proc inherits {name} {
::ClassFactory::inherit %cname $name
}
proc method {cmd args body} {
::ClassFactory::method %cname $cmd $args $body
}
proc destroy {name} {
::ClassFactory::destroy %cname $name
}
proc dispatch {this cmd args} {
eval ::ClassFactory::dispatch %cname $this $cmd $args
}
}
regsub -all {%cname} $preCmd $name preCmd
set body "$preCmd ; $body"
namespace eval ::$name $body
}
###
# inherit,method,destroy must be called only within an 'object' block
###
proc inherit {child parent} {
set ::${child}::cdata(inherits) $parent
}
proc method {cname cmd args body} {
set args [linsert $args 0 this]
set preCmd {
upvar #0 ::%cname::cdata cdata ; upvar #0 ::%cname::$this idata
}
regsub -all {%cname} $preCmd $cname preCmd
set body "$preCmd ; $body"
uplevel 1 proc _$cmd $args [list $body]
uplevel 1 namespace export _$cmd
}
proc destroy {cname iname} {
interp alias {} $iname-> {}
interp alias {} $iname {}
unset ::${cname}::$iname
}
###
# wrapper for interp-alias, do not bare-call
###
proc dispatch {cname iname cmd args} {
if {[llength [info commands ::${cname}::_$cmd]]!=1} {
upvar #0 ::${cname}::cdata cdata
if {[info exists cdata(inherits)]} {
set cname $cdata(inherits)
eval dispatch $cname $iname $cmd $args
} else {
error "Method $cmd is undefined in $cname."
}
} else {
eval "::${cname}::_$cmd $iname $args"
}
}
proc uid {cname} {
set i 0
while {1} {
if {[interp alias {} ${cname}$i]=={}} {break}
incr i
}
return ${cname}$i
}
}
namespace import ::ClassFactory::*
###
# IUnknown: Both sample code, AND a mandatory inherit for all objects
###
object IUnknown {
method AddRef {} {
incr idata(refCount)
}
method Release {} {
incr idata(refCount) -1
if {$idata(refCount)<=0} {
$this Destroy
return 0
} else {
return $idata(refCount)
}
}
method Create {} {
set idata(refCount) 0
}
method Destroy {} {
destroy $this
}
}