Updated 2016-04-03 22:23:27 by pooryorick ▲

Page maintainer: Marco Maggi

Changes  edit

pyk 2016-04-03
Changed after 0 to use the after 0 ... after idle idiom, which I think would result in more orderly event processing in this system.

Description  edit

In Tk, event allows us to declare and generate events that can trigger procedure invocations in the same way as GUI interaction and file events do. Tcl doesn't come with an event command, but we can mimic one with few lines of code.

We'll use an array to map event names to registered scripts, so first we need to obtain a unique fully qualified name.
namespace eval ::tcl::tmp {
    variable global_counter 0

    proc unique_name {} {
        variable global_counter
        set pattern [namespace current]::%s

        set name [format $pattern [incr global_counter]]
        while {
            [info exists $name] ||
            [namespace exists $name] ||
            [llength [info commands $name]]
        } {
            set name [format $pattern [incr global_counter]]
        }
        return $name
    }
}

Now we can declare a namespace for our little package, but it's not strictly required.
namespace eval event {
    namespace export event_declare event_bind \
        event_generate event_forgetevent_detach
}

We need a procedure to declare a new event: we could declare new events and bind them to script directly, but it's better to split the declaration from the first usage to avoid typos problems.
proc event::event_declare {this event} {
    upvar $this map

    if {[string length $event]} {
        set map($event) -1
        set map($event:list) {}
    } else {
        return -code error -errorcode {LOGIC INVALID_ARGUMENT} \
            {null event identifier}
    }
    return
}

We could declare a list of events with a single invocation of event_declare changing the "prototype" to:
proc event::event_declare {this event args}

but we save the "args" parameter for a future implementation of event specific properties.

Now we can bind events to scripts:
proc event::event_bind {this event script {idvar {}}} {
    upvar $this map
    if {[string length $idvar]} {upvar $idvar id}

    if {![info exists map($event)]} {
        return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown event "%s"} $event]
    }

    set id [incr map($event)]
    set map($event:$id) $script
    lappend map($event:list) $id
    return $id
}

the scripts are stored the array and a unique identifier is generated so that later we can use it to detach the script.

There are two equivalent ways to invoke this procedure:
set id [event_bind $this <uno> {puts uno}]
event_bind $this <uno> {
    puts uno
} id

the second form uses the optional variable argument, and it's more readable.

To generate events:
proc event::event_generate { this event } {
    upvar $this map

    if {[info exists map($event)]} {
        foreach id $map($event:list) {
            after 0 [list after idle [namespace code [
                list _event_eval $map($event:$id)]]]
        }
        return
    } else {
        return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown event "%s"} $event]
    }
}

foreach queues the scripts in the event loop, in the same order in which they were registered.

We may want to remove one or more event declarations and all the associated scripts:
proc UTP::event_forget {this event args} {
    upvar $this map

    foreach key [array names map $event*] {unset map($key)}
    foreach event $args {
        foreach key [array names map $event*] {unset map($key)}
    }
    return
}

we can use the -nocomplain option to unset if we don't care to invoke this procedure with an non-existent event name.

To detach a single script from an event:
proc UTP::event_detach {this event id} {
    upvar $this map

    if {![info exists map($event)]} {
        return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown event "%s"} $event]
    }
    if {![info exists map($event:$id)]} {
        return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown script identifier "%s" for event "%s"} \
                $id $event]
    }

    unset map($event:$id)
    set idx [lsearch -sorted $map($event:list) $id]
    set map($event:list) [lreplace $map($event:list) $idx $idx]
    return
}

Here is the simple procedure that evaluates the after 0 ... scripts. Scripts must be evaluated in the global namespace.
proc event::_event_eval {script args} {
    uplevel #0 $script
}

Changing it we can add control to turn on/off script evaluation, although this doesn't seem so useful. More useful is the possibility to preprocess $script with subst or string map to allow the substitution of special symbols, like TK does.

What's a package without a test suite? Here we go (it's loooong maybe it's better if I remove it):
package require Tcl 8.4
package require tcltest 2.2

source ... ;# source the file here

namespace eval test {
    namespace import ::event::event_*

