1 files changed, 128 insertions, 0 deletions
diff --git a/tcllib/modules/devtools/coserv.tcl b/tcllib/modules/devtools/coserv.tcl
new file mode 100644
index 0000000..2b051e4
--- /dev/null
+++ b/tcllib/modules/devtools/coserv.tcl
@@ -0,0 +1,128 @@
+# -*- tcl -*-
+# CoServ - Comm Server
+# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# ### ### ### ######### ######### #########
+## Commands to create server processes ready to talk to their parent
+## via 'comm'. They assume that the 'tcltest' environment is present
+## without having to load it explicitly. We do load 'comm' explicitly.
+
+## Can assume that tcltest is present, and its commands imported into
+## the global namespace.
+
+# ### ### ### ######### ######### #########
+## Load "comm" into the master.
+
+namespace eval ::coserv {variable subcode {}}
+
+package forget comm
+catch {namespace delete comm}
+
+if {[package vsatisfies [package present Tcl] 8.5]} {
+    set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit2.tcl]
+} else {
+    set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit.tcl]
+}
+set ::coserv::commsrc [file join [file dirname [file dirname [info script]]] comm comm.tcl]
+
+if {[catch {source $::coserv::snitsrc} msg]} {
+    puts "Error loading \"snit\": $msg"
+    error ""
+}
+if {[catch {source $::coserv::commsrc} msg]} {
+    puts "Error loading \"comm\": $msg"
+    error ""
+}
+
+package require comm
+
+puts "- coserv (comm server)"
+#puts "Main       @ [::comm::comm self]"
+
+# ### ### ### ######### ######### #########
+## Core of all sub processes.
+
+proc ::coserv::setup {} {
+    variable subcode
+    if {$subcode != {}} return
+    set subcode [::tcltest::makeFile {
+	#puts "Subshell is \"[info nameofexecutable]\""
+	catch {wm withdraw .}
+
+	# ### ### ### ######### ######### #########
+	## Get main configuration data out of the command line, i.e.
+	## - Id of the main process for sending information back.
+	## - Path to the sources of comm.
+
+	foreach {snitsrc commsrc main cookie} $argv break
+
+	# ### ### ### ######### ######### #########
+	## Load and initialize "comm" in the sub process. The latter
+	## includes a report to main that we are ready.
+
+	source $snitsrc
+	source $commsrc
+	::comm::comm send $main [list ::coserv::ready $cookie [::comm::comm self]]
+
+	# ### ### ### ######### ######### #########
+	## Now wait for scripts sent by main for execution in sub.
+
+	#comm::comm debug 1
+	vwait forever
+
+	# ### ### ### ######### ######### #########
+	exit
+    } coserv.sub] ; # {}
+    return
+}
+
+# ### ### ### ######### ######### #########
+## Command used by sub processes to signal that they are ready.
+
+proc ::coserv::ready {cookie id} {
+    #puts "Sub server @ $id\t\[$cookie\]"
+    set ::coserv::go $id
+    return
+}
+
+# ### ### ### ######### ######### #########
+## Start a new sub server process, talk to it.
+
+proc ::coserv::start {cookie} {
+    variable subcode
+    variable snitsrc
+    variable commsrc
+    variable go
+
+    set go {}
+
+    setup
+    exec [info nameofexecutable] $subcode \
+	    $snitsrc $commsrc [::comm::comm self] $cookie &
+
+    #puts "Waiting for sub server to boot"
+    vwait ::coserv::go
+
+    # We return the id of the server
+    return $::coserv::go
+}
+
+proc ::coserv::run {id script} {
+    return [comm::comm send $id $script]
+}
+
+proc ::coserv::task {id script} {
+    comm::comm send -async $id $script
+    return
+}
+
+proc ::coserv::shutdown {id} {
+    variable subcode
+    #puts "Sub server @ $id\tShutting down ..."
+    task $id exit
+    tcltest::removeFile $subcode
+    set subcode {}
+    return
+}
+
+# ### ### ### ######### ######### #########