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