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.

if 0 {
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 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
   }
}
}