# controller.tcl --
#
# Part of: The TCL'ers Wiki
# Contents: demonstrates multitasking with TCL
# Date: updated on June, 2003
#
# Abstract
#
# Read the TCL'ers Wiki page "Multitasking and the event loop"
# to learn what this script does. Remember to create the
# "sleepers.tcl" script in the same directory of this one.
#
# This script is a little complex for a Wiki page, but I wanted
# to make it a demonstration of the task package features. You can
# find the task package description at the TCL'ers Wiki page
# "The task package". I'll also reuse this infrastructure in other
# TCL'ers Wiki pages.
#
# If someone is interested in demonstrating some object system
# package, like [Incr TCL] and XOTcl, and wants to take this code:
# just do it.
#
# Overview
#
# There are six modules:
#
# script - the main module, resides in the "script"
# namespace; it's responsible for the script
# initialisation and finalisation and acts also
# as a mediator between the GUI and the process
# control modules;
#
# gui - the GUI module, resides in the "gui" namespace;
# draws the user interface and handles the commands
# associated to the widgets;
#
# ptable - the process table, resides in the "ptable"
# namespace; keeps track of the existing processes;
#
# process - the image of a sequence of executions of external
# programs, resides in the "process" namespace;
#
# protocol - handles the communication between this script
# and the external programs, resides in the
# "protocol" namespace; it doesn't do much;
#
# task - the task package.
#
# Widget commands handling. Whenever a command is requested by the
# user a procedure is evaluated in the "gui::command" namespace:
# it gets a chance to update the GUI and then invokes a procedure
# in the "script::command" namespace that actually does what it's
# meant.
#
# Copyright (c) 2003 Marco Maggi
#
# The author hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose,
# provided that existing copyright notices are retained in all copies
# and that this notice is included verbatim in any distributions. No
# written agreement, license, or royalty fee is required for any of the
# authorized uses. Modifications to this software may be copyrighted by
# their authors and need not follow the licensing terms described here,
# provided that the new terms are clearly indicated on the first page of
# each file where they apply.
#
# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
# NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS,
# AND THE AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# $Id: 9059,v 1.2 2005-07-16 06:00:12 jcw Exp $
#PAGE
## ------------------------------------------------------------
## Required packages.
## ------------------------------------------------------------
package require Tcl 8
package require Tk 8
#PAGE
## ------------------------------------------------------------
## Script namespace.
## ------------------------------------------------------------
namespace eval script {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace export get_value_var
}
#PAGE
# script::main --
#
# Main procedure; this procedure must be invoked at the end
# of the script like this:
#
# ::script::main $argc $argv
#
# This procedure declares a task to hold its data. The
# members are:
#
# ptable - the token of the process table task;
# gui - the token of the GUI task;
# value - a variable holding an integer that's
# incremented by a [button] widget to
# demonstrate that the GUI is alive when
# the external programs are running;
# quitflag - the variable used signal events to this
# procedure.
#
# Arguments:
#
# argc - the number of elements in "argv"
# argv - the list of command line arguments
#
# Results:
#
# Operations:
#
# - initialises the process table;
# - initialises the GUI;
# - waits for the user to submit the quit command;
# - finalises the process table.
#
# Exits with code zero.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc script::main { argc argv } {
set main [task::constructor ptable gui value quitflag]
set quitflag 0
set value 0
# Build the GUI. The module requires the main task's token to submit
# command requests from the widgets to the rest of the program and to
# access the "value" variable.
set gui [gui::constructor $main]
# Build a process table. The module requires a script to run to
# notify the GUI of process' state changes.
set ptable [ptable::constructor "::gui::notify_process_event $gui"]
# Wait for the quit command.
set v [task::globname $main quitflag]
vwait $v
# Waits for all the processes in the table to be terminated.
if { ! [ptable::finalise $ptable "::set $v 2"] } {
vwait $v
}
# Finalisation.
ptable::destructor $ptable
gui::destructor $gui
task::destructor $main
exit 0
}
#PAGE
# script::get_value_var --
#
# Access the "value" variable.
#
# Arguments:
#
# main - the task's token
#
# Results:
#
# Returns fully qualified name of the "value" task variable,
# this is required by the GUI module to increment the integer
# in it.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc script::get_value_var { main } {
return [task::globname $main value]
}
#PAGE
# script::quit --
#
# Signals to the [main] [vwait] command that a request to
# terminate the script has been received.
#
# Arguments:
#
# main - the main token
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc script::quit { main } {
task::global $main quitflag
if { $quitflag == 0 } {
set quitflag 1
}
}
#PAGE
## ------------------------------------------------------------
## Script commands.
## ------------------------------------------------------------
namespace eval script::command {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace export \[a-z\]*
}
# Stores a value in the variable used to signal events to the [main]
# procedure, which is blocked by a [vwait] on the variable
# itself. Returns the empty string.
proc script::command::quit { main } {
[namespace parent]::quit $main
}
proc script::command::start { main } {
task::global $main ptable
process::constructor $ptable "[auto_execok tclsh] sleeper.tcl"
}
proc script::command::stop { main selected_process } {
process::signal_stop $selected_process
}
proc script::command::resume { main selected_process } {
process::signal_resume $selected_process
}
proc script::command::terminate { main selected_process } {
process::signal_termination $selected_process
}
#PAGE
## ------------------------------------------------------------
## The GUI namespace.
## ------------------------------------------------------------
namespace eval gui {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace export \[a-z\]*
wm withdraw .
variable counter 0
variable message \
"Start one or more tasks with \[Start\], then select a task by\
clicking in the listboxes and \[Stop\] or \[Resume\] 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."
variable buttonbar_buttons { start stop resume terminate quit }
variable state_listboxes { identifiers states counters }
# Overall options.
option add *borderWidth 1
# Options for the [message] widget explaining how to use the
# program.
option add *Upper.ipadx 2m
option add *Upper.ipady 2m
option add *Upper.message.aspect 500
option add *Upper.message.relief sunken
option add *Upper.message.background white
option add *Upper.message.text $message
option add *Upper.message.font Roman
# Options for the button bar.
option add *Bbar.borderWidth 2
option add *Bbar.relief groove
option add *Bbar.start.text "Start"
option add *Bbar.stop.text "Stop"
option add *Bbar.resume.text "Resume"
option add *Bbar.terminate.text "Terminate"
option add *Bbar.quit.text "Quit"
# Options for the frame of listboxes.
option add *State.ipadx 2m
option add *State.ipady 2m
option add *State.Labelframe.relief groove
option add *State.Labelframe.borderWidth 2
option add *State.Labelframe.ipadx 2m
option add *State.Labelframe.ipady 2m
option add *State.identifiers.text "Identifiers"
option add *State.states.text "States"
option add *State.counters.text "Counters"
option add *State*Labelframe.listbox.background white
option add *State*Labelframe.listbox.selectMode single
option add *State*Labelframe.listbox.exportSelection no
# Options for the frame of widgets demonstrating the liveness of the
# GUI.
option add *Stillalive.borderWidth 2
option add *Stillalive.relief groove
option add *Stillalive.ipadx 1m
option add *Stillalive.ipady 1m
option add *Stillalive.label.background white
option add *Stillalive.label.width 5
option add *Stillalive.label.relief sunken
option add *Stillalive.button.text "Push me!"
set s { _propagate_listbox_selection %W }
bind Listbox <ButtonRelease-1> [namespace code $s]
}
#PAGE
# gui::unique --
#
# Return the pathname of a unique widget.
#
# Arguments:
#
# parent - optional pathname of the parent
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::unique { {parent .} } {
variable counter
if { [string equal $parent .] } {
return .[incr counter]
} else {
return $parent.[incr counter]
}
}
#PAGE
# gui::constructor --
#
# Initialises the GUI.
#
# Arguments:
#
# main - the token of the main task
#
# Results:
#
# Returns the GUI task' token.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::constructor { main } {
variable buttonbar_buttons
variable state_listboxes
set gui [task::constructor window identifiers states counters]
# Toplevel.
toplevel [set window [unique]] -class Window
wm withdraw $window
wm title $window "Multitasking and the event loop"
wm geometry $window +10+10
# Upper frame.
frame [set f [unique $window]] -class Upper
grid $f -sticky news
message $f.message
grid $f.message -row 0 -column 0
# Button bar.
frame [set f [unique $window]] -class Bbar
grid $f -row 1 -column 0 -sticky news -padx 2m -pady 2m
set i -1
foreach n $buttonbar_buttons {
button $f.$n -command [namespace code "command::$n $gui $main"]
grid $f.$n -row 0 -column [incr i]
}
unset f i
# Listboxes.
frame [set f $window.state] -class State
grid $f -sticky news -row 2 -column 0
set i -1
foreach n $state_listboxes {
labelframe $f.$n
grid $f.$n -column [incr i] -row 0 -sticky news \
-padx 1m -pady 1m
listbox $f.$n.listbox -listvariable [task::globname $gui $n]
grid $f.$n.listbox -sticky news -padx 1m -pady 1m
}
unset f i
# Still-alive widgets.
frame [set f [unique $window]] -class Stillalive
grid $f -sticky news -row 3 -column 0 -padx 1m -pady 1m
label $f.label -textvariable [set v [script::get_value_var $main]]
button $f.button -command "incr $v"
grid $f.label $f.button
unset f v
# Let's go.
wm deiconify $window
tkwait visibility $window
return $gui
}
#PAGE
# gui::destructor --
#
# GUI destructor.
#
# Arguments:
#
# gui - the GUI's task token
#
# Results:
#
# Destroys the window and the task.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::destructor { gui } {
destroy [task::globget $gui window]
task::destructor $gui
return
}
#PAGE
# gui::notify_process_event --
#
# This procedure is invoked to update the GUI with the new
# state of a process. The recognised state identifiers are:
#
# created - the process has been created but no
# external program have been started yet;
#
# running - the process has started a new external
# program, with this state the "counter"
# argument must be used;
#
# stopping - the process has received a request to
# stop the execution of external programs;
#
# stopped - the process has been stopped;
#
# resuming - the process has received a request to
# resume itself;
#
# terminating - the process has received a request to
# terminate itself;
#
# terminated - the process has terminated itself, its
# data is removed from the GUI.
#
# Arguments:
#
# gui - the GUI's task token
# process - the process' token
# state - the new state identifier
# counter - optional number of external programs
# run by the process so far
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::notify_process_event { gui process state {counter {}} } {
task::global $gui identifiers states counters
switch -exact -- $state {
created {
lappend identifiers $process
lappend states $state
lappend counters 0
}
running {
set idx [lsearch $identifiers $process]
lset states $idx $state
lset counters $idx $counter
}
stopping -
stopped -
terminating {
set idx [lsearch $identifiers $process]
lset states $idx $state
}
terminated {
set idx [lsearch $identifiers $process]
set identifiers [lreplace $identifiers $idx $idx]
set states [lreplace $states $idx $idx]
set counters [lreplace $counters $idx $idx]
}
}
return
}
#PAGE
# gui::get_selected_process --
#
# Access the currently selected process.
#
# Arguments:
#
# gui - the GUI's task token
#
# Results:
#
# Returns the process identifier.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::get_selected_process { gui } {
task::global $gui window identifiers
set lb $window.state.identifiers.listbox
return [lindex $identifiers [$lb curselection]]
}
#PAGE
# gui::_propagate_listbox_selection --
#
# Propagates the selection from a listbox to the others.
#
# Arguments:
#
# widget - the [listbox] widget that triggered
# the event
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc gui::_propagate_listbox_selection { widget } {
variable state_listboxes
set idx [$widget curselection]
set granpa [winfo parent [winfo parent $widget]]
foreach frame $state_listboxes {
if { ! [string equal $widget $granpa.$frame.lb] } {
$granpa.$frame.listbox selection clear 0 end
$granpa.$frame.listbox selection set $idx
}
}
}
#PAGE
## ------------------------------------------------------------
## GUI's commands namespace.
## ------------------------------------------------------------
namespace eval gui::command {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace import ::gui::get_selected_process
}
proc gui::command::quit { gui main } {
script::quit $main
}
proc gui::command::start { gui main } {
script::start $main
}
proc gui::command::stop { gui main } {
if { [string length [set process [get_selected_process $gui]]] } {
script::stop $main $process
}
}
proc gui::command::resume { gui main } {
if { [string length [set process [get_selected_process $gui]]] } {
script::resume $main $process
}
}
proc gui::command::terminate { gui main } {
if { [string length [set process [get_selected_process $gui]]] } {
script::terminate $main $process
}
}
#PAGE
## ------------------------------------------------------------
## Process' table namespace.
## ------------------------------------------------------------
namespace eval ptable {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace export \[a-z\]*
variable period 500
}
#PAGE
# ptable::constructor --
#
# Builds a new process table. This procedure must be invoked
# when the script is initialised.
#
# The task members are:
#
# process_list - the list of identifiers of currently
# existing processes;
#
# notify_script - a script to be evaluated in the global
# namespace to notify a change in state
# for a process, it must accept two
# mandatory arguments: the process
# identifier and the state identifier, and
# an optional argument: the count of
# external programs run so far;
#
# finalise_script - a script to be evaluated in the global
# namespace to notify the complete
# finalisation of the process table.
#
# Arguments:
#
# _notify_script - the notifier script
#
# Results:
#
# Returns the instance's token.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::constructor { _notify_script } {
set table [task::constructor process_list notify_script finalise_script]
set process_list {}
set notify_script $_notify_script
return $table
}
#PAGE
# ptable::destructor --
#
# Process table destructor. It must be invoked after the table
# has been finalised.
#
# Arguments:
#
# table - the instance's token
#
# Results:
#
# Destroys the instance.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::destructor { table } {
task::destructor $table
}
#PAGE
# ptable::register --
#
# Registers a process in the table. This is invoked by a
# process instance whenever it initialises itself.
#
# Arguments:
#
# table - the instance's token
# process - the process identifier
#
# Results:
#
# Appends the identifier to the list. Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::register { table process } {
task::global $table process_list
lappend process_list $process
return
}
#PAGE
# ptable::unregister --
#
# Removes a process identifier from the list of registered
# processes. This is invoked by a process instance whenever
# it terminates itself.
#
# Arguments:
#
# table - the instance's token
# process - the process identifier
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::unregister { table process } {
task::global $table process_list
set idx [lsearch $process_list $process]
if { $idx >= 0 } {
set process_list [lreplace $process_list $idx $idx]
} else {
return -code error "unknown process \"$process\""
}
return
}
#PAGE
# ptable::notify_process_event --
#
# This procedure is invoked by a process instance to signal
# changes in its state.
#
# Arguments:
#
# table - the ptable instance's token
# process - the process identifier
# state - a string identifying the new state
# counter - optional number of external programs
# run by the process so far
#
# Results:
#
# Evaluates the notifier script previously registered.
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::notify_process_event { table process state {counter {}} } {
task::global $table notify_script
eval $notify_script { $process $state $counter }
return
}
#PAGE
# ptable::finalise --
#
# Finalises all the processes.
#
# Arguments:
#
# table - the table's token
# script - a script to be evaluated in the global
# namespace whenever all the processes
# are terminated
#
# Results:
#
# If there are no processes in the table: returns one,
# else returns zero.
#
# In the latter case signals to all the registered processes
# that the execution has to terminate, then schedules a periodic
# script in the event loop that keeps track of the processes
# still existing and, when all of them are terminated,
# evaluates the "script" argument.
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::finalise { table script } {
variable period
task::global $table process_list finalise_script
if { [llength $process_list] == 0 } {
return 1
}
set finalise_script $script
foreach process $process_list {
process::signal_termination $process
}
after $period [namespace code "_finalise_handler $table"]
return 0
}
#PAGE
# ptable::_finalise_handler --
#
# This procedure is scheduled in the event loop by [finalise]
# to check when all the processes are terminated.
#
# It must be invoked with a valid script in the "finalise_script"
# variable. This script, when evaluated, must warn some other
# part of the program (probably a [vwait]) of the finalisation
# event.
#
# Arguments:
#
# table - the table's token
#
# Results:
#
# If the list of registered processes is empty: evaluates the
# registered script in the global namespace; else: reschedules
# itself.
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc ptable::_finalise_handler { table } {
variable period
task::global $table process_list finalise_script
if { [llength $process_list] == 0} {
namespace eval :: $finalise_script
} else {
after $period [namespace code "_finalise_handler $table"]
}
return
}
#PAGE
## ------------------------------------------------------------
## Process module's namespace.
## ------------------------------------------------------------
namespace eval process {
# At the end of the script (when all the namespaces have been
# created) sub-namespaces are created in this namespace. This is
# required because [namespace import] will import only existing
# commands.
namespace export \[a-z\]*
}
#PAGE
# process::constructor --
#
# Builds a new avatar for a sequence of executions of an
# external program.
#
# The purpose of a process instance is execute the
# registered external command again and again until the
# termination request is received. A count of the execution
# number is kept and notified to the table this process belongs
# to. The execution sequence can be stopped and resumed with
# appropriate requests.
#
# A process can be in any of the following states:
#
# created - the process has been created but no external
# program have been started yet;
#
# * the instance is registered into the process
# table;
# * a command is scheduled in the event loop to
# run an instance of the program, it'll switch
# the state to "running";
#
# running - the process has started a new external
# program;
#
# stopping - the process has received a request to
# stop the execution of external programs;
#
# * the request is registered and when the
# running external program terminates the
# state is switched to "stopped";
#
# stopped - the process has been stopped; no external
# programs are running or will be started until
# the process receives a "resume" request;
#
# resuming - the process has received a request to resume
# itself;
#
# * a command is scheduled in the event loop to
# run a new program, switching the state to
# "running";
#
# terminating - the process has received a request to terminate
# itself;
#
# * the request is registered and when the running
# external program terminates the state is
# switched to "terminated";
#
# terminated - the process has terminated itself;
#
# * the instance is unregistered from the table;
# * the instance is destroyed.
#
# Arguments:
#
# _ptable - the process table this one belongs to
# _command - the command used to run the external
# program
#
# Results:
#
# Returns the process instance's token.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::constructor { _ptable _command } {
set process [task::constructor ptable state channel command counter]
set ptable $_ptable
set command $_command
set state "created"
set counter 0
ptable::register $ptable $process
ptable::notify_process_event $ptable $process $state
after 0 [namespace code "_run $process"]
return $process
}
#PAGE
# process::destructor --
#
# Destroys an instance.
#
# Arguments:
#
# process - the instance's token
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::destructor { process } {
task::global $process ptable
ptable::unregister $ptable $process
ptable::notify_process_event $ptable $process "terminated"
task::destructor $process
return
}
#PAGE
# process::_run --
#
# Starts a new external program. This procedure is scheduled
# in the event loop every time a new external program must
# be launched.
#
# Arguments:
#
# process - the process instance's token
#
# Results:
#
# Executes the registered program opening a bidirectional
# pipe with it; a handler script is registered.
#
# The external program must signal its termination with
# an appropriate command, written through the pipe, to the
# protocol module: this will trigger the registered event
# handler, that will take care of the cleanup and will
# reschedule this procedure.
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::_run { process } {
task::global $process state ptable command channel counter
set channel [open |$command {RDWR}]
fconfigure $channel -buffering none -blocking yes
fileevent $channel readable [namespace code "_handler $process"]
set state "running"
incr counter
ptable::notify_process_event $ptable $process $state $counter
return
}
#PAGE
# process::signal_stop --
#
# This procedure is invoked whenever this process must stop
# the sequence of executions.
#
# Arguments:
#
# process - the instance's token
#
# Results:
#
# The request is registered and will be served as soon as
# the running external program terminates.
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::signal_stop { process } {
task::global $process ptable state
if { [string equal $state "running"] } {
set state "stopping"
ptable::notify_process_event $ptable $process $state
}
return
}
#PAGE
# process::signal_resume --
#
# This procedure is invoked whenever this process must resume
# the sequence of executions.
#
# Arguments:
#
# process - the instance's token
#
# Results:
#
# A script is scheduled in the event loop to resume the sequence
# of executions. Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::signal_resume { process } {
task::global $process ptable state
if { [string equal $state "stopped"] } {
set state "resuming"
ptable::notify_process_event $ptable $process $state
after 0 [namespace code "_run $process"]
}
return
}
#PAGE
# process::signal_termination --
#
# This procedure is invoked whenever this process must terminate
# the sequence of executions.
#
# Arguments:
#
# process - the instance's token
#
# Results:
#
# The request is registered and will be served as soon as
# the running external program terminates.
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::signal_termination { process } {
task::global $process ptable state
if { [string equal $state "running"] } {
set state "terminating"
ptable::notify_process_event $ptable $process $state
} else {
destructor $process
}
return
}
#PAGE
# process::_handler --
#
# This procedure is attached to the external program's pipe
# as event handler.
#
# Arguments:
#
# process - the process instance's token
#
# Results:
#
# Returns the empty string.
#
# Error codes:
#
# None.
#
# Side effects:
#
# None.
#
proc process::_handler { process } {
task::global $process channel state ptable
set eof 0
gets $channel line
if { [eof $channel] } {
set eof 1
set state "terminating"
}
if { $eof || [protocol::talk $line] } {
close $channel
switch $state {
running { after 0 [namespace code "_run $process"] }
stopping {
set state "stopped"
ptable::notify_process_event $ptable $process $state
}
terminating { after 0 [namespace code "destructor $process"] }
}
}
return
}
#PAGE
## ------------------------------------------------------------
## Protocol module's namespace.
## ------------------------------------------------------------
namespace eval protocol {}
proc protocol::talk { line } {
switch $line {
HELLO { return 0 }
QUIT { return 1 }
}
return 0
}
#PAGE
## ------------------------------------------------------------
## The task package.
## ------------------------------------------------------------
namespace eval task {
namespace export \[a-z\]*
variable counter 0
variable ns [namespace current]
variable map
array set map {}
namespace eval tmp {}
}
proc task::constructor { args } {
variable counter
variable map
variable ns
while { [info exists map([incr counter])] } {}
set map([set token $counter]) {}
foreach varname $args {
while { [info exists [set n ${ns}::tmp::[incr counter]]] } {}
uplevel [list upvar [set map($token:$varname) $n] $varname]
}
return $token
}
proc task::destructor { token } {
variable map
foreach k [array names map $token:*] {
# Some variables may be unexistent, only registered, so we use
#"-nocomplain".
unset -nocomplain -- $map($k)
unset map($k)
}
unset map($token)
return
}
proc task::global { token varname args } {
variable map
uplevel [list upvar $map($token:$varname) $varname]
foreach varname $args {
uplevel [list upvar $map($token:$varname) $varname]
}
return
}
proc task::globname { token varname } {
variable map
return $map($token:$varname)
}
proc task::globset { token varname value } {
variable map
set $map($token:$varname) $value
return
}
proc task::globget { token varname } {
variable map
return [set $map($token:$varname)]
}
#PAGE
## ------------------------------------------------------------
## Main script.
## ------------------------------------------------------------
namespace eval script {
namespace eval task { namespace import ::task::* }
namespace eval gui { namespace import ::gui::* }
namespace eval ptable { namespace import ::ptable::* }
namespace eval command {
namespace eval task { namespace import ::task::* }
namespace eval process { namespace import ::process::* }
}
}
namespace eval gui {
namespace eval task { namespace import ::task::* }
namespace eval script { namespace import ::script::* }
namespace eval command {
namespace eval script { namespace import ::script::command::* }
}
}
namespace eval ptable {
namespace eval task { namespace import ::task::* }
namespace eval process { namespace import ::process::* }
}
namespace eval process {
namespace eval task { namespace import ::task::* }
namespace eval ptable { namespace import ::ptable::* }
}
script::main $argc $argv
### end of file
# Local Variables:
# mode: tcl
# page-delimiter: "^#PAGE"
# End: