This is a general events mechanism. It uses metaprogramming to speed things up.
Simple example:
zevents::bind Something event1 10 {puts EVENT1-before}
zevents::bind Something event1 -10 {puts EVENT1-final}
zevents::bind Something event1 0 {puts EVENT1-after}
zevents::bind Something event2 0 {puts EVENT2}
zevents::bind Something puts 0 {puts}
zevents::call Something event1
zevents::call Something event2
zevents::call Something puts "Some string"
zevents::unbind Something event1 {puts EVENT1-after}
zevents::call Something event1Result:
EVENT1-before EVENT1-after EVENT1-final EVENT2 Some string EVENT1-before EVENT1-final
The code:
# zevents --
#
# Package for handling events
#
namespace eval zevents {}
# zevents::settags --
#
# Sets the tags (names) that should be executed when this tag (name)
# is to be executed.
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
# tags A list of tags (names) to be called
#
# Results:
# None
proc zevents::settags {collection name taglist} {
variable syncTags
set fn ${collection}::::${name}
set syncTags($fn) $taglist
updatedEvent $fn
}
# zevents::gettags --
#
# Gets the tags (names) that should be executed when this tag (name)
# is to be executed.
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
#
# Results:
# A list of tags (names) to be called
#
# Side Effects:
# None
#
proc zevents::gettags {collection name} {
variable syncTags
set fn ${collection}::::${name}
recreateEvent $name $fn
return $syncTags($fn)
}
# zevents::bind --
#
# Binds a command to a certain event. The command will get executed
# once an event is called.
#
# NOTE: It only allows binding a command once.
# NOTE: There is no reliable ordering of commands with same priority
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
# priority Priority at which to register the command
# command A command to be executed (lists of arguments allowed)
#
# Results:
# None
#
# Side Effects:
# None
#
proc zevents::bind {collection name priority command} {
variable syncCallback
set fn ${collection}::::${name}
lappend syncCallback($fn) [list $priority $command]
updatedEvent $fn
}
# zevents::unbind --
#
# Unbinds a command to a certain event. The command will no longer get
# executed once an event is called.
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
# command A command to be removed from being executed
#
# Results:
# None
#
# Side Effects:
# None
#
proc zevents::unbind {collection name command} {
variable syncCallback
set fn ${collection}::::${name}
# if we haven't created any bindings for this event, then just leave
if {![info exists syncCallback($fn)]} {
return
}
# make a copy of the list only with other commands
set oldlist $syncCallback($fn); set newlist [list]
foreach e $oldlist {
if {![string equal [lindex $e 1] $command]} {
lappend newlist $e
}
}
# this prevents errors from dropping an entire list
set syncCallback($fn) $newlist
updatedEvent $fn
return ""
}
# zevents::init --
#
# Initialize an event - clean up event lists.
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
#
# Results:
# None
#
# Side Effects:
# None
#
proc zevents::init {collection name} {
variable syncCallback
set fn ${collection}::::${name}
set syncCallback($fn) [list]
updatedEvent $fn
return ""
}
# zevents::call --
#
# Call an event and pass the arguments to it
#
# Arguments:
# collection Name of the collection which the event is in
# name The name of the event to call
# args A list of all arguments appended to the listeners
#
# Results:
# None
#
# Side Effects:
# One or more background errors may be thrown
#
proc zevents::call {collection name args} {
zevents::call0 $collection $name $args
}
# same as above, but using one argument as a list of arguments (varargs)
proc zevents::call0 {collection name ar} {
variable syncBody
variable syncTags
set fn ${collection}::::${name}
# optionally update the sync body
recreateEvent $name $fn
# eval the most recent syncBody in the current interpreter
# (not using [eval] since it would not bytecompile the code)
foreach tag $syncTags($fn) {
set fn ${collection}::::${tag}
recreateEvent $tag $fn
interp eval {} $syncBody($fn)
}
}
#
# internal functions
#
# sets that an event definition has been updated and needs to be recreated ASAP
proc zevents::updatedEvent {fn} {
variable syncEvent
# unset that the event has been synchronized
if {[info exists syncEvent($fn)]} {
unset syncEvent($fn)
}
}
# recreate event internal storage
proc zevents::recreateEvent {name fn} {
variable syncEvent
variable syncTags
variable syncCallback
variable syncBody
# only sync if it hasn't been synchronized
if {[info exists syncEvent($fn)]} {
return
}
if {![info exists syncTags($fn)]} {
set syncTags($fn) [list $name]
}
if {![info exists syncCallback($fn)]} {
set syncCallback($fn) [list]
}
set syncCallback($fn) [lsort -index 0 -integer -decreasing \
[lsort -unique -index 1 $syncCallback($fn)]]
set b ""
# create a static body to call on each invocation
foreach cmd $syncCallback($fn) {
set cmd [lindex $cmd 1]
set body ""
append body "set c \[catch \[list uplevel #0 \[concat [list $cmd] \$ar\]\] rc\]" \n
append body "switch -- \$c \{" \n
# 0 - ok; 4 - continue -- continue executing
# 2 - return; 3 - break --
append body " 2 - 3 \{" \n
append body " return \"\"" \n
append body " \}" \n
# 1 - error - throw an error using bgerror in a catch; try to resume executing the bindings
append body " 1 \{" \n
append body " set ei \$::errorInfo" \n
# if we can't call [bgerror], at least print out the errors to stderr
append body " if \{\[catch \{bgerror \$rc\}\]\} \{ puts stderr \$ei \}" \n
append body " \}" \n
append body "\}" \n
append b $body
}
set syncBody($fn) $b
set syncEvent($fn) 1
}
package provide zevents 1.0NEM 7 June 2006: Could you give some explanation of what problem this package solves, and how it differs from Tcl's built-in event loop?
Also, in the call procedure, the call to call0 is redundant - all it does is essentially change the name of "args" to "ar". This variable is then not even used in the body. I also imagine that interp eval and eval behave the same in terms of not byte-compiling the body.