Multitasking and the event loop: the script

# 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: