Version 1 of How to mimic event generation without TK

Updated 2003-01-26 20:44:24

The event TK command 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 variable traces to trigger the evaluation of scripts, so first we need to obtain a unique fully qualified name: we declare an array and use it as a map that associates event names to variable traces.

 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_forget
 }

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
    } 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 args } {
    upvar        $this map

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

    foreach script [concat [list $script] $args] {
        if { [string length $script] } {
            set name [set this]($event)
            trace add variable $name write \
                    [list after 0 [namespace code \
                        [list _event_eval $script ]]]
        }
    }
    return
 }

we see that scripts are queued in the event loop with the [after] command. To generate events:

 proc event::event_generate { this event } {
    upvar        $this map

    set name ${this}($event)
    if { [info exists $name] } {
        set $name 1
    } else {
        return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
                [format "unknown event \"%s\"" $event]
    }
    return
 }

We may want to remove an event declaration and all the associated variable traces:

 proc UTP::event_forget { this event args } {
    upvar        $this map


    foreach event [concat [list $event] $args] {
        unset -nocomplain -- map($event)
    }
    return
 }

we don't care if we invoke this with an unexistent event name, this can be changed easily.

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:

 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 "registers and generates events" {
    -setup        {
        set this [::tcl::tmp::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-1.2 "registers, generates, then forgets" {
    -setup        {
        set this [::tcl::tmp::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 <due> <tre> <uno>
        catch {event_generate $this <uno>} res
        set res
    }

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

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

That's it.


Marco Maggi - 26 Jan 2003


This is a nice start. There are some interesting pros and cons of this compare 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.