Page maintainer: Marco Maggi
With TCL it's possible to organise the code so that a sequence of event handler invocations can be viewed as the execution of a "subprocess" of the main script; this is done arranging access for the event handlers to a set of variables considered private for the subprocess.
In this document we'll name the subprocesses "event loop processes" or tasks, and this technique "event loop multitasking".
The concept is easy: since an event handler is a script and TCL is capable of building a script at runtime, we use a procedure as handler and we allocate a variable name reserved for the task:
proc handler { varname channel } {
upvar $varname value
# do something
}
set value 123the variable name is handed to the procedure in the event handler script; for example: if the event is the readability of an I/O channel:
fileevent $channel readable \
[namespace code handler ::value $channel]every time the channel becomes readable, the [handler] procedure can update the value of the global variable (note that the variable name must be fully qualified with the namespace). If the variable is an array, more than one value can constitute the "state" of the task.
Obviously, at some point the channel will be closed and the handler procedure will be detached from the event loop. The state of the task must not be lost, so for example:
proc handler { varname channel } {
upvar $varname value
...
if { [eof $channel] } {
close $channel
terminate $varname
}
}[handler] invokes the procedure [terminate] to take care of task finalisation; the fully qualified name of the state variable is handed as argument to the finalisation procedure.
The [handler] procedure is reentrant: the state of the event loop process is stored in a global variable that's accessed only in the sequence of event loop handlers evaluations.
It is good programming style to keep the event handler script itself as little as possible, and to code all the task logic in the handler procedure.
In the following kilobytes a little package is presented: it allows the state of a task to be stored in any number of variables and arrays and handles the final cleanup with a single procedure call. It can be viewed as a big wrapper for a global associative array.
First of all we need a procedure to create unique variable names in a private namespace:
namespace eval ::tcl::tmp {
variable global_counter 0
namespace export unique_name
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 the package namespace:
namespace eval task {
namespace export task_constructor task_destructor task_global
namespace import ::tcl::tmp::unique_name
}and a brief overview of the procedures: [task_constructor], initialises a new task; [task_destructor], finalises the task unsetting all the variables; [task_global], used as the builting [global] command, links the task variables to the scope of a procedure.
All the package procedures accept as first argument the fully qualified name of a variable: it's used to store task data and as an identifier for the task itself.
The constructor initialises the task data:
proc task_constructor { this args } {
upvar $this token
array set token { GLOBALS {} }
return
}and the destructor unsets all the task variables:
proc task_destructor { this } {
upvar $this token
eval {unset -nocomplain --} $token(GLOBALS)
return
}the task variable itself is not deallocated: it's responsibility of the caller to do that.
The [task_global] procedure works exactly as the builtin [global] command: it doesn't actually create variables, it just links variable names to the procedure's scope.
proc task_global { this varname args } {
upvar $this token
foreach varname [concat [list $varname] $args] {
if { [lsearch $token(GLOBALS) $varname] < 0 } {
lappend token(GLOBALS) $varname
set token(global:$varname) [unique_name]
}
uplevel [list upvar \#0 $token(global:$varname) $varname]
}
return
}we see that the [unique_name] procedure is used to generate a unique name for task variables.
This is the package. As a simple non-event related usage example take a look at the following code:
proc begin { task working_directory } {
task_constructor $task
task_global $task pwd data
set pwd $working_directory
set data 123
}
proc routine { task args } {
task_global $task pwd data
cd $pwd
...
set data ...
...
}
proc end { task } {
task_global $task data
# do something with "$data"
task_destructor $task
unset $task
return
}
namespace import ::tcl::tmp::unique_name
set task [unique_name]
begin $task
routine $task
end $taskNow a more interesting event loop example: a script that executes external processes and reads data from them until they are terminated. To simulate an external process, we create the following TCL script:
# sleeper.tcl --
puts start
after 1000 { set ::forever 1 }
vwait forever
puts end
exit 0
# end of fileand will execute it with the commands:
set cmd [list [auto_execok tclsh] ./sleeper.tcl]
set id [open |$cmd {RDWR}]The script just prints a string at the beginning and at the end. The controlling script is below: it's a TCL+TK script that let's us create multiple event loop processes, each of which starts a sequence of "sleeper.tcl" scripts. Every time a new "sleeper.tcl" script is executed a counter is incremented, so we can track how many scripts each task has executed so far.
Tasks can be stopped and resumed. When exiting: the script waits for the termination of all the event loop processes, and each process waits for the termination of the running "sleeper.tcl" script.
# tasktest.tcl --
package require Tk
array set status {
IDENTS {}
RUNNING {}
COUNTERS {}
}
proc build_gui {} {
global value
set value 0
option add *Listbox.background white
option add *Listbox.selectMode single
option add *Listbox.exportSelection no
option add *Entry.background white
option add *Label.background lightgray
option add *Button.borderWidth 1
option add *Message.aspect 500
option add *Message.relief sunken
option add *Message.background white
wm geometry . +10+10
message .msg -text "Start one or more tasks with \"Begin Task\",\
then select a task by clicking in the listboxes and Stop/Continue it.
While tasks are running, press the \"Push Me\" button to verify that\
the GUI is still responding fine (the counter on the left is incremented).
When you're tired: press the \"Quit\" button and see the tasks\
terminate one by one."
frame .bbar
button .bbar.start -text "Begin Task" -command exec_start
button .bbar.stop -text "Stop Task" -command exec_stop
button .bbar.continue -text "Continue Task" -command exec_continue
button .bbar.quit -text "Quit" -command { set forever 1 }
pack .bbar.start .bbar.stop .bbar.continue .bbar.quit -side left
bind Listbox <ButtonRelease-1> [list propagate_listbox_selection %W]
foreach { text name } {
Identifiers idents
Status status
Counters counters
} {
labelframe .$name -text [format "Task %s:" $text]
listbox .$name.lb \
-listvariable ::status([string toupper $name])
grid .$name.lb -sticky news
}
entry .e -textvariable ::value -justify right
button .b -text "Push me" -command { incr ::value }
grid .msg -columnspan 3 -sticky news
grid .bbar -columnspan 3 -sticky w -ipadx 5 -ipady 5
grid .idents .status .counters -sticky news
grid .e .b
}
proc propagate_listbox_selection { widget } {
set idx [$widget curselection]
foreach lb { idents status counters } {
if { ! [string equal $widget .$lb.lb] } {
.$lb.lb selection clear 0 end
.$lb.lb selection set $idx
}
}
}
namespace eval tcl::tmp {
namespace export unique_name
variable global_counter -1
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
}
}
namespace import ::tcl::tmp::unique_name
namespace eval task {
namespace export task_constructor task_destructor task_global
namespace import ::tcl::tmp::unique_name
}
proc task_constructor { this args } {
upvar $this token
array set token { GLOBALS {} }
return
}
proc task_destructor { this } {
upvar $this token
eval {unset -nocomplain --} $token(GLOBALS)
return
}
proc task_global { this varname args } {
upvar $this token
foreach varname [concat [list $varname] $args] {
if { [lsearch $token(GLOBALS) $varname] < 0 } {
lappend token(GLOBALS) $varname
set token(global:$varname) [unique_name]
}
uplevel [list upvar \#0 $token(global:$varname) $varname]
}
return
}
proc exec_start {} {
global status
set task [unique_name]
task_constructor $task
task_global $task id command state
set id {}
set command [list [auto_execok tclsh] ./sleeper.tcl]
set state "stop"
after 0 [list exec_run $task]
lappend status(IDENTS) $task
lappend status(STATUS) "stopped"
lappend status(COUNTERS) 0
return
}
proc exec_run { task } {
global status
task_global $task command id state
set idx [lsearch $status(IDENTS) $task]
lset status(STATUS) $idx "running"
set state "running"
set id [open |$command {RDWR}]
fileevent $id readable [list exec_done $task]
}
proc exec_done { task } {
global status
task_global $task id state
gets $id line
if { [string equal $line "start"] } {
#puts [format "%s: start" $task]
} elseif { [string equal $line end] } {
#puts [format "%s: end" $task]
set idx [lsearch $status(IDENTS) $task]
set count [lindex $status(COUNTERS) $idx]
lset status(COUNTERS) $idx [incr count]
close $id
switch $state {
running { exec_run $task }
end { exec_finalise $task }
}
}
}
proc exec_stop {} {
global status
set idx [.idents.lb curselection]
if { [string is integer -strict $idx] } {
set task [lindex $status(IDENTS) $idx]
task_global $task state
set state "stopped"
set idx [lsearch $status(IDENTS) $task]
lset status(STATUS) $idx "stopped"
}
}
proc exec_continue {} {
global status
set idx [.idents.lb curselection]
if { [string is integer -strict $idx] } {
set task [lindex $status(IDENTS) $idx]
task_global $task state
if { [string equal $state "stopped"] } {
exec_run $task
}
}
}
proc exec_end { task } {
task_global $task state
if { [string equal $state "running"] } {
set state "end"
} else {
exec_finalise $task
}
}
proc exec_finalise { task } {
global status exiting
set idx [lsearch $status(IDENTS) $task]
foreach key { IDENTS COUNTERS STATUS } {
set status($key) [lreplace $status($key) $idx $idx]
}
set exiting 1
}
build_gui
vwait forever
foreach task $status(IDENTS) {
exec_end $task
}
while { [llength $status(IDENTS)] > 0 } {
vwait exiting
}
foreach task $status(IDENTS) {
task_destructor $task
}
exit 0COMMENTS