'''Update:'''  The latest SDynObject is now available (with demos) from: http://www.xmission.com/~georgeps/SDynObject/  I've released it under a Tcl-like license. 

----
[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'''.

[GPS] - I used source because otherwise a pkgIndex would need to be generated, and the auto_path would need to be changed.  The package provide is there to make it easier for users to use it in a package require manner.

''[escargo]'' - My main point was my first one, which you did not address.
If the '''source''' were ''conditional'', then all the code on the page could be extracted
''in a single file'' and executed, producing a runnable demo in a single file.
That would make it more convenient for your prospective users.

''[GPS]'' - I see what you're saying.  When I update SDynObject I'll cat the files together after I've run them through wikify.tcl and then paste them here.

----
'''Planned Changes'''

 (bool) sd.object.has.method methodName
 (bool) sd.copy.method methodName in obj1 to obj2 
 (list) sd.get.method.list obj
 (bool) sd.copy.all.methods in obj1 to obj2
----

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