simpleOO

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
   }
 }

Category Object Orientation