Updated 2012-01-20 13:31:22 by dkf

This is a general events mechanism. It uses metaprogramming to speed things up.

Simple example edit

 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 event1

Result:
 EVENT1-before
 EVENT1-after
 EVENT1-final
 EVENT2
 Some string
 EVENT1-before
 EVENT1-final

The code edit

 # 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.0

NEM 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.

AM (7 june 2006) The event command is not available in pure Tcl, only in Tk. As Tk events are associated with widgets, an application that wants to use "events" as a means to drive a simulation can not use that mechanism, but the above package is a solution. You may also look at today's chatroom logs - I initiated the discussion.

NEM: OK, although the above is not really a replacement for event, but nearer to something like trace -- an implementation of the observer design pattern.