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[L1 ].
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.
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 {]} {
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