    variable        forever 0


::tcltest::test event-1.1 \
        "\[event_declare\] error: null identifier" {
    -setup        {
        set this [::UTP::unique_name]
    }
    -body        {
        catch {event_declare $this {}} res
        set res
    }
    -result "null event identifier"
    -cleanup        {
        unset -nocomplain $this this res
    }
}

::tcltest::test event-1.2 \
        "\[event_bind\] error: unkwnown identifier" {
    -setup        {
        set this [::UTP::unique_name]
    }
    -body        {
        event_declare $this <uno>
        catch {event_bind $this <due> {}} res
        set res
    }
    -result "unknown event \"<due>\""
    -cleanup        {
        unset -nocomplain $this this res
    }
}

::tcltest::test event-1.3 \
        "\[event_generate\] error: unkwnown event" {
    -setup        {
        set this [::UTP::unique_name]
    }
    -body        {
        event_declare $this <uno>
        event_bind $this <uno> {}
        catch {event_generate $this <due>} res
        set res
    }
    -result "unknown event \"<due>\""
    -cleanup        {
        unset -nocomplain $this this res
    }
}

::tcltest::test event-1.4 \
        "\[event_detach\] error: unkwnown event" {
    -setup        {
        set this [::UTP::unique_name]
    }
    -body        {
        event_declare $this <uno>
        event_bind $this <uno> {} id
        catch {event_detach $this <due> $id} res
        set res
    }
    -result "unknown event \"<due>\""
    -cleanup        {
        unset -nocomplain $this this res
    }
}

::tcltest::test event-1.5 \
        "\[event_detach\] error: unkwnown id" {
    -setup        {
        set this [::UTP::unique_name]
    }
    -body        {
        event_declare $this <uno>
        event_bind $this <uno> {} id
        catch {event_detach $this <uno> dummy} res
        set res
    }
    -result "unknown script identifier \"dummy\" for event \"<uno>\""
    -cleanup        {
        unset -nocomplain $this this res
    }
}

::tcltest::test event-2.1 \
        "registers and generates events" {
    -setup        {
        set this [::UTP::unique_name]
        set uno  0
    }
    -body        {
        event_declare $this <uno>
        event_declare $this <due>
        event_bind $this <uno> [namespace code { incr uno }]
        event_bind $this <due> [namespace code { set forever 1 }]

        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <due>

        vwait [namespace current]::forever
        set uno
    }
    -result 3
    -cleanup        {
        unset -nocomplain $this this uno
    }
}

::tcltest::test event-2.2 \
        "registers and generates events, then forgets" {
    -setup        {
        set this [::UTP::unique_name]
        set uno  0
    }
    -body        {
        event_declare $this <uno>
        event_declare $this <due>
        event_bind $this <uno> [namespace code { incr uno }]
        event_bind $this <due> [namespace code { set forever 1 }]

        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <due>

        vwait [namespace current]::forever
        event_forget $this <uno>
        catch {event_generate $this <uno>} res
        set res
    }

    -result "unknown event \"<uno>\""
    -cleanup        {
        unset -nocomplain $this this uno res
    }
}

::tcltest::test event-2.3 {
    registers and generates events, then forgets
} {
    -setup        {
        set this [::UTP::unique_name]
        set uno  0
    }
    -body        {
        event_declare $this <uno>
        event_declare $this <due>
        event_bind $this <uno> [namespace code { incr uno }]
        event_bind $this <uno> [namespace code { incr uno }] id
        event_bind $this <due> [namespace code { set forever 1 }]

        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <uno>
        event_generate $this <due>

        vwait [namespace current]::forever

        event_detach $this <uno> $id

        event_generate $this <uno>
        event_generate $this <due>
        set uno 0
        vwait [namespace current]::forever
        set uno
    }
    -result 1
    -cleanup        {
        unset -nocomplain $this this uno res id
    }
}

    ::tcltest::cleanupTests
}
namespace delete ::test

That's it.

Comments  edit

This is a nice start. There are some interesting pros and cons of this compared with Tk bindings.

On the plus side, it's much nicer to be able to independently bind multiple scripts to the same event as done here, compared with the hack in Tk that treats scripts beginning with + as scripts to be appended instead of replaced.

However, because of that difference, this scheme does not offer any way to remove a binding without removing an entire event, and *all* of its bindings.

The big thing that Tk's bindings have over this scheme, though, is the layer of indirection through bind tags that give Tk bindings so much power and flexibility.

As you hint, there's no reason this start could not be expanded in ways to more closely match Tk, where it makes sense to do so.

Marco Maggi 2003-01-27:

The TK scheme is good for GUI: the ability to break out of the binding scripts evaluation sequence is required; it's a specialised version of the "Observer" design pattern in which the "Subject" of the observation is the TK widget and the "Observers" are all the chunks of code that require to be notified of the event.

In the TK scheme an Observer can influence the Subject behaviour and so the other Observers. In the "event" package I don't think this is required.

