[GPS]: I like playing with new interfaces and object systems.  This package sort of evolved from several ideas I had.  It's simple, fast, and unique. 

Use this code however you like, but I would like to know how you use it, so leave a comment or email me[mailto:GeorgePS@XMission.com].

----
'''UPDATED''' April 8, 2003 with an almost complete rewrite and now a demo widget.  I'm now using SDynObject successfully with several projects.  I updated a few comments above too. 

''[escargo]'' - If you did not execute the source command unless the package SDynObject was not
known, wouldn't this page then be ''reapable'' (that is, would not the whole body of code defined
on this page run and do what was intended)?  I do note that the first part of the code does a
'''package provide''', but the second part does a '''source''' and not '''package require'''.
----

 package provide SDynObject 1.0
 
 #BEGIN OBJECT SYSTEM - SDynObject
 proc sd.get.unique.id {} {
   while 1 {
     set id [clock clicks]
     if {"" == [info commands $id]} {
       return $id
     }
   }
 }
 
 proc sd.new.object {} {
   set id [sd.get.unique.id]
   interp alias {} $id {} __sd.instance $id
   return $id
 }
 
 proc __sd.instance {id args} {
   upvar #0 _obj$id ar
   set al [llength $args]
   if {1 == $al} {
     set mem [lindex $args 0]
     if {![info exists ar($mem)]} {
       return -code error "no member named $meth in $id"
     }
     return [set ar($mem)]
   } elseif {2 == $al} {
     foreach {mem value} $args break
     set ar($mem) $value
   } else {
     return -code error "bad number of arguments sent to $id; $args"
   }
 }
 
 proc sd.call {meth _ id args} {
   upvar #0 _obj$id ar
 
   if {![info exists ar($meth)]} {
     return -code error "no method named $meth in $id"
   }
   namespace eval :: [set ar($meth)] $args
 }
 
 proc sd.new.method {name _ id _ takes body} {
   upvar #0 _obj$id ar
   set methodId [sd.get.unique.id]
   proc ::$methodId $takes "set self $id\n$body"
   set ar($name) $methodId
 
   if {![info exists ::_obj[set id](__methodList)]} {
     set ar(__methodList) [list]
   }
 
   lappend ar(__methodList) $methodId
   
   return $methodId
 }
 
 proc sd.dereference {id mem} {
   return "::_obj[set id]($mem)"
 }
 
 proc sd.dereference.cmd {id cmd} {
   return [set ::_obj[set id]($cmd)]
 }
 
 proc sd.destroy.object {id} {
   upvar #0 _obj$id ar
 
   foreach method $ar(__methodList) {
     catch {rename $method {}}
   }
   array unset ar
 }
 
----
'''DEMO'''

 source ./SDynObject.tcl
 
 proc box {win args} {
   set b [sd.new.object]
   $b size 200
   $b color royalblue
   $b delay 20 
   $b busy 0
 
   frame $win -class Box -bg [$b color] \
   -width [$b size] -height [$b size]  
   
   $b win $win
 
   sd.new.method fade.to.black for $b takes {win r g b} {
     if {$r < 1 || $g < 1 || $b < 1} {
       $win configure -bg [$self color]
       $self busy 0
       return
     }
     set col [format {#%2.2x%2.2x%2.2x} $r $g $b]
     $win config -bg $col
 
     incr r -1
     incr g -1
     incr b -1
 
     after [$self delay] [list sd.call fade.to.black in $self $win $r $g $b]
   }
 
   sd.new.method begin.fading for $b takes {win r g b} {
     if {[$self busy]} {
       #already running
       return
     }
 
     $self busy 1
     sd.call fade.to.black in $self $win $r $g $b
   }
 
 
   set fadeCmd [list [sd.dereference.cmd $b begin.fading] $win 255 255 255]
 
   bind $win <Expose> $fadeCmd
   bind $win <ButtonPress-1> $fadeCmd 
   
   return $win
 }
 
 pack [box .b] -fill both -expand 1
----
[Category Object Orientation] |
[Category Package] |