The code below defines two commands hubs::interp::local_spawn and hubs::interp::ssh_spawn which are similar to interp create in that they create a new interp and return the name of a "slave command" that can be used to control it, e.g. tell it to eval whatever script one likes. What is new about these commands is however that the interpreter they create resides in a separate process. In the case of ssh_spawn, that process may furthermore have been started on a completely different computer! For example, you can do
% hubs::interp::ssh_spawn my [email protected] ; # Bogus login info Password: Hello, I'm example.tcl.tk 52024 /usr/bin/tclsh 8.5.7 ::my::slave % my::slave eval {array get tcl_platform} osVersion 10.5.0 pointerSize 8 byteOrder littleEndian threaded 1 machine i386 platform unix os Darwin user lars wordSize 8 % my::slave exit
For various reasons, it was a requirement for hubs that it should handle the following situation:
The idea was to have C act as a router for the stream of messages between B and A. hubs has a lot of code for managing small networks of Tcl processes that send messages to each other, and for abstracting the details of the actual means employed in each communication link.
This is all rather complicated (e.g., there is a dependence on snit), and a process like C can get started in a fairly barren environment, so some kind of bootstrapping would probably be needed: First set up an environment that is just stable enough that you can send arbitrary commands, then worry about loading whatever packages that'll be needed. The code below is mostly just the first step of that bootstrapping — a slave interp seems a very natural model to emulate — but it does have some bells and whistles built in that are rather meant for the full system. If you don't use them, then they shouldn't be a problem, but they can make it harder to understand the code. The hubs page has links to more documentation of the many protocols and interfaces that are in use.
A child interpreter here is a separate Tcl interpreter process whose stdin and stdout are available to us as a channel—as would e.g. be the result of open "|tclsh" r+. This technique can be used to achieve multitasking without threads. A Tcl interpreter started at the other end of an SSH connection also falls into this category.
When booting hubs in a child process, it is useful to avoid depending on snit (at least initially), so the following is a clone of the hubs::link::channel class as a namespace.
namespace eval hubs::link::nschan {}The procedure to set up an "nschan object" is as follows:
The latter initialises all the variables and creates an "object command" (a namespace ensemble or interp alias depending on Tcl version) for the new object, whose name is the same as that of the namespace. Conversely, the destroy "method" deletes the namespace and "object command".
The create procedure has the call syntax
where output-channel must be a channel open for writing and input-channel must be a channel open for reading. The return value is the fully qualified name of the new link object.
As a special case, the input-channel may also be an empty string, in which case the link is set up with input already closed. This may be used to tie a link to a log file.
The first step is to create the instance variables. See other hubs documentation for details on what they do.
proc hubs::link::nschan::create {outputF inputF} {
variable inF $inputF
variable outF $outputF
variable Callback
array set Callback {
got {first_of_whatever 0}
undeliverable list
garbled list
error list
}
variable queue {}
variable openB 1
variable buffer {}
variable skimmingB 1The second step is to create the object command. The pre-8.5 implementation of this command is an alias to namespace inscope, which is a slight abuse of data, but works here since all method names are invariant under list-quoting.
if {[catch {
namespace export {[a-z]*}
namespace ensemble create
}]} then {
interp alias {} [namespace current] {}\
::namespace inscope [namespace current]
}
The input channel is set up to start receiving immediately, so it is important that the got callback is set before entering the event loop. The -blocking setting makes it possible to read everything transmitted from the other end of the link without knowing beforehand how much that is.
if {$inF == ""} then {
unset inF
} else {
fconfigure $inF -blocking 0 -translation binary
fileevent $inF readable [list [namespace current]::Receive 0]
}The -buffering setting here means there's no need to flush, but it also makes the need for the queue more pronounced. The \xC0\x8D sequence is written to make sure that any partial message in the channel gets properly terminated.
fconfigure $outF -blocking 0 -translation binary -buffering none
fileevent $outF writable {}
puts $outF \xC0\x8D
return [namespace current]
}
Again this little helper procedure that accepts any number of arguments and always returns the first. It is used as default for got callback, since the return value for this must be a boolean. Duplicating it in every link object is probably not necessary, but it's the easiest way to play it safe when booting remote interpreters.
proc hubs::link::nschan::first_of_whatever {args} {lindex $args 0}
The presence of a close method is awkward in that it shadows the core command close. Therefore the latter must be written as ::close in this namespace.
The call syntax of the close method is
proc hubs::link::nschan::close {msgL args} {
array set O {-listen 0 -immediate 0 -destroy 1}
array set O $args
variable openB 0
variable inF
variable outF
if {!$O(-listen) && [info exists inF]} then {
fileevent $inF readable {}
if {![info exists outF] || $inF!=$outF} then {::close $inF}
unset inF
}
variable Callback
variable queue
if {$O(-immediate) > 0} then {
foreach msg $queue {
eval [linsert $Callback(undeliverable) end $msg]
}
set queue {}
}
if {$O(-immediate) > 1} then {
set L {}
foreach var {outF inF} {
if {[info exists $var]} then {
lappend L [set $var]
unset var
}
}
foreach F [lsort -unique $L] {::close $F}
if {$O(-destroy)} then {destroy}
return
}
if {[info exists inF]} then {
fileevent $inF readable\
[list [namespace current]::Receive $O(-destroy)]
}
if {[info exists outF]} then {
fileevent $outF writable\
[list [namespace current]::Transmit $O(-destroy)]
foreach msg $msgL {lappend queue $msg}
} else {
foreach msg $msgL {
eval [linsert $Callback(undeliverable) end $msg]
}
}
if {$O(-destroy) && ![info exists inF] && ![info exists outF]}\
then {destroy}
}
In principle the same name collision exists for the destroy method (which here has to be implemented explicitly), but that's not an issue as we don't need the Tk destroy command.
This command takes no arguments, and is supposed to release all resources held by the object. This means:
proc hubs::link::nschan::destroy {} {
variable inF
if {[info exists inF]} then {catch {::close $inF}}
variable outF
if {[info exists outF]} then {catch {::close $outF}}
catch {rename [namespace current] ""}
namespace delete [namespace current]
}
The implementation of the callback method is now obvious. An error is thrown if the event is not among the array elements.
proc hubs::link::nschan::callback {event {prefix ""}} {
variable Callback
if {![info exists Callback($event)]} then {
error "Unknown event \"$event\": must be [
join [lsort -dictionary [array names Callback]] {, }
]"
}
if {[llength $prefix]} then {
set Callback($event) $prefix
} else {
return $Callback($event)
}
}
The put method arranges for a message to be sent. The actual transmission is handled by the Transmit method, which is called as a file event handler.
proc hubs::link::nschan::put {msg} {
variable queue
variable openB
variable outF
variable Callback
if {$openB} then {
lappend queue $msg
fileevent $outF writable [list [namespace current]::Transmit 0]
} else {
eval [linsert $Callback(undeliverable) end $msg]
}
}
This method is meant to be called from a fileevent writable handler, since it writes data to a non-buffering channel. The call syntax is
where destroy is true if the object is no longer open and it should be destroyed as soon as all traffic has completed. It's usually false, however.
proc hubs::link::nschan::Transmit {destroy} {
variable inF
variable outF
variable queue
variable openB
variable Callback
if {![llength $queue]} then {
if {$openB} then {
fileevent $outF writable {}
} else {
if {![info exists inF] || $inF!=$outF} then {::close $outF}
unset outF
if {$destroy && ![info exists inF]} then {destroy}
}
return
}
if {[catch {
puts $outF "[
encoding convertto utf-8 [lrange $queue 0 0]
]\xC0\x8D"
} res] == 0} then {
set queue [lreplace $queue 0 0]
return
}
set infoD [list -errorcode $::errorCode]
eval [linsert $Callback(error) end $res $infoD]
fileevent $outF writable {}
}
This method is the fileevent readable handler for incoming material. The call syntax is
where destroy is true if the object is no longer open and it should be destroyed as soon as all traffic has completed. It is usually false, however.
Errors when reading are reported straight off.
proc hubs::link::nschan::Receive {destroy} {
variable inF
variable buffer
variable Callback
if {[catch {
append buffer [read $inF]
} res]} then {
set infoD [list -errorcode $::errorCode]
eval [linsert $Callback(error) end $res $infoD]
}An end of file situation usually occurs when the link is closing down, but if it occurs unexpectedly then it is comparable to an error and reported as such. However, since no technical error occurred, there is no -errorcode entry in the dictionary. The error callback should close the link, but in case it doesn't, the Receive method will make the necessary call while telling the object to live on as a zombie. An extra end-of-message is appended to the buffer to make sure that everything read gets processed.
variable openB
variable outF
if {[info exists inF] && [eof $inF]} then {
if {$openB} then {
eval [linsert $Callback(error) end "Unexpected EOF" {}]
}
if {$openB} then {close {} -destroy 0}The calls above may have closed the input channel while we weren't looking, so it's necessary to check inF existence again.
if {[info exists inF]} then {
if {![info exists outF] || $outF!=$inF} then {
::close $inF
} else {
fileevent $inF readable {}
}
unset inF
}
append buffer \xC0\x8D
}After all that error and shutdown handling, we're now at the main part of this method: split off, decode, and handle the message(s) received. If ignoring is on, then turn it off instead of treating what is split off from the buffer as a message.
variable skimmingB
while {[
set pos [string first \xC0\x8D $buffer]
] >= 0} {
set chunk [string range $buffer 0 [expr {$pos-1}]]
set buffer [string range $buffer [expr {$pos+2}] end]
if {$skimmingB} then {
set skimmingB 0
} elseif {[catch {
encoding convertfrom utf-8 $chunk
} msg] || [catch {llength $msg} len] || $len>1} then {
eval [linsert $Callback(garbled) end $chunk $msg]
} elseif {$len == 1} then {
if {[
eval [linsert $Callback(got) end [lindex $msg 0]]
]} then {Another special case, which makes it possible to react immediately to a close message. It is important if the object has been deregistered by the hub but was still delivering incoming traffic, since the hub then cannot call the link object anymore.
if {[info exists inF]} then {
if {![info exists outF] || $outF!=$inF} then {
::close $inF
} else {
fileevent $inF readable {}
}
unset inF
}
break
}
}
}Finally one more point of shutdown: if the object is set to self-destruct and there's nothing more to do, then carry out that deed.
if {$destroy && ![info exists inF] && ![info exists outF]} then {
destroy
}
}
This final method reports the current state of the link.
proc hubs::link::nschan::state {} {
set res {}
variable outF
if {[info exists outF] && [llength [fileevent $outF writable]]}\
then {lappend res busy}
variable buffer
if {[regexp {\S} $buffer]} then {lappend res incoming}
variable skimmingB
if {$skimmingB} then {lappend res skimming}
variable openB
variable inF
if {!$openB} then {
if {[info exists outF] || [info exists inF]} then {
lappend res closing
} else {
lappend res zombie
}
}
if {![llength $res]} then {lappend res idle}
return $res
}
This procedure is meant to be called from unset traces on the inF and outF variables; it evaluates a script when both are unset. One application is to arrange for a child interpreter to exit when it loses contact with the parent.
The call syntax is
It is the namespace context of this procedure that is used to identify the link as a whole.
proc hubs::link::nschan::on_zombie {script args} {
variable inF
variable outF
if {![info exists inF] && ![info exists outF]} then $script
}
Since remote evaluation would be important for a remote booting system, it is implemented as a namespace with state (replies being waited upon and senders that have identified themselves).
namespace eval hubs::eval {}
This procedure takes a script, evaluates it, and returns the triplet
that one gets from catching this evaluation. It relies on the Tcl 8.5 extension (hence the name) of the catch command. The call syntax is
where prefix is a command prefix to which the script will be appended, to produce the command to be caught. Some prefixes of interest are:
proc hubs::eval::do-8.5 {prefix script} {
list [eval {catch [lappend prefix $script] res info}] $res $info
}Regarding the eval, see Tcl bug #2038069.
This procedure takes a script, evaluates it using a custom prefix, and returns the triple
that one gets from catching this evaluation. It is meant to work under Tcl 8.4 and earlier, so it does not use the info extension of the catch command, but instead takes -errorinfo and -errorcode from the global variables.
The call syntax is
proc hubs::eval::do-8.4 {prefix script} {
set status [eval {catch [lappend prefix $script] res}]
if {$status == 1} then {
list $status $res [
list -errorinfo $::errorInfo -errorcode $::errorCode
]
} else {
list $status $res {}
}
}The result from this command is different from that of do-8.5 in that it doesn't provide -level and -code entries in the info, but there is little point in faking these—renormalise the result if you need these entries.
This procedure is an extended catch command that never evaluates anything and always responds with an error.
proc hubs::eval::do-not {script} {
list 1 "Eval not supported" {-errorcode {hubs ENOTSUP}}
}
This procedure renormalises the
triplet returned by an extended catch command; it has the call syntax
and returns the renormalisation of the triplet. Renormalisation means:
proc hubs::eval::renormalise {triplet} {
foreach {status res info} $triplet break
if {![string is integer -strict $status]} then {
switch -- $status {
ok {set status 0}
error {set status 1}
return {set status 2}
break {set status 3}
continue {set status 4}
default {
return [list 1 "Bad status code \"$status\""\
[list -oldtriplet $triplet -level 0 -code 1\
-errorinfo "(renormalisation rewrite)"]]
}
}
}
array set A $info
if {$status != 2} then {
set A(-code) $status
set A(-level) 0
} else {
if {![info exists A(-level)]} then {set A(-level) 1}
if {![info exists A(-code)]} then {
set A(-code) 0
} elseif {![string is integer -strict $A(-code)]} then {
switch -- $A(-code) {
ok {set A(-code) 0}
error {set A(-code) 1}
return {set A(-code) 2}
break {set A(-code) 3}
continue {set A(-code) 4}
default {
return [list 1 "Bad -code \"$A(-code)\""\
[list -oldtriplet $triplet -level 0 -code 1\
-errorinfo "(renormalisation rewrite)"]]
}
}
}
if {$A(-code)==2} then {
incr A(-level)
set A(-code) 0
}
if {$A(-level) <= 0} then {
set status $A(-code)
set A(-level) 0
}
}
return [list $status $res [array get A]]
}
This is a wrapper around an extended catch command, which however itself has the syntax of an extended catch command. The idea is that it filters the result returned, preventing results that would have dangerous consequences if rethrown in the caller.
The call syntax is
where the xcatch-prefix is called (from the calling context) with the script as extra argument. The return value is a renormalised "status result info-dict" triplet.
The expression is an expression evaluated in the filter_result procedure. The result is only let through if this expression returns true. The status code is available in the status variable, the result is available in the res variable, and the info dictionary has been unrolled into the A array.
proc hubs::eval::filter_result {expr prefix script} {
foreach {status res info} [renormalise\
[uplevel 1 [lappend prefix $script]]] break
array set A $info
if $expr then {
return [list $status $res $info]
} else {
return [list 1 "Forbidden return status: $status"\
[list -code 1 -level 0 -oldtriplet [list $status $res $info]\
-errorinfo "(result filtering)"]]
}
}
This is a wrapper around an extended catch command, which however itself has the syntax of an extended catch command. This wrapper appends text to the -errorinfo (if there is any, otherwise it does nothing), which can be used to include extra information, e.g.~that this error has been transported from one process to another. The call syntax is
proc hubs::eval::extra_errorinfo {msg prefix script} {
set triplet [uplevel 1 [lappend prefix $script]]
array set A [lindex $triplet 2]
if {![info exists A(-errorinfo)]} then {return $triplet}
append A(-errorinfo) \n $msg
return [lreplace $triplet 2 2 [array get A]]
}
When a reply with identifier id is expected, the corresponding entry in this array is set to an empty list. When such a reply arrives, the entry is set to a three-element list
Typically, the entries in this array are being vwaited upon.
This procedure provides a dummy error reply to the largest entry in the reply array. It can (hopefully) be used to end a vwait for a reply that should have come back long ago. The call syntax is
where the arguments specify the error to leave as the result. The return value is the index into the reply array for the entry that was set, or an error if no entry to set existed.
proc hubs::eval::write_off_reply {args} {
if {[llength $args]<1} then {lappend args "Manual abort"}
if {[llength $args]<2} then {
lappend args "[lindex $args 0]\n by\n\"[info level 0]\"\n"
}
if {[llength $args]<3} then {lappend args {hubs ECANCELED}}
variable reply
foreach id [lsort -dictionary -decreasing [array names reply]] {
if {[llength $reply($id)]} then {continue}
set reply($id) [list 1 [lindex $args 0]\
[list -level 0 -code 1 -errorinfo [lindex $args 1]\
-errorcode [lindex $args 2]]]
return $id
}
error "No reply pending"
}
This array holds -presentations of masters. eval messages from masters that haven't presented themselves are typically rejected.
This procedure parses messages and handles them. The call syntax is
and the return value is a list of messages to send in return (usually zero or one reply messages).
do-cmd is the extended catch command used to actually evaluate scripts provided in eval messages; it is typically do-8.4 {uplevel #0} or ditto do-8.5. (However, if one uses an interp eval instead of the uplevel \#0 then it is possible to get better emulation of ordinary interpreter behaviour—concretely avoid visibly dropping out to level #0 just because of being in an event handler, because that happened in the interpreter handling messages, not the interpreter where the code is being evaluated.) from is a return address and id is a message identifier provided by a higher level mechanism; neither is parsed, and may be generated locally, but they are used in some cases.
proc hubs::eval::handlemsg {doprefix from id msg} {
switch -- [lindex $msg 0] "eval" {
set O(-id) $id
set O(-reply) 1
array set O [lreplace $msg 0 1]
variable master
if {[info exists O(-presentation)]} then {
set master($from) $O(-presentation)
} elseif {![info exists master($from)]} then {
return [list [list reply $O(-id) 1\
{Who is you to tell me what to do?}\
{-errorcode {hubs ENEEDAUTH}}]]
}
set res [eval [linsert $doprefix end [lindex $msg 1]]]
if {$O(-reply)} then {
return [list [linsert $res 0 reply $O(-id)]]
} else {
return ""
}
} "reply" {
variable reply
if {[info exists reply([lindex $msg 1])]} then {
set reply([lindex $msg 1]) [lrange $msg 2 end]
}
return ""
}
}
This procedure can be used to "glue" handlemsg directly to a link endpoint. It is meant to be called as the got handler of the link, and will put any replies back on the link. The call syntax is
where link is the link object (for replying), docmd is the extended catch command used to evaluate scripts in eval messages, from is where the message should count as coming from (index into the master array), and msg is the message itself.
proc hubs::eval::linkglue {link docmd from msg} {
foreach reply [
handlemsg $docmd $from {} $msg
] {
$link put $reply
}
return 0
}
This procedure is a kind of "interp catch" for child interpreters interfaced directly with a link endpoint. The call syntax is
and the return value is a triple status–result–info that is result of evaluating the script on the remote side.
The procedure calls vwait to wait for a reply, so it enters the event loop. It does not supply any -presentation of itself; you should do that separately if needed (see the end of hubs::interp::initchild for an example of how).
info cmdcount is used to generate an identifier for the reply.
proc hubs::eval::linkcatch {link script} {
set id [info cmdcount]
variable reply
set reply($id) {}
$link put [list eval $script -id $id]
vwait [namespace current]::reply($id)
set res $reply($id)
unset reply($id)
return $res
}
This procedure can be used as a hub handler for eval messages. It has the call syntax
and no particular return value. async is a boolean; if it is 1 then the procedure returns immediately and arranges for the message to be processed by an after 0 script, otherwise it is processed before the procedure returns. do-cmd is as for handlemsg. hub is the hub to use when sending replies (which ought to be the same as we're handling the event for, since that is where the from address is valid).
proc hubs::eval::hubglue {async docmd hub from id msg} {
if {$async} then {
after 0 [namespace code [list\
hubglue 0 $docmd $hub $from $id $msg]]
return
}
foreach reply [
handlemsg $docmd $from $id $msg
] {
eval [linsert $reply 0 $hub send $from ""]
}
}
This procedure can be used to "glue" handlemsg to the link side of a hubs::link::twist link endpoint. When doing so, one gets the partial illusion of having a hub at the other end, but the only thing this "hub" ever does is process eval and reply messages directed specifically to it; everything else gets a delivery nack.
The call syntax is
where the message is a connect, close, or envelope; only the last of these is actually processed. The mode is 1 if evaluation is to be handled asynchronously, 0 if it is to be handled synchronously, and -1 if it is to be handled synchronously and it has been verified that this is an envelope that we want to process. The prefix is the command prefix used for sending reply messages back over the link (typically an incoming method call).
proc hubs::eval::twistglue {mode docmd prefix msg} {
foreach {type to from id payload} $msg break
if {$mode>=0} then {
if {$type != "envelope"} then {return}
set done 1
if {$to != ""} then {
set ret [list delivery nack $id $to {No such connection}]
} elseif {[lindex $payload 0] != "eval" &&\
[lindex $payload 0] != "reply"} then {
set ret [list delivery nack $id {} {No handler for subject}]
} else {
set ret [list delivery ack $id [clock seconds]]
set done 0
}
if {$id != ""} then {
eval [linsert $prefix end [list envelope $from {} "" $ret]]
}
if {$done} then {return}
}
if {$mode==1} then {
after 0 [namespace code [list twistglue -1 $docmd $prefix $msg]]
return
}
foreach reply [
handlemsg $docmd $from $id $payload
] {
eval [linsert $prefix end [
list envelope $from {} "" $reply
]]
}
}
This procedure calls an extended catch command and throws its result back at the caller. The call syntax is
The idea is that a "slave eval" type command should be possible to implement as an alias to throw. The catch-cmd-prefix is the extended catch command prefix used. The mode specifies how the subsequent arguments should be turned into a script. The supported modes are:
| concat | The words of the script are concatenated into a script. This results in eval semantics. |
| just | There must be exactly one additional argument, and it is the script. This somewhat matches the catch behaviour. |
| lappend | The first word of the script is a list of words, and any additional words are appended to it. This results in namespace inscope semantics. |
| list | The words of the script constitute the list of words of the command. This is rather interp alias semantics. |
proc hubs::eval::throw-8.4 {catchprefix mode args} {
switch -- $mode "concat" {
set script [eval [list concat] $args]
} "just" {
if {[llength $args] != 1} then {
return -code error "wrong # args, must be:\
throw-8.4 <catchprefix> just <script>"
}
set script [lindex $args 0]
} "lappend" {
set script [lindex $args 0]
eval [list lappend script] [lrange $args 1 end]
} "list" {
set script $args
} default {
return -code error "Unknown script mode \"$mode\""
}
foreach {status result info} [
eval [linsert $catchprefix end $script]
] break
set call [list return -code $status]
if {$status == 1} then {
array set A $info
if {[info exists A(-errorinfo)]} then {
lappend call -errorinfo $A(-errorinfo)
}
if {[info exists A(-errorcode)]} then {
lappend call -errorcode $A(-errorcode)
}
}
eval [lappend call $result]
}
This procedure calls an extended catch command and throws its result back at the caller. It makes heavy use of extensions in Tcl 8.5. The call syntax is
The idea is that a "slave eval" type command should be possible to implement as an alias to throw. The catch-cmd-prefix is the extended catch command prefix used.
The level is an analogue of the -level option of the return command; the idea is that throw-8.5 should be thought of as a fancy return. If this is 0 then no details of throw-8.5 is shown in errorInfo tracebacks, but if it is 1 then also the caller is hidden, and so on. The level adjustment is an integer added to the -level value of the info dict returned by the catch-cmd, but only when the corresponding status value is 2. This is provided for compatibility with ordinary slave eval commands, which knock 1 off the return level; to get that effect use -1 for the level adjustment.
Other arguments are as for throw-8.4.
proc hubs::eval::throw-8.5 {lbase ladj catchprefix mode args} {
switch -- $mode "concat" {
set script [concat {*}$args]
} "just" {
if {[llength $args] != 1} then {
return -code error "wrong # args, must be:\
throw-8.5 <levelofs> <filter> <catchprefix> just <script>"
}
set script [lindex $args 0]
} "lappend" {
set script [lindex $args 0]
lappend script {*}[lrange $args 1 end]
} "list" {
set script $args
} default {
return -code error "Unknown script mode \"$mode\""
}
lassign [{*}$catchprefix $script] status result info
if {$status == 2} then {
set status [expr {[dict exists $info -code] ?\
[dict get $info -code] : 0}]
set level [expr {[dict exists $info -level] ?\
[dict get $info -level] : 1}]
if {$status == 2} then {incr level; set status 0}
incr level $ladj
if {$level<0} then {set level 0}
} else {
set level 0
}
incr level $lbase
incr level
return -options $info -level $level -code $status $result
}
namespace eval hubs::interp {}This procedure returns a script that recreates all procedures in the specified namespace. This script does not itself contain any namespace specifiers, which means if it is evaluated in a different namespace context it will create a copy of the original namespace. Such cloning of the hubs::link::nschan namespace is the motivating application of this procedure.
The call syntax is
Note that the return value only recreates the procedures, not aliases, imported commands, variables, or other things tied to the namespace.
An alternative to constructing a fully qualified command name is to call info from within the namespace using e.g. namespace inscope, but that would make info default create the variable d in that context.
proc hubs::interp::namespace_procs {ns} {
set procL [namespace eval $ns {::info procs}]
set res {}
foreach name $procL {
set call [list ::proc $name]
set full [namespace inscope $ns\
{::namespace which -command} $name]
set varL {}
foreach a [info args $full] {
if {[info default $full $a d]} then {
lappend varL [list $a $d]
} else {
lappend varL [list $a]
}
}
lappend call $varL [info body $full]
lappend res $call
}
return [join $res \n]
}
When defined, this command is an alias to throw-8.4 or throw-8.5 that sends an eval message back to the master. It has the call syntax
where mode specifies how the args make up the script sent. All replies are let through unaffected.
This procedure implements the various forms of the alias subcommand of a remote slave interpreter command. These are
The call syntax for this procedure is
where local is the slave command of a local interpreter that handles dispatch and remote is an extended catch command prefix that evaluates code in the remote interpreter.
There are some differences in behaviour between aliases created by this command and ordinary interp alias commands. Ordinary aliases live as long as their commands live, which means there can be several aliases created with the same cmd (if the aliases are renamed in between to prevent direct overwriting); this is the main reason there is a difference between alias command names and alias tokens. By contrast, a remote alias will be deleted whenever a new alias is creaed with a cmd equivalent to the cmd of the original alias, even if the original has been renamed. An alias can also be deleted on the remote side, but still appear to exist on the local side.
proc hubs::interp::alias {local remote token args} {
if {![llength $args]} then {
return [$local alias $token]
}
if {[lindex $args 0] == ""} then {
foreach {status res info} [
eval [linsert $remote end [
list ::interp alias {} $token {}
]]
] break
$local alias $token {}
} else {
regsub -all -- {:{2,}} ::$token :: token
foreach {status res info} [
eval [linsert $remote end "
catch {::interp alias {} [list $token] {}}
::interp alias {} [list $token] {}\
::hubs::interp::master_callback list [list $token]
"]
] break
if {$status != 0} then {One reason the above can fail is that it created an alias loop (an attempt was made to overwrite master_callback).
set A(-errorInfo) ""
array set A $info
return -code error -errorinfo $A(-errorinfo)\
"Could not create alias $token"
}
eval [list $local alias $token] $args
return $token
}
}
This procedure sends code to a child interpreter that sets it up as a link endpoint glued directly to handlemsg. The call syntax is
where channel is the channel which reads from stdout of the child and writes to stdin of the child; it is assumed that this is configured so that commands (restricted to using, say, an ascii character set) written to this channel will be correctly interpreted at the other end. extra is extra initialisation code that will be included in the output, just before the event loop is started (it is thus evaluated in the ::hubs namespace). create-endpoint is a command prefix which will eventually be called as
The presumption is that this will set up a link endpoint in the parent interpreter. The return value is the return value from that call.
The basic idea is to construct a huge namespace eval command that when evaluated in the child sets everything up and enters the event loop. This script has four main parts: hubs::link::nschan namespace, hubs::eval namespace, hubs::interp namespace, and setup code. The first three parts are easy to construct using namespace_procs. The whole $script below is going to be wrapped up in a namespace eval ::hubs when sent.
proc hubs::interp::initchild {prefix F extra} {
set script \n
append script [list namespace eval link::nschan "\n[
namespace_procs [namespace parent]::link::nschan
]\n"] \n
append script [list namespace eval eval "\n[
namespace_procs [namespace parent]::eval
]\n"] \n
append script [list namespace eval interp "\n[
namespace_procs [namespace parent]::interp
]\n"] \nSet-up means initialising the nschan endpoint and connecting it to handlemsg via linkglue. The only thing that is tricky in the latter is the need to have the child interpreter make the choice of do-8.4 or do-8.5.
append script [list link::nschan::create stdout stdin] {
link::nschan callback got [
list ::hubs::eval::linkglue ::hubs::link::nschan [
lindex {{do-8.4 {uplevel #0}} {do-8.5 {uplevel #0}}}\
[package vsatisfies [package provide Tcl] 8.5]
] ::hubs::link::nschan
]
}Conversely create an alias master_callback for sending eval messages back to the master. This has a similar dualism with respect to whether one should use throw-8.4 or throw-8.5.
append script {
eval {interp alias {} ::hubs::interp::master_callback {}} [
lindex {{::hubs::eval::throw-8.4}\
{::hubs::eval::throw-8.5 0 -1}}\
[package vsatisfies [package provide Tcl] 8.5]
] {{::hubs::eval::linkcatch ::hubs::link::nschan}}
}As a practical precausion, the child interpreter is set to exit if the connection closes. trace remove these traces if they are unwanted.
foreach var {link::nschan::inF link::nschan::outF} {
append script [list trace add variable $var unset\
{::hubs::link::nschan::on_zombie exit}] \n
}There is also the matter of making sure that tcl_interactive is off and actually starting the event loop.
append script [list set ::tcl_interactive 0] \n
append script $extra \n
append script [list vwait ::forever] \nWith that taken care of, it is time to send the script to the child. The exit command is there to kill the child if any error occurs at this stage (e.g. a typo in the extra code); since it is at a separate line, it would be evaluated next in that case, and otherwise it gets discarded by the remote link endpoint. The exit code 70 is in FreeBSD defined as signalling an internal software error.
puts $F [list ::namespace eval ::hubs $script]
puts $F {exit 70}
flush $FNow that all commands needed to set up the other end has been given, it is time to hand this end of the channel over to a link endpoint and set it up so that it can receive replies. Also, a first message with -presentation is sent so that these aren't needed later.
set link [eval [linsert $prefix end $F $F]]
$link callback got [list ::hubs::eval::linkglue $link do-not $link]
$link put {eval {} -reply 0 -presentation {}}That's it!
return $link }
This procedure creates a command which behaves somewhat like a "slave interp" command, but acts on a remote interpreter rather than a local one. Its call syntax is
where namespace is the namespace which will house everything related to this interpreter and channel is the channel to which it is connected. The supported options are:
The return value is the name of a "slave command" for the remote interpreter. It has the following subcommands:
| slave alias srcToken | Returns a Tcl list whose elements are the targetCmd and arguments associated with the alias represented by srcToken (this is the value returned when the alias was created; it is possible that the actual source command in the slave is different from srcToken). This form of the subcommand does not communicate with the remote interpreter. |
| slave alias srcToken {} | Deletes the alias for srcToken in the slave interpreter. srcToken refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. This form of the subcommand does communicate with the remote interpreter. To reduce errors, the remote part of the alias is deleted first. |
| slave alias srcCmd targetCmd ?arg ...? | Creates an alias such that whenever srcCmd is invoked in the slave, targetCmd is invoked in the master. The arg arguments will be passed to targetCmd as additional arguments, prepended before any arguments passed in the invocation of srcCmd. The command returns a token that uniquely identifies the command created as srcCmd, even if the command is renamed afterwards. The token may but does not have to be equal to srcCmd. |
| slave aliases | Returns a Tcl list whose elements are the tokens of all the aliases in the slave. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). This form of the subcommand does not communicate with the remote interpreter. |
| slave eval ?script-fragment ...? | This command concatenates the script-fragments and evaluates the result of that as a Tcl script in the slave. The result of this evaluation (including all return options, such as -errorinfo and -errorcode information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the global context of the slave; this is different from ordinary slave interpreters, where the script is executed in the current context stack frame of the slave. |
| slave exit | This command destroys the "slave command" wrapper, tells the remote interpreter to exit, and closes the link. It is intended as the normal way to shut down the remote interpreter. |
| slave link subcommand ?arg ...? | This command provides access to the underlying link endpoint object. |
| slave release | This command releases the link endpoint from the "slave command" wrapper, and returns the name of the link object. It also deletes all resources held by the slave command. This command does not communicate with the remote interpreter, so any aliases in it to commands in the master will continue to exist as commands. The dispatch at the master side is however changed to reject all eval messages. |
| slave xcatch script | This is an extended catch command which evaluates the script in the slave. It is similar to the eval subcommand, but avoids rethrowing the result, which (at least before Tcl 8.5) preserves more information. |
First: basic option processing.
proc hubs::interp::remote {ns F args} {
array set Opt {-extra {} -returnfilter 1}
array set Opt $argsSecond: set up namespace, subnamespace link for the link object, and the empty interpreter gutted through which callbacks are routed.
set ns [uplevel 1 [list ::namespace eval $ns {::namespace current}]]
namespace eval ${ns}::link [namespace_procs ::hubs::link::nschan]
interp create -safe ${ns}::gutted
${ns}::gutted eval {namespace delete ::}Third: initialise the remote interpreter and configure it so that callbacks go into the gutted interpreter.
set tcl8_5 [package vsatisfies [package provide Tcl] 8.5]
set linkcmd [initchild [list ${ns}::link::create] $F $Opt(-extra)]
$linkcmd callback got [list ::hubs::eval::linkglue $linkcmd [
list [lindex {do-8.4 do-8.5} $tcl8_5] [list ${ns}::gutted eval]
] $linkcmd]
set ::hubs::eval::master($linkcmd) ""Fourth: create the slave command. This is done as a bunch of aliases (although the -map option of a namespace ensemble might be easier) because this makes it possible to fake the ensemble in Tcl 8.4. The more elementary approach of using a proc is inferior because of the lack of return -level in those Tcl versions; it is important that throw-8.4 appears naked.
namespace eval ${ns}::slave {}
interp alias {} ${ns}::slave::alias {} ::hubs::interp::alias\
${ns}::gutted [list ::hubs::eval::linkcatch $linkcmd]
interp alias {} ${ns}::slave::aliases {} ${ns}::gutted aliases
set call [list interp alias {} ${ns}::slave::eval {}]
if {$tcl8_5} then {
lappend call ::hubs::eval::throw-8.5 0 -1
} else {
lappend call ::hubs::eval::throw-8.4
}
set xcatch [list ::hubs::eval::linkcatch $linkcmd]
set xcatch [list ::hubs::eval::filter_result [expr {
$Opt(-returnfilter) == "safe" ?
{$status==0 || $status==1} : $Opt(-returnfilter)
}] $xcatch]
set xcatch [list ::hubs::eval::extra_errorinfo\
" invoked by eval message on link\n\"$linkcmd\"" $xcatch]
lappend call $xcatch concat
eval $call
interp alias {} ${ns}::slave::link {} $linkcmd
proc ${ns}::slave::release {} "
[list $linkcmd callback got {first_of_whatever 0}]
[list ::rename ${ns}::gutted {}]
[list ::rename ${ns}::slave {}]
[list ::namespace delete ${ns}::slave]
[list ::return $linkcmd]
"
proc ${ns}::slave::exit {} {
[release] close {{eval exit -reply 0}} -destroy 1
}
interp alias {} ${ns}::slave::xcatch {}\
::hubs::eval::linkcatch $linkcmd
if {$tcl8_5} then {
namespace eval ${ns}::slave {
namespace export *
namespace ensemble create
}
} else {
interp alias {} ${ns}::slave {} namespace inscope ${ns}::slave
}
return ${ns}::slave
}
The following procedures demonstrate starting separate Tcl process and using hubs::interp::remote to set it up a as a remote slave interpreter. They have a number of options:
| -debug | Show extra information, to assist in debugging. The value is an integer. The default value is 0, meaning no debugging. If the value is at least 1, then messages are written to stderr that show the results of the major steps in the procedure. If the value is greater than 1 then stdin, stdout, and stderr of the child are copied/sent to the files in, out, and err respectively. (Copying uses the tee utility program.) |
| -debugdir | The directory in which the in, out, and err files are placed. Defaults to ~/tmp. |
| -extra | Extra init code evaluated by the remote interpreter just before it enters the event loop; this is supplied to initchild as the extra argument. Defaults to an empty string. |
| -prog | The executable name for the separate Tcl process. Defaults to tclsh. |
| -returnfilter | The filter expression used by hubs::eval::filter_result when returning results from the remote side. Defaults to 1. The special value safe is provided as a shorthand for only letting through ok' and error' returns. |
| -shake | Takes a boolean value. If true, then the command list [info hostname] [pid] [info nameofexecutable] [info patchlevel] is sent to the remote slave and the result is written to the master's stderr. This has the effect of waiting in the procedure until the remote interpreter is fully set up and ready. |
| -ssh | The name of the ssh executable, which is used by ssh_spawn. Defaults to ssh. |
This procedure starts a Tcl process on the local machine. It has the call syntax
and return the name of the remote interpreter's slave command.
proc hubs::interp::local_spawn {ns args} {
array set Opt {-debug 0 -debugdir ~/tmp -prog tclsh -shake 0}
array set Opt $args
set pipeline "| [list $Opt(-prog)]"
if {$Opt(-debug)>1} then {
set pipeline [concat |\
[list tee [file normalize [file join $Opt(-debugdir) in]]]\
$pipeline\
| [list tee [file normalize [file join $Opt(-debugdir) out]]\
2> [list [file join $Opt(-debugdir) err]]]]
}
if {$Opt(-debug)} then {puts stderr "Pipeline: $pipeline"}
set F [open $pipeline r+]
if {$Opt(-debug)} then {
puts stderr "Opened pipeline: $F, pid: [pid $F]"
}
set slave [uplevel 1\
[list [namespace which remote] $ns $F] $args]
if {$Opt(-debug)} then {puts stderr "Has interp $slave."}
if {$Opt(-shake)} then {
puts stderr "Hello, I'm [$slave eval {
list [info hostname] [pid] [info nameofexecutable]\
[info patchlevel]
}]"
}
return $slave
}
This procedure logs into some machine using ssh and starts the Tcl process to set up as remote slave there. It has the call syntax
and return the name of the remote interpreter's slave command. The host is a hostname or user@hostname for the machine to log into.
The default for the -shake option is 1, since it can otherwise in interactive use happen that ssh and the tclsh prompt compete for the password typed by the user.
proc hubs::interp::ssh_spawn {ns host args} {
array set Opt {-debug 0 -debugdir ~/tmp -prog tclsh -shake 1 -ssh ssh}
array set Opt $args
set pipeline "| $Opt(-ssh) [list $host $Opt(-prog)]"
if {$Opt(-debug)>1} then {
set pipeline [concat |\
[list tee [file normalize [file join $Opt(-debugdir) in]]]\
$pipeline\
| [list tee [file normalize [file join $Opt(-debugdir) out]]\
2> [list [file join $Opt(-debugdir) err]]]]
}
if {$Opt(-debug)} then {puts stderr "Pipeline: $pipeline"}
set F [open $pipeline r+]
if {$Opt(-debug)} then {
puts stderr "Opened pipeline: $F, pid: [pid $F]"
}
set slave [uplevel 1\
[list [namespace which remote] $ns $F] $args]
if {$Opt(-debug)} then {puts stderr "Has interp $slave."}
if {$Opt(-shake)} then {
puts stderr "Hello, I'm [$slave eval {
list [info hostname] [pid] [info nameofexecutable]\
[info patchlevel]
}]"
}
return $slave
}