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