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 123
the 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 $task
Now 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 file
and 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 0
COMMENTS