About tags: again they are good for GUI, because there's a well known hierarchy of Subjects to which we append a tag. But we can see it as if the TK widgets code is invoking the event generate command each time the user clicks or "key-downs" etc.

In the "event" package the role of the tag is played by the event map array: nothing prevents us from building a set of event maps and link them in a graph, with an event script that triggers events in other maps. This is dangerous (infinite loops, etc.) and confused: but just because in a normal script there's no "well known" hierarchy of Subjects.

The ability to "detach" an Observer from a Subject is missing. It's not difficult to add it: just use an array element for each registered script, with a trace on each element. This requires generating a unique script identifier that's returned by event_bind to the Observer code, and can be later used to detach the script.

I want to think over this, because I like the extreme simplicity of the code as it is now and I don't want to mess it up.

Marco Maggi 2003-02-17:

Well, I've added event_detach to detach a script from an event. I've added the ability to generate a unique map-specific identifier for each registered script (a lot of words that means: a counter), so now I can evaluate all the scripts in the same order as they are registered.

Now the package no longer uses variable traces: they were good before because the code was small, but now with an element in the array for each registered script, it's useless to keep them.

MM 2003-01-28:

Corrected a dumb error in the event_generate loop.

MM 2003-01-28:

I see bit of interest in allowing a mnemonic name to be associated to the event map, or better wrap the event_* commands so that the array disappears from the procedure invocation:
set this [::tcl::tmp::unique_name]
interp alias {} apples_generate {} event_generate $this
# etc

With TK the "event map" is implicit in each invocation of bind, event and bindtags.

MM 2003-01-28:

Still not convinced about binding tags. When creating a Subject it is possible to hand to it more than one event map: it can store them in a list and then? Let's investigate this with the following UNTESTED code:
proc event::subject_declare {this subject args} {
    upvar $this tagmap
    set tagmap($subject) $args
}

here "this" is not the event map but the "tag map" a fully qualified variable name that we use as array to store the associations between a Subject identifier ("subject") and the list of event maps. "args" is the list of event maps (fully qualified array names) to be associated with the Subject.

We don't care here about the possibility to associate a mnemonic name to the event map.

Now, when the Subject needs to signal an event:
proc event::tag_generate {this subject event} {
     upvar $this tagmap

     if {![info exists tagmap($subject)]} {
         return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown subject "%s"} $subject]
     }

     foreach map $tagmap($subject) {
         catch {event_generate $map $event}
     }
     return
}

here we trigger the event in all the event maps; we catch because some map may not include the requested event.

To mess with the tag list:
proc event::tag_bindtags {this subject {lst {}}} {
     upvar $this tagmap

     if {![info exists tagmap($subject)]} {
         return -code error -errorcode {LOGIC INVALID_ARGUMENT} [
            format {unknown subject "%s"} $subject]
     }

     if {[llength $lst]} {
         set tagmap($subject) $lst
         return
     } else {
         return $tagmap($subject)
     }
}

The first arguments to the tag_* procedures are always "this" and "subject", so it's possible to interp alias them.

I cannot find an example for which this is useful. The Observer pattern IS good; but with tags?

Brian Theado 2003-01-29: A good example of where bindtags is useful in Tk is described by Bryan Oakley in Emulating editors in Tk, c.l.t, 2012-11-15. He describes how easy it would be to implement vi's insert vs. command mode in Tk's text widget using bindtags.

An example outside of Tk would be if you were to implement the TCP protocol. A bindtag would be defined for each TCP state (represented by bubbles in the state transition diagram at http://www4.informatik.uni-erlangen.de/Projects/JX/Misc/Projects/TCP/tcpstate.gif). Each tag would get the appropriate bindings for each of the events (i.e. recv FIN, recv SYN, recv ACK, etc.). Changing state would simply be a matter of swapping bindtags. Then if you also want to trace the events for debugging purposes, you can define another bindtag that logs the events. Entering and leaving debug mode is as simple as inserting and removing this bindtag.

MM 2003-01-28:

To after 0 or not to after 0? It's more general if I let the user choose if he want to queue scripts in the event loop or not. But: I like the event loop a lot. If you want to remove after 0, just change the foreach loop in event_generate like this:
 foreach id $map($event:list) {
     _event_eval $map($event:$id)
 }

and _event_eval like this:
catch {uplevel #0 $script}

we have to catch all the errors here: let the script take care of itself.

ulis, 2003-02-16: very nice idea and implementation.

This is quite similar to the uevent package in tcllib.

MartinCleaver 2009-09-05 11:54:48:

So is it better to use the uevent mechanism?

Why are there no examples for uevent?

Category Internals