1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
}
# ### ### ### ######### ######### #########
|
